diff options
Diffstat (limited to 'src/translate')
167 files changed, 73994 insertions, 0 deletions
diff --git a/src/translate/Makefile b/src/translate/Makefile new file mode 100644 index 0000000..b331b57 --- /dev/null +++ b/src/translate/Makefile @@ -0,0 +1,45 @@ +# -*- Makefile -*- for the GHDL translation back-end. +# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +# +# GHDL is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any later +# version. +# +# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING. If not, write to the Free +# Software Foundation, 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. + +BE=gcc +ortho_srcdir=../ortho +GNAT_FLAGS=-aI.. -aI../psl -gnaty3befhkmr -gnata -gnatf -gnatwael -gnat05 +#GNAT_FLAGS+=-O -gnatn +LN=ln -s + +compiler: force # ortho_nodes.ads ortho_$(BE)_front.ads + $(MAKE) -f $(ortho_srcdir)/$(BE)/Makefile \ + ortho_srcdir=$(ortho_srcdir) GNAT_FLAGS="$(GNAT_FLAGS)" \ + ortho_exec=ghdl1-$(BE) all + +all: + [ -d lib ] || mkdir lib + $(MAKE) -f $(ortho_srcdir)/gcc/Makefile \ + ortho_srcdir=$(ortho_srcdir) GNAT_FLAGS="$(GNAT_FLAGS)" \ + ortho_exec=ghdl1-gcc all + $(MAKE) -C ghdldrv + $(MAKE) -C grt all libdir=`pwd`/lib + $(MAKE) -C ghdldrv install.v87 install.v93 install.standard + +clean: + $(RM) *.o *.ali ghdl1-* gen_tree ortho_nodes-main b~*.ad? + $(RM) *~ ortho_nodes.ads ortho_nodes.tmp + +force: + +.PHONY: compiler clean force all diff --git a/src/translate/gcc/ANNOUNCE b/src/translate/gcc/ANNOUNCE new file mode 100644 index 0000000..7b1060e --- /dev/null +++ b/src/translate/gcc/ANNOUNCE @@ -0,0 +1,21 @@ +I am happy to introduce GHDL. + +GHDL is a GCC front-end for the VHDL (IEEE 1076) language, an hardware design +language. + +Currently, GHDL implements most of VHDL-1987 and some features of +VHDL-1993. It is mature enough to compile and run some complex design (such +as a DLX processor and leon1, a SPARCv7 processor) + +GHDL has been developped on a GNU/Linux x86 system, and only this configuration +has been tested (porting to other processor or system should not be an hard +task, but there are system dependent files in the run time). + +GHDL is written in Ada95 (using GNAT) and relies on agcc, an Ada +binding for GCC. It also includes a run-time library (written in Ada), named +grt. The front-end and the library are both distributed under the GPL licence. + +For sources, binary tarballs, or for more information, go to +http://ghdl.free.fr + +Tristan Gingold. diff --git a/src/translate/gcc/INSTALL b/src/translate/gcc/INSTALL new file mode 100644 index 0000000..e710f91 --- /dev/null +++ b/src/translate/gcc/INSTALL @@ -0,0 +1,24 @@ +Install file for the binary distribution of GHDL. + +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 +(at your option) any later version. + +The binary are installed in /usr/local directory. You cannot change this +default location, unless you set links. + +You must be root to install this distribution. + +To install ghdl: +$ su +# tar -C / -jxvf @TARFILE@.tar.bz2 + +Note: you must also have a C compiler and zlib installed. + +There is a mailing list for any questions. You can subscribe via: + https://mail.gna.org/listinfo/ghdl-discuss/ + +Tristan Gingold. + diff --git a/src/translate/gcc/Make-lang.in b/src/translate/gcc/Make-lang.in new file mode 100644 index 0000000..cde3e6c --- /dev/null +++ b/src/translate/gcc/Make-lang.in @@ -0,0 +1,190 @@ +# Top level -*- makefile -*- fragment for vhdl (GHDL). +# Copyright (C) 2002 +# Free Software Foundation, Inc. + +#This file is part of GNU CC. + +#GNU CC 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. + +#GNU CC 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 GNU CC; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, +#Boston, MA 02111-1307, USA. + +# This file provides the language dependent support in the main Makefile. +# Each language makefile fragment must provide the following targets: +# +# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap, +# foo.info, foo.dvi, +# foo.install-normal, foo.install-common, foo.install-info, foo.install-man, +# foo.uninstall, foo.mostlyclean, foo.clean, foo.distclean, foo.extraclean, +# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4 +# +# where `foo' is the name of the language. +# +# It should also provide rules for: +# +# - making any compiler driver (eg: g++) +# - the compiler proper (eg: cc1plus) +# - define the names for selecting the language in LANGUAGES. +# tool definitions +MV = mv +RM = rm -f + +# Extra flags to pass to recursive makes. +GHDL_ADAFLAGS= -Wall -gnata +VHDL_LIB_DIR=$(libsubdir)/vhdl +GNATBIND = gnatbind +GNATMAKE = gnatmake +VHDL_FLAGS_TO_PASS = \ + "GHDL_ADAFLAGS=$(GHDL_ADAFLAGS)" \ + "GNATMAKE=$(GNATMAKE)" \ + "GNATBIND=$(GNATBIND)" \ + "CFLAGS=$(CFLAGS)" \ + "VHDL_LIB_DIR=$(VHDL_LIB_DIR)" \ + "INSTALL_DATA=$(INSTALL_DATA)" \ + "INSTALL_PROGRAM=$(INSTALL_PROGRAM)" \ + "libexecsubdir=$(libexecsubdir)" + +MAKE_IN_VHDL=$(MAKE) -C vhdl $(FLAGS_TO_PASS) $(VHDL_FLAGS_TO_PASS) + +# Define the names for selecting vhdl in LANGUAGES. +vhdl VHDL: ghdl1$(exeext) ghdl$(exeext) ghdllib + +# Tell GNU Make to ignore these, if they exist. +.PHONY: vhdl VHDL ghdllib + +#ortho-lang.o: $(agcc_srcdir)/ortho-lang.c \ +# $(AGCC_GCCOBJ_DIR)gcc/gtype-vhdl.h \ +# $(AGCC_GCCOBJ_DIR)gcc/gt-vhdl-ortho-lang.h +# $(COMPILER) -c -o $@ $< $(AGCC_CFLAGS) $(INCLUDES) + +GHDL1_OBJS = attribs.o vhdl/ortho-lang.o + +# To be put in ALL_HOST_FRONTEND_OBJS, so that generated files are created +# before. +vhdl_OBJS=vhdl/ortho-lang.o + +# The compiler proper. +# It is compiled into the vhdl/ subdirectory to avoid file name clashes but +# linked in in gcc directory to be able to access to gcc object files. +ghdl1$(exeext): force $(GHDL1_OBJS) $(BACKEND) $(LIBDEPS) + CURDIR=`pwd`; cd $(srcdir)/vhdl; VHDLSRCDIR=`pwd`; cd $$CURDIR/vhdl; \ + $(GNATMAKE) -c -aI$$VHDLSRCDIR ortho_gcc-main \ + -cargs $(CFLAGS) $(GHDL_ADAFLAGS) + $(GNATMAKE) -o $@ -aI$(srcdir)/vhdl -aOvhdl ortho_gcc-main \ + -bargs -E -cargs $(CFLAGS) $(GHDL_ADAFLAGS) \ + -largs --LINK=$(LLINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) $(GHDL1_OBJS) \ + $(filter-out main.o,$(BACKEND)) $(LIBS) $(BACKENDLIBS) + +# The driver for ghdl. +ghdl$(exeext): force + $(MAKE_IN_VHDL) ../ghdl$(exeext) + +# Ghdl libraries. +ghdllib: ghdl$(exeext) ghdl1$(exeext) $(GCC_PASSES) force + $(MAKE_IN_VHDL) GRT_FLAGS="-O -g" $(FLAGS_TO_PASS) \ + ADAC=$(COMPILER_FOR_BUILD) ghdllib + +# Build hooks: + +vhdl.all.build: + +vhdl.all.cross: + @echo "No support for building vhdl cross-compiler" + exit 1 + +vhdl.start.encap: +vhdl.rest.encap: + +# Documentation hooks +doc/ghdl.info: vhdl/ghdl.texi + -rm -f doc/ghdl.info* + $(MAKEINFO) $(MAKEINFOFLAGS) -o $@ $< + +doc/ghdl.dvi: vhdl/ghdl.texi + $(TEXI2DVI) -o $@ $< + +vhdl.info: doc/ghdl.info + +vhdl.man: + +vhdl.dvi: doc/ghdl.dvi + +vhdl.generated-manpages: + +# Install hooks: +# ghdl1 is installed elsewhere as part of $(COMPILERS). + +vhdl.install-normal: + +vhdl.install-plugin: + +# Install the driver program as ghdl. +vhdl.install-common: ghdl$(exeext) + -mkdir $(DESTDIR)$(bindir) + -$(RM) $(DESTDIR)$(bindir)/ghdl$(exeext) + $(INSTALL_PROGRAM) ghdl$(exeext) $(DESTDIR)$(bindir)/ghdl$(exeext) +# Install the library + $(MAKE_IN_VHDL) install-ghdllib + +install-info:: $(DESTDIR)$(infodir)/ghdl.info + +vhdl.install-info: doc/ghdl.info + -rm -rf $(infodir)/ghdl.info* + $(INSTALL_DATA) doc/ghdl.info* $(DESTDIR)$(infodir) + -chmod a-x $(DESTDIR)$(infodir)/ghdl.info* + +install-ghdllib: + $(MAKE) -f vhdl/Makefile $(FLAGS_TO_PASS) $(VHDL_FLAGS_TO_PASS) install-ghdllib + +vhdl.install-man: $(DESTDIR)$(man1dir)/ghdl$(man1ext) + +$(DESTDIR)$(man1dir)/ghdl$(man1ext): $(srcdir)/vhdl/ghdl.1 + -rm -f $@ + -$(INSTALL_DATA) $< $@ + -chmod a-x $@ + +vhdl.uninstall: + -$(RM) $(DESTDIR)$(bindir)/ghdl$(exeext) + + +# Clean hooks: +# A lot of the ancillary files are deleted by the main makefile. +# We just have to delete files specific to us. + +vhdl.mostlyclean: + -$(RM) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c +vhdl.clean: + -$(RM) vhdl/*$(objext) +vhdl.distclean: + -$(RM) vhdl/Makefile + -$(RM) ghdl$(exeext) +vhdl.extraclean: + +vhdl.maintainer-clean: + + +# Stage hooks: +# The main makefile has already created stage?/vhdl + +vhdl.stage1: + -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage1/vhdl + -$(MV) vhdl/stamp-* stage1/vhdl +vhdl.stage2: + -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage2/vhdl + -$(MV) vhdl/stamp-* stage2/vhdl +vhdl.stage3: + -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage3/vhdl + -$(MV) vhdl/stamp-* stage3/vhdl +vhdl.stage4: + -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage4/vhdl + -$(MV) vhdl/stamp-* stage4/vhdl diff --git a/src/translate/gcc/Makefile.in b/src/translate/gcc/Makefile.in new file mode 100644 index 0000000..13f3296 --- /dev/null +++ b/src/translate/gcc/Makefile.in @@ -0,0 +1,299 @@ +# Makefile for GNU vhdl Compiler (GHDL). +# Copyright (C) 2002 Free Software Foundation, Inc. + +#This file is part of GNU CC. + +#GNU CC 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. + +#GNU CC 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 GNU CC; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, +#Boston, MA 02111-1307, USA. + +# The makefile built from this file lives in the language subdirectory. +# It's purpose is to provide support for: +# +# 1) recursion where necessary, and only then (building .o's), and +# 2) building and debugging cc1 from the language subdirectory, and +# 3) nothing else. +# +# The parent makefile handles all other chores, with help from the +# language makefile fragment, of course. +# +# The targets for external use are: +# all, TAGS, ???mostlyclean, ???clean. + +# This makefile will only work with Gnu make. +# The rules are written assuming a minimum subset of tools are available: +# +# Required: +# MAKE: Only Gnu make will work. +# MV: Must accept (at least) one, maybe wildcard, source argument, +# a file or directory destination, and support creation/ +# modification date preservation. Gnu mv -f works. +# RM: Must accept an arbitrary number of space separated file +# arguments, or one wildcard argument. Gnu rm works. +# RMDIR: Must delete a directory and all its contents. Gnu rm -rf works. +# ECHO: Must support command line redirection. Any Unix-like +# shell will typically provide this, otherwise a custom version +# is trivial to write. +# LN: ln -s works, cp should work bu was not tested. +# CP: GNU cp -p works. +# AR: Gnu ar works. +# MKDIR: Gnu mkdir works. +# CHMOD: Gnu chmod works. +# true: Does nothing and returns a normal successful return code. +# pwd: Prints the current directory on stdout. +# cd: Change directory. + +# Tell GNU make 3.79 not to run this directory in parallel. +# Not all of the required dependencies are present. +.NOTPARALLEL: + +# Variables that exist for you to override. +# See below for how to change them for certain systems. + +ALLOCA = +# Various ways of specifying flags for compilations: +# CFLAGS is for the user to override to, e.g., do a bootstrap with -O2. +# BOOT_CFLAGS is the value of CFLAGS to pass +# to the stage2 and stage3 compilations +# XCFLAGS is used for most compilations but not when using the GCC just built. +XCFLAGS = +CFLAGS = -g +BOOT_CFLAGS = -O $(CFLAGS) +# These exists to be overridden by the x-* and t-* files, respectively. +X_CFLAGS = +T_CFLAGS = + +X_CPPFLAGS = +T_CPPFLAGS = + +X_ADAFLAGS = +T_ADAFLAGS = + +ADAC = $(CC) + +ECHO = echo +CHMOD = chmod +CP = cp -p +MV = mv -f +RM = rm -f +RMDIR = rm -rf +MKDIR = mkdir -p +LN = ln -s +AR = ar +# How to invoke ranlib. +RANLIB = ranlib +# Test to use to see whether ranlib exists on the system. +RANLIB_TEST = [ -f /usr/bin/ranlib -o -f /bin/ranlib ] +SHELL = /bin/sh +INSTALL_DATA = install -m 644 +MAKEINFO = makeinfo +TEXI2DVI = texi2dvi +GNATBIND = gnatbind +GNATMAKE = gnatmake +ADA_CFLAGS = $(CFLAGS) +GHDL_ADAFLAGS = -Wall -gnata + +objext = .o +exeext = +arext = .a +soext = .so +shext = + +HOST_CC=$(CC) +HOST_CFLAGS=$(ALL_CFLAGS) +HOST_CLIB=$(CLIB) +HOST_LDFLAGS=$(LDFLAGS) +HOST_CPPFLAGS=$(ALL_CPPFLAGS) +HOST_ALLOCA=$(ALLOCA) +HOST_MALLOC=$(MALLOC) +HOST_OBSTACK=$(OBSTACK) + +# We don't use cross-make. Instead we use the tools from the build tree, +# if they are available. +# program_transform_name and objdir are set by configure.in. +program_transform_name = +objdir = . + +target=@target@ +target_alias=@target_alias@ +target_noncanonical:=@target_noncanonical@ +xmake_file=@dep_host_xmake_file@ +tmake_file=@dep_tmake_file@ +#version=`sed -e 's/.*\"\([^ \"]*\)[ \"].*/\1/' < $(srcdir)/version.c` +#mainversion=`sed -e 's/.*\"\([0-9]*\.[0-9]*\).*/\1/' < $(srcdir)/version.c` + +# Directory where sources are, from where we are. +srcdir = @srcdir@ +VPATH = @srcdir@ + +# Top build directory, relative to here. +top_builddir = .. + +version := $(shell cat $(srcdir)/../BASE-VER) + +# End of variables for you to override. + +# Definition of `all' is here so that new rules inserted by sed +# do not specify the default target. +all: all.indirect + +# This tells GNU Make version 3 not to put all variables in the environment. +.NOEXPORT: + +# Now figure out from those variables how to compile and link. + +all.indirect: Makefile + +# This tells GNU make version 3 not to export all the variables +# defined in this file into the environment. +.NOEXPORT: + +Makefile: $(srcdir)/Makefile.in $(srcdir)/../configure + cd ..; $(SHELL) config.status + +force: + +SED=sed + +drvdir/default_pathes.ads: drvdir Makefile + echo "-- DO NOT EDIT" > tmp-dpathes.ads + echo "-- This file is created by Makefile" >> tmp-dpathes.ads + echo "package Default_Pathes is" >> tmp-dpathes.ads + echo " -- Accept long lines." >> tmp-dpathes.ads + echo " pragma Style_Checks (\"M999\");" >> tmp-dpathes.ads + echo " Install_Prefix : constant String :=" >> tmp-dpathes.ads + echo " \"$(exec_prefix)\";" >> tmp-dpathes.ads + echo " Compiler_Gcc : constant String :=" >> tmp-dpathes.ads + echo " \"libexec/gcc/$(target_noncanonical)/$(version)/ghdl1$(exeext)\";" >> tmp-dpathes.ads + echo " Compiler_Debug : constant String := \"\";" >> tmp-dpathes.ads + echo " Compiler_Mcode : constant String := \"\";" >> tmp-dpathes.ads + echo " Compiler_Llvm : constant String := \"\";" >> tmp-dpathes.ads + echo " Post_Processor : constant String := \"\";" >> tmp-dpathes.ads + echo " Lib_Prefix : constant String :=">> tmp-dpathes.ads + echo " \"lib/gcc/$(target_noncanonical)/$(version)/vhdl/lib/\";" >> tmp-dpathes.ads + echo "end Default_Pathes;" >> tmp-dpathes.ads + $(srcdir)/../../move-if-change tmp-dpathes.ads $@ + +../ghdl$(exeext): drvdir drvdir/default_pathes.ads force + CURDIR=`pwd`; cd $(srcdir); SRCDIR=`pwd`; cd $$CURDIR/drvdir; \ + $(GNATMAKE) -o ../$@ -aI$$SRCDIR/ghdldrv -aI$$SRCDIR -aO.. ghdl_gcc \ + -bargs -E -cargs $(ADA_CFLAGS) $(GHDL_ADAFLAGS) -largs $(LIBS) + +drvdir: + mkdir $@ + +clean: grt-clean ghdllibs-clean force + $(RM) *.o *.ali + $(RM) default_pathes.ads + +# Additionnal rules + +LIB87_DIR:=./lib/v87 +LIB93_DIR:=./lib/v93 +LIB08_DIR:=./lib/v08 +LIBSRC_DIR:=$(srcdir)/libraries +ANALYZE=../ghdl -a --GHDL1=../ghdl1 --ieee=none + +$(LIB93_DIR) $(LIB87_DIR): + $(srcdir)/../../mkinstalldirs $@ + +####libraries Makefile.inc + +std87_standard.o: $(GHDL1) + $(GHDL1) --std=87 -quiet -o std_standard.s --compile-standard + ../xgcc -c -o std_standard.o std_standard.s + $(MV) std_standard.o $@ + +std93_standard.o: $(GHDL1) + $(GHDL1) --std=93 -quiet -o std_standard.s --compile-standard + ../xgcc -c -o std_standard.o std_standard.s + $(MV) std_standard.o $@ + +std08_standard.o: $(GHDL1) + $(GHDL1) --std=08 -quiet -o std_standard.s --compile-standard + ../xgcc -c -o std_standard.o std_standard.s + $(MV) std_standard.o $@ + +ghdllib: std87_standard.o std93_standard.o std08_standard.o libgrt.a + +ghdllibs-clean: force + $(RM) -rf $(LIB87_DIR) $(LIB93_DIR) $(LIB08_DIR) + +PHONY: ghdllib ghdllibs-clean + +GHDL1=../ghdl1 +GRTSRCDIR=$(srcdir)/grt +GRT_RANLIB=$(RANLIB) + +####grt Makefile.inc + +install-ghdllib: ghdllib grt.lst $(STD93_SRCS) $(STD87_SRCS) \ + $(IEEE93_SRCS) $(IEEE87_SRCS) $(SYNOPSYS_SRCS) \ + $(STD08_SRCS) $(IEEE08_SRCS) + $(RM) -rf $(DESTDIR)$(VHDL_LIB_DIR) + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR) +# Install libgrt + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib + $(INSTALL_DATA) libgrt.a $(DESTDIR)$(VHDL_LIB_DIR)/lib/libgrt.a + $(INSTALL_DATA) grt.lst $(DESTDIR)$(VHDL_LIB_DIR)/lib/grt.lst + $(INSTALL_DATA) $(GRTSRCDIR)/grt.ver $(DESTDIR)$(VHDL_LIB_DIR)/lib/grt.ver +# Install VHDL sources. + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/std + for i in $(STD93_SRCS) $(STD87_SRCS) $(STD08_SRCS); do \ + $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/std; \ + done + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee + for i in $(IEEE93_SRCS) $(IEEE87_SRCS); do \ + $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee; \ + done + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/vital95 + for i in $(VITAL95_SRCS); do \ + $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/vital95; \ + done + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/vital2000 + for i in $(VITAL2000_SRCS); do \ + $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/vital2000; \ + done + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/synopsys + for i in $(SYNOPSYS_SRCS); do \ + $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/synopsys; \ + done + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/mentor + for i in $(MENTOR93_SRCS); do \ + $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/mentor; \ + done + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee2008 + for i in $(IEEE08_SRCS); do \ + $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee2008; \ + done +# Create library dirs + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib/v93 + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib/v87 + $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib/v08 +# Compile in place. + PDIR=`pwd` && cd $(DESTDIR)$(VHDL_LIB_DIR) && \ + $(MAKE) -f $$PDIR/Makefile REL_DIR=../../.. LIBSRC_DIR="src" \ + LIB93_DIR=lib/v93 LIB87_DIR=lib/v87 LIB08_DIR=lib/v08 \ + ANALYZE="$$PDIR/../ghdl -a --GHDL1=$$PDIR/../ghdl1 --ieee=none" \ + std.v87 ieee.v87 synopsys.v87 \ + std.v93 ieee.v93 synopsys.v93 mentor.v93 \ + std.v08 ieee.v08 +# Copy std_standard (this is done after libraries, since they remove dirs). + $(INSTALL_DATA) std87_standard.o \ + $(DESTDIR)$(VHDL_LIB_DIR)/lib/v87/std/std_standard.o + $(INSTALL_DATA) std93_standard.o \ + $(DESTDIR)$(VHDL_LIB_DIR)/lib/v93/std/std_standard.o + $(INSTALL_DATA) std08_standard.o \ + $(DESTDIR)$(VHDL_LIB_DIR)/lib/v08/std/std_standard.o diff --git a/src/translate/gcc/README b/src/translate/gcc/README new file mode 100644 index 0000000..1152e99 --- /dev/null +++ b/src/translate/gcc/README @@ -0,0 +1,87 @@ +This is the README from the source distribution of GHDL. + +To get the binary distribution or more information, go to http://ghdl.free.fr + +Copyright: +********** +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 +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program 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 this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. + + +Building GHDL from sources: +*************************** + +Required: +* the sources of @GCCVERSION@ (at least the core part). + Note: other versions of gcc sources have not been tested. +* the Ada95 GNAT compiler (GNAT GPL 2008 are known to work; + Ada compilers in most Linux distributions are more or less buggy) +* GNU/Linux for ix86 (pc systems) (porting is necessary for other systems) + +Procedure: +* Check your Ada compiler. On some systems (or with some distribution), the + GNAT compiler seems broken. Try this very simple example, using file + example.adb +<<<<<<<<<<<<<<<<<< +procedure Example is +begin + null; +end Example; +<<<<<<<<<<<<<<<<<< + Compile with + $ gnatmake example + It should create an executable, 'example'. + If this doesn't work, your GNAT installation is broken. It may be a PATH + problem or something else. +* untar the gcc tarball +* untar the ghdl tarball (this sould have been done, since you are reading a + file from it). +* move or copy the vhdl directory of ghdl into the gcc subdirectory of + 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. 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. + +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. + +* Note for ppc64 (and AIX ?) platform: +The object file format contains an identifier for the source language. Because +gcc doesn't know about the VHDL, gcc crashes very early. This could be fixed +with a very simple change in gcc/config/rs6000/rs6000.c, +function rs6000_output_function_epilogue (as of gcc 4.8): + else if (! strcmp (language_string, "GNU Objective-C")) + i = 14; + else +- gcc_unreachable (); ++ i = 0; + fprintf (file, "%d,", i); + + /* 8 single bit fields: global linkage (not set for C extern linkage, + +Tristan Gingold. diff --git a/src/translate/gcc/config-lang.in b/src/translate/gcc/config-lang.in new file mode 100644 index 0000000..7010b11 --- /dev/null +++ b/src/translate/gcc/config-lang.in @@ -0,0 +1,38 @@ +# Top level configure fragment for GNU vhdl (GHDL). +# Copyright (C) 1994-2001 Free Software Foundation, Inc. + +#This file is part of GNU CC. + +#GNU CC 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. + +#GNU CC 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 GNU CC; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, +#Boston, MA 02111-1307, USA. + +# Configure looks for the existence of this file to auto-config each language. +# We define several parameters used by configure: +# +# language - name of language as it would appear in $(LANGUAGES) +# boot_language - "yes" if we need to build this language in stage1 +# compilers - value to add to $(COMPILERS) +# stagestuff - files to add to $(STAGESTUFF) + +language="vhdl" +boot_language=no + +compilers="ghdl1\$(exeext)" + +stagestuff="ghdl\$(exeext) ghdl1\$(exeext)" + +outputs=vhdl/Makefile + +gtfiles="\$(srcdir)/vhdl/ortho-lang.c" diff --git a/src/translate/gcc/dist-common.sh b/src/translate/gcc/dist-common.sh new file mode 100644 index 0000000..ad22297 --- /dev/null +++ b/src/translate/gcc/dist-common.sh @@ -0,0 +1,337 @@ +# ghdl core files +cfiles=" +evaluation.adb +evaluation.ads +scanner.ads +scanner.adb +scanner-scan_literal.adb +back_end.ads +back_end.adb +files_map.adb +files_map.ads +sem.adb +sem.ads +sem_expr.adb +sem_expr.ads +sem_names.adb +sem_names.ads +sem_scopes.adb +sem_scopes.ads +sem_decls.ads +sem_decls.adb +sem_inst.ads +sem_inst.adb +sem_specs.ads +sem_specs.adb +sem_stmts.ads +sem_stmts.adb +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 +configuration.ads +nodes.ads +nodes.adb +nodes_gc.ads +nodes_gc.adb +nodes_meta.ads +nodes_meta.adb +options.ads +options.adb +psl-errors.ads +lists.ads +lists.adb +iirs.adb +iirs.ads +iir_chains.ads +iir_chains.adb +iir_chain_handling.ads +iir_chain_handling.adb +iirs_walk.ads +iirs_walk.adb +std_names.adb +std_names.ads +disp_tree.adb +disp_tree.ads +iirs_utils.adb +iirs_utils.ads +std_package.adb +std_package.ads +disp_vhdl.adb +disp_vhdl.ads +libraries.adb +libraries.ads +tokens.adb +tokens.ads +name_table.adb +name_table.ads +str_table.ads +str_table.adb +types.ads +version.ads +errorout.adb +errorout.ads +parse.adb +parse.ads +parse_psl.ads +parse_psl.adb +post_sems.ads +post_sems.adb +ieee.ads +ieee-std_logic_1164.ads +ieee-std_logic_1164.adb +ieee-vital_timing.ads +ieee-vital_timing.adb +xrefs.ads +xrefs.adb +bug.ads +bug.adb +" + +# translation file +tfiles=" +translation.adb +ortho_front.adb +translation.ads +trans_decls.ads +trans_be.ads +trans_be.adb +trans_analyzes.ads +trans_analyzes.adb" + +ortho_files=" +ortho_front.ads" + +ortho_gcc_files=" +lang.opt +ortho-lang.c +ortho_gcc-main.adb +ortho_gcc-main.ads +ortho_gcc.adb +ortho_gcc.ads +ortho_gcc_front.ads +ortho_ident.adb +ortho_ident.ads +ortho_nodes.ads +" + +ghdl_files=" +ghdl_gcc.adb +ghdldrv.ads +ghdldrv.adb +ghdlprint.ads +ghdlprint.adb +ghdllocal.ads +ghdllocal.adb +ghdlmain.ads +ghdlmain.adb +" + +libraries_files=" +std/textio.vhdl +std/textio_body.vhdl +std/env.vhdl +std/env_body.vhdl +ieee/README.ieee +ieee/numeric_bit-body.vhdl +ieee/numeric_bit.vhdl +ieee/numeric_std-body.vhdl +ieee/numeric_std.vhdl +ieee/std_logic_1164.vhdl +ieee/std_logic_1164_body.vhdl +ieee/math_real.vhdl +ieee/math_real-body.vhdl +ieee/math_complex.vhdl +ieee/math_complex-body.vhdl +ieee2008/README.ieee +ieee2008/fixed_float_types.vhdl +ieee2008/fixed_generic_pkg-body.vhdl +ieee2008/fixed_generic_pkg.vhdl +ieee2008/fixed_pkg.vhdl +ieee2008/float_generic_pkg-body.vhdl +ieee2008/float_generic_pkg.vhdl +ieee2008/float_pkg.vhdl +ieee2008/math_complex-body.vhdl +ieee2008/math_complex.vhdl +ieee2008/math_real-body.vhdl +ieee2008/math_real.vhdl +ieee2008/numeric_bit-body.vhdl +ieee2008/numeric_bit.vhdl +ieee2008/numeric_bit_unsigned-body.vhdl +ieee2008/numeric_bit_unsigned.vhdl +ieee2008/numeric_std-body.vhdl +ieee2008/numeric_std.vhdl +ieee2008/numeric_std_unsigned-body.vhdl +ieee2008/numeric_std_unsigned.vhdl +ieee2008/std_logic_1164-body.vhdl +ieee2008/std_logic_1164.vhdl +ieee2008/std_logic_textio.vhdl +vital95/vital_primitives.vhdl +vital95/vital_primitives_body.vhdl +vital95/vital_timing.vhdl +vital95/vital_timing_body.vhdl +vital2000/memory_b.vhdl +vital2000/memory_p.vhdl +vital2000/prmtvs_b.vhdl +vital2000/prmtvs_p.vhdl +vital2000/timing_b.vhdl +vital2000/timing_p.vhdl +synopsys/std_logic_arith.vhdl +synopsys/std_logic_misc.vhdl +synopsys/std_logic_misc-body.vhdl +synopsys/std_logic_signed.vhdl +synopsys/std_logic_textio.vhdl +synopsys/std_logic_unsigned.vhdl +mentor/std_logic_arith.vhdl +mentor/std_logic_arith_body.vhdl +" + +grt_files=" +grt-cbinding.c +grt-cvpi.c +grt.adc +grt-astdio.ads +grt-astdio.adb +grt-avhpi.adb +grt-avhpi.ads +grt-avls.ads +grt-avls.adb +grt-c.ads +grt-disp.adb +grt-disp.ads +grt-disp_rti.adb +grt-disp_rti.ads +grt-disp_tree.adb +grt-disp_tree.ads +grt-disp_signals.adb +grt-disp_signals.ads +grt-errors.adb +grt-errors.ads +grt-files.adb +grt-files.ads +grt-hooks.adb +grt-hooks.ads +grt-images.adb +grt-images.ads +grt-lib.adb +grt-lib.ads +grt-main.adb +grt-main.ads +grt-modules.ads +grt-modules.adb +grt-names.adb +grt-names.ads +grt-options.adb +grt-options.ads +grt-processes.adb +grt-processes.ads +grt-rtis.ads +grt-rtis.adb +grt-rtis_addr.adb +grt-rtis_addr.ads +grt-rtis_utils.adb +grt-rtis_utils.ads +grt-rtis_binding.ads +grt-rtis_types.ads +grt-rtis_types.adb +grt-sdf.adb +grt-sdf.ads +grt-shadow_ieee.ads +grt-shadow_ieee.adb +grt-signals.adb +grt-signals.ads +grt-stack2.adb +grt-stack2.ads +grt-stacks.adb +grt-stacks.ads +grt-stats.ads +grt-stats.adb +grt-stdio.ads +grt-table.ads +grt-table.adb +grt-types.ads +grt-unithread.ads +grt-unithread.adb +grt-values.adb +grt-values.ads +grt-vcd.adb +grt-vcd.ads +grt-vcdz.adb +grt-vcdz.ads +grt-vital_annotate.adb +grt-vital_annotate.ads +grt-vpi.adb +grt-vpi.ads +grt-vstrings.adb +grt-vstrings.ads +grt-waves.ads +grt-waves.adb +grt-zlib.ads +grt-threads.ads +grt-arch_none.ads +grt-arch_none.adb +grt-std_logic_1164.ads +grt-std_logic_1164.adb +grt.ads +main.adb +main.ads +ghdl_main.ads +ghdl_main.adb +ghwlib.h +ghwlib.c +ghwdump.c +grt.ver +" + +grt_config_files=" +i386.S +sparc.S +ppc.S +ia64.S +amd64.S +times.c +clock.c +linux.c +pthread.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" diff --git a/src/translate/gcc/dist.sh b/src/translate/gcc/dist.sh new file mode 100755 index 0000000..8632dc5 --- /dev/null +++ b/src/translate/gcc/dist.sh @@ -0,0 +1,471 @@ +#!/bin/sh + +# Script used to create tar balls. +# Copyright (C) 2002, 2003, 2004, 2005, 2006 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. + +# Building a distribution: +# * update the 'version' variable in ../../Makefile +# * Regenerate version.ads: make -f ../../Makefile version.ads +# * Check NEWS, README and INSTALL files. +# * Check version and copyright years in doc/ghdl.texi, ghdlmain.adb +# * Check GCCVERSION below. +# * Check lists of exported files in this file. +# * Create source tar and build binaries: ./dist.sh dist_phase1 +# * su root +# * 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) +# * CVS commit, tag + cd image. +# * remove previous version in /usr/local + +## DO NOT MODIFY this file while it is running... + +set -e + +# GCC version +GCCVERSION=4.9.2 +# Machine name used by GCC +MACHINE=${MACHINE:i686-pc-linux-gnu} +# Directory where GCC sources (and objects) stay. +DISTDIR=${DISTDIR:-$HOME/dist} +# GTKWave version. +GTKWAVE_VERSION=3.3.50 + +# GHDL version (extracted from version.ads) +VERSION=`sed -n -e 's/.*GHDL \([0-9.a-z]*\) (.*/\1/p' ../../version.ads` + +CWD=`pwd` + +distdir=ghdl-$VERSION +tarfile=$distdir.tar + +GTKWAVE_BASE=$HOME/devel/gtkwave-$GTKWAVE_VERSION + +GCCDIST=$DISTDIR/gcc-$GCCVERSION +GCCDISTOBJ=$GCCDIST-objs +PREFIX=/usr/local +GCCLIBDIR=$PREFIX/lib/gcc/$MACHINE/$GCCVERSION +GCCLIBEXECDIR=$PREFIX/libexec/gcc/$MACHINE/$GCCVERSION +bindirname=ghdl-$VERSION-$MACHINE +TARINSTALL=$DISTDIR/$bindirname.tar.bz2 +VHDLDIR=$distdir/vhdl +DOWNLOAD_HTML=../../website/download.html +DESTDIR=$CWD/ +UNSTRIPDIR=${distdir}-unstripped + +PATH=/usr/gnat/bin:$PATH + +do_clean () +{ + rm -rf $VHDLDIR + mkdir $VHDLDIR + mkdir $VHDLDIR/ghdldrv + mkdir $VHDLDIR/libraries + mkdir $VHDLDIR/libraries/std $VHDLDIR/libraries/ieee + mkdir $VHDLDIR/libraries/vital95 $VHDLDIR/libraries/vital2000 + mkdir $VHDLDIR/libraries/synopsys $VHDLDIR/libraries/mentor + mkdir $VHDLDIR/libraries/ieee2008 + mkdir $VHDLDIR/grt + mkdir $VHDLDIR/grt/config +} + +# Build Makefile +do_Makefile () +{ + sed -e "/^####libraries Makefile.inc/r ../../libraries/Makefile.inc" \ + -e "/^####grt Makefile.inc/r ../grt/Makefile.inc" \ + < Makefile.in > $VHDLDIR/Makefile.in + cp Make-lang.in $VHDLDIR/Make-lang.in +} + +# Copy (or link) sources files into $VHDLDIR +do_files () +{ +. ./dist-common.sh + +# Local files +lfiles="config-lang.in lang-options.h lang-specs.h" +for i in $lfiles; do ln -sf $CWD/$i $VHDLDIR/$i; done + +for i in $cfiles; do ln -sf $CWD/../../$i $VHDLDIR/$i; done + +for i in ghdl.texi ghdl.1; do ln -sf $CWD/../../doc/$i $VHDLDIR/$i; done + +for i in $tfiles; do ln -sf $CWD/../$i $VHDLDIR/$i; done + +for i in $ortho_files; do ln -sf $CWD/../../ortho/$i $VHDLDIR/$i; done + +for i in $ortho_gcc_files; do + ln -sf $CWD/../../ortho/gcc/$i $VHDLDIR/$i +done + +for i in $ghdl_files; do + ln -sf $CWD/../ghdldrv/$i $VHDLDIR/ghdldrv/$i +done + +for i in $libraries_files; do + ln -sf $CWD/../../libraries/$i $VHDLDIR/libraries/$i +done + +for i in $grt_files; do + ln -sf $CWD/../grt/$i $VHDLDIR/grt/$i +done + +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. +do_sources () +{ + \rm -rf $distdir + mkdir $distdir + VHDLDIR=$distdir/vhdl + do_clean $VHDLDIR + do_Makefile + do_files + ln -sf ../../../COPYING $distdir + sed -e "s/@GCCVERSION@/gcc-$GCCVERSION/g" < README > $distdir/README + tar cvhf $tarfile $distdir + bzip2 -f $tarfile + rm -rf $distdir +} + +# Put GHDL sources in GCC. +do_update_gcc_sources () +{ + set -x + + cd $GCCDIST/.. + tar jxvf $CWD/$tarfile.bz2 + rm -rf $GCCDIST/gcc/vhdl + mv $distdir/vhdl $GCCDIST/gcc +} + +# Extract the source, configure and make. +do_compile () +{ + #set -x + + do_update_gcc_sources; + +# gmp build with: +# CFLAGS="-O -m32" ./configure --prefix=$HOME/dist/build \ +# --disable-shared --build=i686-pc-linux-gnu +# make +# make install +# make check + + # usegnat32! + + rm -rf $GCCDISTOBJ + mkdir $GCCDISTOBJ + cd $GCCDISTOBJ + export CFLAGS="-O -g" + + case $MACHINE in + i?86-*-linux*) + # gmp location (mpfr and mpc are supposed to be at the same place) + CONFIG_LIBS="--with-gmp=$PWD/../build" + ;; + x86_64-*-linux*) + CONFIG_LIBS="" + ;; + x86_64-*-darwin*) + CONFIG_LIBS="--with-gmp=$HOME/local --with-stage1-ldflags=" + ;; + *) + exit 1 + ;; + esac + ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX --disable-bootstrap --with-bugurl="<URL:http://gna.org/projects/ghdl>" --build=$MACHINE $CONFIG_LIBS --disable-shared --disable-libmudflap --disable-libssp --disable-libgomp --disable-libquadmath + + make -j4 + make -C gcc vhdl.info + cd $CWD +} + +# Re-package sources, update gcc sources and recompile without reconfiguring. +do_recompile () +{ + do_sources + do_update_gcc_sources; + cd $GCCDISTOBJ + export CFLAGS="-O -g" + make -j4 +} + +check_root () +{ + if [ $UID -ne 0 ]; then + echo "$0: you must be root"; + exit 1; + fi +} + +# Do a make install +do_gcc_install () +{ + set -x + cd $GCCDISTOBJ + # Check the info file is not empty. + if [ -s gcc/doc/ghdl.info ]; then + echo "info file found" + else + echo "Error: ghdl.info not found". + exit 1; + fi + mkdir -p $DESTDIR/usr/local || true + make DESTDIR=$DESTDIR install + cd $CWD + if [ -d $UNSTRIPDIR ]; then + rm -rf $UNSTRIPDIR + fi + mkdir $UNSTRIPDIR + cp ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl $UNSTRIPDIR + chmod -w $UNSTRIPDIR/* + strip ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl +} + +# Create the tar file from the current installation. +do_tar_install () +{ + tar -C $DESTDIR -jcvf $TARINSTALL \ + ./$PREFIX/bin/ghdl ./$PREFIX/info/ghdl.info ./$PREFIX/man/man1/ghdl.1 \ + ./$GCCLIBDIR/vhdl \ + ./$GCCLIBEXECDIR/ghdl1 +} + +do_extract_tar_install () +{ + check_root; + cd / + tar jxvf $TARINSTALL + cd $CWD +} + +# Create the tar file to be distributed. +do_tar_dist () +{ + rm -rf $bindirname + mkdir $bindirname + sed -e "s/@TARFILE@/$bindirname/" < INSTALL > $bindirname/INSTALL + ln ../../COPYING $bindirname + cp $TARINSTALL $bindirname + tar cvf $bindirname.tar $bindirname +} + +# Remove the non-ghdl files of gcc in the current installation. +do_distclean_gcc () +{ + set -x + rm -f ${DESTDIR}${PREFIX}/bin/cpp ${DESTDIR}${PREFIX}/bin/gcc + rm -f ${DESTDIR}${PREFIX}/bin/gcc-* + rm -f ${DESTDIR}${PREFIX}/bin/gccbug ${DESTDIR}${PREFIX}/bin/gcov + rm -f ${DESTDIR}${PREFIX}/bin/${MACHINE}-gcc* + rm -f ${DESTDIR}${PREFIX}/info/cpp.info* + rm -f ${DESTDIR}${PREFIX}/info/cppinternals.info* + rm -f ${DESTDIR}${PREFIX}/info/gcc.info* + rm -f ${DESTDIR}${PREFIX}/info/gccinstall.info* + rm -f ${DESTDIR}${PREFIX}/info/gccint.info* + rm -f ${DESTDIR}${PREFIX}/lib/*.a + rm -f ${DESTDIR}${PREFIX}/lib/*.so* + rm -f ${DESTDIR}${PREFIX}/lib/*.la + rm -rf ${DESTDIR}${PREFIX}/share + rm -rf ${DESTDIR}${PREFIX}/man/man7 + rm -rf ${DESTDIR}${PREFIX}/man/man1/{cpp,gcc,gcov}.1 + rm -rf ${DESTDIR}${PREFIX}/include + rm -f ${DESTDIR}${GCCLIBEXECDIR}/cc1 ${DESTDIR}${GCCLIBEXECDIR}/collect2 + rm -f ${DESTDIR}${GCCLIBEXECDIR}/cpp0 ${DESTDIR}${GCCLIBEXECDIR}/tradcpp0 + rm -rf ${DESTDIR}${GCCLIBEXECDIR}/plugin + rm -rf ${DESTDIR}${GCCLIBEXECDIR}/lto-wrapper + rm -f ${DESTDIR}${GCCLIBDIR}/*.o ${DESTDIR}$GCCLIBDIR/*.a + rm -f ${DESTDIR}${GCCLIBDIR}/specs + rm -rf ${DESTDIR}${GCCLIBDIR}/plugin + rm -rf ${DESTDIR}${GCCLIBDIR}/include + rm -rf ${DESTDIR}${GCCLIBDIR}/include-fixed + rm -rf ${DESTDIR}${GCCLIBDIR}/install-tools + rm -rf ${DESTDIR}${GCCLIBEXECDIR}/install-tools +} + +# Remove ghdl files in the current installation. +do_distclean_ghdl () +{ + check_root; + set -x + rm -f $PREFIX/bin/ghdl + rm -f $PREFIX/info/ghdl.info* + rm -f $GCCLIBEXECDIR/ghdl1 + rm -rf $GCCLIBDIR/vhdl +} + +# Build the source tar, and build the binaries. +do_dist_phase1 () +{ + do_sources; + do_compile; + do_gcc_install; + do_distclean_gcc; + do_tar_install; + do_tar_dist; + rm -rf ./$PREFIX +} + +# Install the binaries and create the binary tar. +do_dist_phase2 () +{ + check_root; + do_distclean_ghdl; + do_extract_tar_install; + echo "dist_phase2 success" +} + +# Create gtkwave patch +do_gtkwave_patch () +{ +# rm -rf gtkwave-patch + mkdir gtkwave-patch + diff -rc -x Makefile.in $GTKWAVE_BASE.orig $GTKWAVE_BASE | \ + sed -e "/^Only in/d" \ + > gtkwave-patch/gtkwave-$GTKWAVE_VERSION.diffs + cp ../grt/ghwlib.c ../grt/ghwlib.h $GTKWAVE_BASE/src/ghw.c gtkwave-patch + sed -e "s/VERSION/$GTKWAVE_VERSION/g" < README.gtkwave > gtkwave-patch/README + tar zcvf ../../website/gtkwave-patch.tgz gtkwave-patch + rm -rf gtkwave-patch +} + +# Update the index.html +# Update the doc +do_website () +{ + cp "$DOWNLOAD_HTML" "$DOWNLOAD_HTML".old + sed -e " +/SRC-HREF/ s/href=\".*\"/href=\"$tarfile.bz2\"/ +/BIN-HREF/ s/href=\".*\"/href=\"$bindirname.tar\"/ +/HISTORY/ a \\ + <tr>\\ + <td>$VERSION</td>\\ + <td>`date +'%b %e %Y'`</td>\\ + <td>$GCCVERSION</td>\\ + <td><a href=\"$tarfile.bz2\">$tarfile.bz2</a></td>\\ + <td><a href=\"$bindirname.tar\">\\ + $bindirname.tar</a></td>\\ + </tr> +" < "$DOWNLOAD_HTML".old > "$DOWNLOAD_HTML" + dir=../../website/ghdl + echo "Updating $dir" + rm -rf $dir + makeinfo --html -o $dir ../../doc/ghdl.texi +} + +# Do ftp commands to upload +do_upload () +{ +if tty -s; then + echo -n "Please, enter password: " + stty -echo + read pass + stty echo + echo +else + echo "$0: upload must be done from a tty" + exit 1; +fi +ftp -n <<EOF +open ftpperso.free.fr +user ghdl $pass +prompt +hash +bin +passive +put $tarfile.bz2 +put $bindirname.tar +put INSTALL +lcd ../../website +put NEWS +put index.html +put download.html +put features.html +put roadmap.html +put manual.html +put more.html +put links.html +put bug.html +put waveviewer.html +put gtkwave-patch.tgz +put favicon.ico +lcd ghdl +cd ghdl +mput \* +bye +EOF +} + +if [ $# -eq 0 ]; then + do_Makefile; +else + for i ; do + case $i in + Makefile|makefile) + do_Makefile ;; + files) + do_files ;; + sources) + do_sources ;; + compile) + do_compile;; + recompile) + do_recompile;; + update_gcc) + do_update_gcc_sources;; + gcc_install) + do_gcc_install;; + tar_install) + do_tar_install;; + tar_dist) + do_tar_dist;; + -v | --version | version) + echo $VERSION + exit 0 + ;; + website) + do_website;; + upload) + do_upload;; + distclean_gcc) + do_distclean_gcc;; + distclean_ghdl) + do_distclean_ghdl;; + dist_phase1) + do_dist_phase1;; + dist_phase2) + do_dist_phase2;; + gtkwave_patch) + do_gtkwave_patch;; + *) + echo "usage: $0 clean|Makefile|files|all" + exit 1 ;; + esac + done +fi diff --git a/src/translate/gcc/lang-options.h b/src/translate/gcc/lang-options.h new file mode 100644 index 0000000..c92b121 --- /dev/null +++ b/src/translate/gcc/lang-options.h @@ -0,0 +1,29 @@ +/* Definitions for switches for vhdl. + Copyright (C) 2002 + Free Software Foundation, Inc. + +This file is part of GNU CC. + +GNU CC 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. + +GNU CC 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 GNU CC; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +DEFINE_LANG_NAME ("vhdl") + +/* This is the contribution to the `lang_options' array in gcc.c for ghdl. */ + + {"--ghdl-", "Specify options to GHDL"}, + + + diff --git a/src/translate/gcc/lang-specs.h b/src/translate/gcc/lang-specs.h new file mode 100644 index 0000000..0504435 --- /dev/null +++ b/src/translate/gcc/lang-specs.h @@ -0,0 +1,28 @@ +/* Definitions for specs for vhdl. + Copyright (C) 2002 + Free Software Foundation, Inc. + +This file is part of GNU CC. + +GNU CC 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. + +GNU CC 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 GNU CC; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* This is the contribution to the `default_compilers' array in gcc.c for + GHDL. */ + + {".vhd", "@vhdl", 0, 0, 0}, + {".vhdl", "@vhdl", 0, 0, 0}, + {"@vhdl", + "ghdl1 %i %(cc1_options) %{!fsyntax-only:%(invoke_as)}", 0, 0, 0}, diff --git a/src/translate/ghdldrv/Makefile b/src/translate/ghdldrv/Makefile new file mode 100644 index 0000000..ebf23c2 --- /dev/null +++ b/src/translate/ghdldrv/Makefile @@ -0,0 +1,193 @@ +# -*- Makefile -*- for the GHDL drivers. +# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +# +# GHDL is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any later +# version. +# +# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING. If not, write to the Free +# Software Foundation, 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. +GNATFLAGS=-gnaty3befhkmr -gnata -gnatwael -aI../.. -aI.. -aI../../psl -aI../grt -aO.. -g -gnatf -gnat05 +GRT_FLAGS=-g +LIB_CFLAGS=-g -O2 +GNATMAKE=gnatmake +CC=gcc + +# Optimize, do not forget to use MODE=--genfast for iirs.adb. +#GNATFLAGS+=-O -gnatn +#GRT_FLAGS+=-O + +# Profiling. +#GNATFLAGS+=-pg -gnatn -O +#GRT_FLAGS+=-pg -O + +# Coverage +#GNATFLAGS+=-fprofile-arcs -ftest-coverage + +GNAT_BARGS=-bargs -E + +LLVM_CONFIG=llvm-config + +#GNAT_LARGS= -static +all: ghdl_mcode + +target=i686-pc-linux-gnu +#target=x86_64-pc-linux-gnu +#target=i686-apple-darwin +#target=x86_64-apple-darwin +#target=i386-pc-mingw32 +GRTSRCDIR=../grt +include $(GRTSRCDIR)/Makefile.inc + +ifeq ($(filter-out i%86 linux,$(arch) $(osys)),) + ORTHO_X86_FLAGS=Flags_Linux +endif +ifeq ($(filter-out i%86 darwin%,$(arch) $(osys)),) + ORTHO_X86_FLAGS=Flags_Macosx +endif +ifeq ($(filter-out i%86 mingw32%,$(arch) $(osys)),) + ORTHO_X86_FLAGS=Flags_Windows +endif +ifdef ORTHO_X86_FLAGS + ORTHO_DEPS=ortho_code-x86-flags.ads +endif + +ortho_code-x86-flags.ads: + echo "with Ortho_Code.X86.$(ORTHO_X86_FLAGS);" > $@ + echo "package Ortho_Code.X86.Flags renames Ortho_Code.X86.$(ORTHO_X86_FLAGS);" >> $@ + +ghdl_mcode: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME +ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) memsegs_c.o chkstk.o force + $(GNATMAKE) -o $@ -aI../../ortho/mcode -aI../../ortho $(GNATFLAGS) ghdl_jit.adb $(GNAT_BARGS) -largs memsegs_c.o chkstk.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) + +memsegs_c.o: ../../ortho/mcode/memsegs_c.c + $(CC) -c -g -o $@ $< + +ghdl_llvm_jit: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME +ghdl_llvm_jit: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) llvm-cbindings.o force + $(GNATMAKE) -o $@ -aI../../ortho/llvm -aI../../ortho $(GNATFLAGS) ghdl_jit.adb $(GNAT_BARGS) -largs llvm-cbindings.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) `$(LLVM_CONFIG) --ldflags --libs --system-libs` -lc++ + +llvm-cbindings.o: ../../ortho/llvm/llvm-cbindings.cpp + $(CXX) -c -m64 `$(LLVM_CONFIG) --includedir --cxxflags` -g -o $@ $< + +ghdl_simul: default_pathes.ads $(GRT_ADD_OBJS) force + $(GNATMAKE) -aI../../simulate $(GNATFLAGS) ghdl_simul $(GNAT_BARGS) -largs $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) + +ghdl_gcc: default_pathes.ads force + $(GNATMAKE) $(GNATFLAGS) ghdl_gcc $(GNAT_BARGS) -largs $(GNAT_LARGS) + +ghdl_llvm: default_pathes.ads force + $(GNATMAKE) $(GNATFLAGS) ghdl_llvm $(GNAT_BARGS) -largs $(GNAT_LARGS) + +default_pathes.ads: default_pathes.ads.in Makefile + curdir=`cd ..; pwd`; \ + sed -e "s%@COMPILER_GCC@%$$curdir/ghdl1-gcc%" \ + -e "s%@COMPILER_DEBUG@%$$curdir/ghdl1-debug%" \ + -e "s%@COMPILER_MCODE@%$$curdir/ghdl1-mcode%" \ + -e "s%@COMPILER_LLVM@%$$curdir/ghdl1-llvm%" \ + -e "s%@POST_PROCESSOR@%$$curdir/../ortho/oread/oread-gcc%" \ + -e "s%@INSTALL_PREFIX@%%" \ + -e "s%@LIB_PREFIX@%$$curdir/lib/%" < $< > $@ + +bootstrap.old: force + $(RM) ../../libraries/std-obj87.cf + $(MAKE) -C ../../libraries EXT=obj \ + ANALYSE="$(PWD)/ghdl -a -g" std-obj87.cf + $(RM) ../../libraries/std-obj93.cf + $(MAKE) -C ../../libraries EXT=obj \ + ANALYSE="$(PWD)/ghdl -a -g" std-obj93.cf + +LIB87_DIR:=../lib/v87 +LIB93_DIR:=../lib/v93 +LIB08_DIR:=../lib/v08 + +LIBSRC_DIR:=../../libraries +REL_DIR:=../.. +GHDL=ghdl +ANALYZE:=../../../ghdldrv/$(GHDL) -a $(LIB_CFLAGS) +LN=ln -s +CP=cp + +$(LIB87_DIR) $(LIB93_DIR) $(LIB08_DIR): + [ -d ../lib ] || mkdir ../lib + [ -d $@ ] || mkdir $@ + +include ../../libraries/Makefile.inc + +GHDL1=../ghdl1-gcc +$(LIB93_DIR)/std/std_standard.o: $(GHDL1) +ifeq ($(GHDL),ghdl_llvm) + $(GHDL1) --std=93 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard +else + $(GHDL1) --std=93 -quiet $(LIB_CFLAGS) -o std_standard.s \ + --compile-standard + $(CC) -c -o $@ std_standard.s + $(RM) std_standard.s +endif + +$(LIB87_DIR)/std/std_standard.o: $(GHDL1) +ifeq ($(GHDL),ghdl_llvm) + $(GHDL1) --std=87 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard +else + $(GHDL1) --std=87 -quiet $(LIB_CFLAGS) -o std_standard.s \ + --compile-standard + $(CC) -c -o $@ std_standard.s + $(RM) std_standard.s +endif + +$(LIB08_DIR)/std/std_standard.o: $(GHDL1) +ifeq ($(GHDL),ghdl_llvm) + $(GHDL1) --std=08 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard +else + $(GHDL1) --std=08 -quiet $(LIB_CFLAGS) -o std_standard.s \ + --compile-standard + $(CC) -c -o $@ std_standard.s + $(RM) std_standard.s +endif + +install.v93: std.v93 ieee.v93 synopsys.v93 mentor.v93 +install.v87: std.v87 ieee.v87 synopsys.v87 +install.v08: std.v08 ieee.v08 + +install.standard: $(LIB93_DIR)/std/std_standard.o \ + $(LIB87_DIR)/std/std_standard.o \ + $(LIB08_DIR)/std/std_standard.o + +grt.links: + cd ../lib; ln -sf $(GRTSRCDIR)/grt.lst .; ln -sf $(GRTSRCDIR)/libgrt.a .; ln -sf $(GRTSRCDIR)/grt.ver . + +install.all: install.v87 install.v93 install.v08 + +install.gcc: + $(MAKE) GHDL=ghdl_gcc install.all + $(MAKE) GHDL1=../ghdl1-gcc install.standard + +install.mcode: + $(MAKE) GHDL=ghdl_mcode install.all + +install.simul: + $(MAKE) GHDL=ghdl_simul install.all + +install.llvm: + $(MAKE) GHDL=ghdl_llvm install.all + $(MAKE) GHDL1=../ghdl1-llvm install.standard + +clean: force + $(RM) -f *.o *.ali ghdl_gcc ghdl_mcode ghdl_llvm ghdl_llvm_jit + $(RM) -f b~*.ad? *~ default_pathes.ads ghdl_simul + $(RM) -rf ../lib + +clean-c: force + $(RM) -f memsegs_c.o chkstk.o linux.o times.o grt-cbinding.o grt-cvpi.o + +force: + +.PHONY: force clean diff --git a/src/translate/ghdldrv/default_pathes.ads.in b/src/translate/ghdldrv/default_pathes.ads.in new file mode 100644 index 0000000..7f471a5 --- /dev/null +++ b/src/translate/ghdldrv/default_pathes.ads.in @@ -0,0 +1,39 @@ +-- GHDL driver pathes -*- ada -*-. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package Default_Pathes is + + -- Accept long lines. + pragma Style_Checks ("M999"); + + Install_Prefix : constant String := + "@INSTALL_PREFIX@"; + Lib_Prefix : constant String := + "@LIB_PREFIX@"; + + Compiler_Gcc : constant String := + "@COMPILER_GCC@"; + Compiler_Mcode : constant String := + "@COMPILER_MCODE@"; + Compiler_Llvm : constant String := + "@COMPILER_LLVM@"; + Compiler_Debug : constant String := + "@COMPILER_DEBUG@"; + Post_Processor : constant String := + "@POST_PROCESSOR@"; +end Default_Pathes; diff --git a/src/translate/ghdldrv/foreigns.adb b/src/translate/ghdldrv/foreigns.adb new file mode 100644 index 0000000..15e3dd0 --- /dev/null +++ b/src/translate/ghdldrv/foreigns.adb @@ -0,0 +1,64 @@ +with Interfaces.C; use Interfaces.C; + +package body Foreigns is + function Sin (Arg : double) return double; + pragma Import (C, Sin); + + function Log (Arg : double) return double; + pragma Import (C, Log); + + function Exp (Arg : double) return double; + pragma Import (C, Exp); + + function Sqrt (Arg : double) return double; + pragma Import (C, Sqrt); + + function Asin (Arg : double) return double; + pragma Import (C, Asin); + + function Acos (Arg : double) return double; + pragma Import (C, Acos); + + function Asinh (Arg : double) return double; + pragma Import (C, Asinh); + + function Acosh (Arg : double) return double; + pragma Import (C, Acosh); + + function Atanh (X : double) return double; + pragma Import (C, Atanh); + + function Atan2 (X, Y : double) return double; + pragma Import (C, Atan2); + + type String_Cacc is access constant String; + type Foreign_Record is record + Name : String_Cacc; + Addr : Address; + end record; + + + Foreign_Arr : constant array (Natural range <>) of Foreign_Record := + ( + (new String'("sin"), Sin'Address), + (new String'("log"), Log'Address), + (new String'("exp"), Exp'Address), + (new String'("sqrt"), Sqrt'Address), + (new String'("asin"), Asin'Address), + (new String'("acos"), Acos'Address), + (new String'("asinh"), Asinh'Address), + (new String'("acosh"), Acosh'Address), + (new String'("atanh"), Atanh'Address), + (new String'("atan2"), Atan2'Address) + ); + + function Find_Foreign (Name : String) return Address is + begin + for I in Foreign_Arr'Range loop + if Foreign_Arr(I).Name.all = Name then + return Foreign_Arr(I).Addr; + end if; + end loop; + return Null_Address; + end Find_Foreign; +end Foreigns; diff --git a/src/translate/ghdldrv/foreigns.ads b/src/translate/ghdldrv/foreigns.ads new file mode 100644 index 0000000..5759ae4 --- /dev/null +++ b/src/translate/ghdldrv/foreigns.ads @@ -0,0 +1,5 @@ +with System; use System; + +package Foreigns is + function Find_Foreign (Name : String) return Address; +end Foreigns; diff --git a/src/translate/ghdldrv/ghdl_gcc.adb b/src/translate/ghdldrv/ghdl_gcc.adb new file mode 100644 index 0000000..615a8c5 --- /dev/null +++ b/src/translate/ghdldrv/ghdl_gcc.adb @@ -0,0 +1,34 @@ +-- GHDL driver for gcc. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ghdlmain; +with Ghdllocal; +with Ghdldrv; +with Ghdlprint; + +procedure Ghdl_Gcc is +begin + -- Manual elaboration so that the order is known (because it is the order + -- used to display help). + Ghdlmain.Version_String := new String'("GCC back-end code generator"); + Ghdldrv.Compile_Kind := Ghdldrv.Compile_Gcc; + Ghdldrv.Register_Commands; + Ghdllocal.Register_Commands; + Ghdlprint.Register_Commands; + Ghdlmain.Register_Commands; + Ghdlmain.Main; +end Ghdl_Gcc; diff --git a/src/translate/ghdldrv/ghdl_jit.adb b/src/translate/ghdldrv/ghdl_jit.adb new file mode 100644 index 0000000..ba70874 --- /dev/null +++ b/src/translate/ghdldrv/ghdl_jit.adb @@ -0,0 +1,35 @@ +-- GHDL driver for jit. +-- Copyright (C) 2002-2014 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 Ghdlmain; +with Ghdllocal; +with Ghdlprint; +with Ghdlrun; +with Ortho_Jit; + +procedure Ghdl_Jit is +begin + -- Manual elaboration so that the order is known (because it is the order + -- used to display help). + Ghdlmain.Version_String := + new String'(Ortho_Jit.Get_Jit_Name & " code generator"); + Ghdlrun.Register_Commands; + Ghdllocal.Register_Commands; + Ghdlprint.Register_Commands; + Ghdlmain.Register_Commands; + Ghdlmain.Main; +end Ghdl_Jit; diff --git a/src/translate/ghdldrv/ghdl_simul.adb b/src/translate/ghdldrv/ghdl_simul.adb new file mode 100644 index 0000000..d4d0abd --- /dev/null +++ b/src/translate/ghdldrv/ghdl_simul.adb @@ -0,0 +1,33 @@ +-- GHDL driver for simulator. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ghdlmain; +with Ghdllocal; +with Ghdlprint; +with Ghdlsimul; + +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; + Ghdlmain.Register_Commands; + Ghdlmain.Main; +end Ghdl_Simul; diff --git a/src/translate/ghdldrv/ghdlcomp.adb b/src/translate/ghdldrv/ghdlcomp.adb new file mode 100644 index 0000000..ba755af --- /dev/null +++ b/src/translate/ghdldrv/ghdlcomp.adb @@ -0,0 +1,757 @@ +-- GHDL driver - compile commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ghdlmain; use Ghdlmain; +with Ghdllocal; use Ghdllocal; + +with Ada.Command_Line; +with Ada.Characters.Latin_1; +with Ada.Text_IO; + +with Types; +with Iirs; use Iirs; +with Nodes_GC; +with Flags; +with Back_End; +with Sem; +with Name_Table; +with Errorout; use Errorout; +with Libraries; +with Std_Package; +with Files_Map; +with Version; +with Default_Pathes; + +package body Ghdlcomp is + + Flag_Expect_Failure : Boolean := False; + + Flag_Debug_Nodes_Leak : Boolean := False; + -- If True, detect unreferenced nodes at the end of analysis. + + -- Commands which use the mcode compiler. + type Command_Comp is abstract new Command_Lib with null record; + procedure Decode_Option (Cmd : in out Command_Comp; + Option : String; + Arg : String; + Res : out Option_Res); + procedure Disp_Long_Help (Cmd : Command_Comp); + + procedure Decode_Option (Cmd : in out Command_Comp; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "--expect-failure" then + Flag_Expect_Failure := True; + Res := Option_Ok; + elsif Option = "--debug-nodes-leak" then + Flag_Debug_Nodes_Leak := True; + Res := Option_Ok; + elsif Hooks.Decode_Option.all (Option) then + Res := Option_Ok; + else + Decode_Option (Command_Lib (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + + procedure Disp_Long_Help (Cmd : Command_Comp) + is + use Ada.Text_IO; + begin + Disp_Long_Help (Command_Lib (Cmd)); + Hooks.Disp_Long_Help.all; + Put_Line (" --expect-failure Expect analysis/elaboration failure"); + end Disp_Long_Help; + + -- Command -r + type Command_Run is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Run; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Run) return String; + + procedure Perform_Action (Cmd : in out Command_Run; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Run; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-r" or Name = "--elab-run"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Run) return String + is + pragma Unreferenced (Cmd); + begin + return "-r,--elab-run [OPTS] UNIT [ARCH] [RUNOPTS] Run UNIT"; + end Get_Short_Help; + + + procedure Perform_Action (Cmd : in out Command_Run; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Opt_Arg : Natural; + begin + begin + Hooks.Compile_Init.all (False); + + Libraries.Load_Work_Library (False); + Flags.Flag_Elaborate_With_Outdated := False; + Flags.Flag_Only_Elab_Warnings := True; + + Hooks.Compile_Elab.all ("-r", Args, Opt_Arg); + exception + when Compilation_Error => + if Flag_Expect_Failure then + return; + else + raise; + end if; + end; + Hooks.Set_Run_Options (Args (Opt_Arg .. Args'Last)); + Hooks.Run.all; + end Perform_Action; + + + -- Command -c xx -r + type Command_Compile is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Compile; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Compile) return String; + procedure Decode_Option (Cmd : in out Command_Compile; + Option : String; + Arg : String; + Res : out Option_Res); + procedure Perform_Action (Cmd : in out Command_Compile; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Compile; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-c"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Compile) return String + is + pragma Unreferenced (Cmd); + begin + return "-c [OPTS] FILEs -r UNIT [ARCH] [RUNOPTS] " + & "Compile, elaborate and run UNIT"; + end Get_Short_Help; + + procedure Decode_Option (Cmd : in out Command_Compile; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "-r" or else Option = "-e" then + Res := Option_End; + else + Decode_Option (Command_Comp (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Perform_Action (Cmd : in out Command_Compile; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Elab_Arg : Natural; + Run_Arg : Natural; + begin + begin + Hooks.Compile_Init.all (False); + + Flags.Flag_Elaborate_With_Outdated := True; + Flags.Flag_Only_Elab_Warnings := False; + + if Args'Length > 1 and then + (Args (Args'First).all = "-r" or else Args (Args'First).all = "-e") + then + -- If there is no files, then load the work library. + Libraries.Load_Work_Library (False); + -- Also, load all libraries and files, so that every design unit + -- is known. + Load_All_Libraries_And_Files; + Elab_Arg := Args'First + 1; + else + -- If there is at least one file, do not load the work library. + Libraries.Load_Work_Library (True); + Elab_Arg := Natural'Last; + for I in Args'Range loop + declare + Arg : constant String := Args (I).all; + Res : Iir_Design_File; + Design : Iir; + Next_Design : Iir; + begin + if Arg = "-r" or else Arg = "-e" then + Elab_Arg := I + 1; + exit; + else + Res := Libraries.Load_File + (Name_Table.Get_Identifier (Arg)); + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Put units into library. + Design := Get_First_Design_Unit (Res); + while not Is_Null (Design) loop + Next_Design := Get_Chain (Design); + Set_Chain (Design, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Design); + Design := Next_Design; + end loop; + end if; + end; + end loop; + if Elab_Arg = Natural'Last then + Libraries.Save_Work_Library; + return; + end if; + end if; + + Hooks.Compile_Elab.all ("-c", Args (Elab_Arg .. Args'Last), Run_Arg); + exception + when Compilation_Error => + if Flag_Expect_Failure then + return; + else + raise; + end if; + end; + if Args (Elab_Arg - 1).all = "-r" then + Hooks.Set_Run_Options (Args (Run_Arg .. Args'Last)); + Hooks.Run.all; + else + if Run_Arg <= Args'Last then + Error_Msg_Option ("options after unit are ignored"); + end if; + end if; + end Perform_Action; + + -- Command -a + type Command_Analyze is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Analyze; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Analyze) return String; + + procedure Perform_Action (Cmd : in out Command_Analyze; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Analyze; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-a"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Analyze) return String + is + pragma Unreferenced (Cmd); + begin + return "-a [OPTS] FILEs Analyze FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Analyze; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Types; + Id : Name_Id; + Design_File : Iir_Design_File; + New_Design_File : Iir_Design_File; + Unit : Iir; + Next_Unit : Iir; + begin + Setup_Libraries (True); + + Hooks.Compile_Init.all (True); + + -- Parse all files. + for I in Args'Range loop + Id := Name_Table.Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if False then + -- Speed up analysis: remove all previous designs. + -- However, this is not in the LRM... + Libraries.Purge_Design_File (Design_File); + end if; + + if Design_File /= Null_Iir then + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + Back_End.Finish_Compilation (Unit, True); + + Next_Unit := Get_Chain (Unit); + + if Errorout.Nbr_Errors = 0 then + Set_Chain (Unit, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Unit); + New_Design_File := Get_Design_File (Unit); + end if; + + Unit := Next_Unit; + end loop; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + Free_Iir (Design_File); + + -- Do late analysis checks. + Unit := Get_First_Design_Unit (New_Design_File); + while Unit /= Null_Iir loop + Sem.Sem_Analysis_Checks_List (Unit, Flags.Warn_Delayed_Checks); + Unit := Get_Chain (Unit); + end loop; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + end if; + end loop; + + if Flag_Expect_Failure then + raise Compilation_Error; + end if; + + if Flag_Debug_Nodes_Leak then + Nodes_GC.Report_Unreferenced; + end if; + + Libraries.Save_Work_Library; + + exception + when Compilation_Error => + if Flag_Expect_Failure and Errorout.Nbr_Errors /= 0 then + return; + else + raise; + end if; + end Perform_Action; + + -- Command -e + type Command_Elab is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Elab; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Elab) return String; + procedure Decode_Option (Cmd : in out Command_Elab; + Option : String; + Arg : String; + Res : out Option_Res); + + procedure Perform_Action (Cmd : in out Command_Elab; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Elab; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-e"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Elab) return String + is + pragma Unreferenced (Cmd); + begin + return "-e [OPTS] UNIT [ARCH] Elaborate UNIT"; + end Get_Short_Help; + + procedure Decode_Option (Cmd : in out Command_Elab; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "--expect-failure" then + Flag_Expect_Failure := True; + Res := Option_Ok; + elsif Option = "-o" then + if Arg'Length = 0 then + Res := Option_Arg_Req; + else + -- Silently accepted. + Res := Option_Arg; + end if; + --elsif Option'Length >= 4 and then Option (1 .. 4) = "-Wl," then + -- Res := Option_Ok; + else + Decode_Option (Command_Lib (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Perform_Action (Cmd : in out Command_Elab; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Run_Arg : Natural; + begin + Hooks.Compile_Init.all (False); + + Libraries.Load_Work_Library (False); + Flags.Flag_Elaborate_With_Outdated := False; + Flags.Flag_Only_Elab_Warnings := True; + + Hooks.Compile_Elab.all ("-e", Args, Run_Arg); + if Run_Arg <= Args'Last then + Error_Msg_Option ("options after unit are ignored"); + end if; + if Flag_Expect_Failure then + raise Compilation_Error; + end if; + exception + when Compilation_Error => + if Flag_Expect_Failure and then Errorout.Nbr_Errors > 0 then + return; + else + raise; + end if; + end Perform_Action; + + -- Command dispconfig. + type Command_Dispconfig is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Dispconfig; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Dispconfig) return String; + procedure Perform_Action (Cmd : in out Command_Dispconfig; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Dispconfig; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--dispconfig"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Dispconfig) return String + is + pragma Unreferenced (Cmd); + begin + return "--dispconfig Disp tools path"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Dispconfig; + Args : Argument_List) + is + use Ada.Text_IO; + use Libraries; + pragma Unreferenced (Cmd); + begin + if Args'Length /= 0 then + Error ("--dispconfig does not accept any argument"); + raise Errorout.Option_Error; + end if; + + Put ("command line prefix (--PREFIX): "); + if Prefix_Path = null then + Put_Line ("(not set)"); + else + Put_Line (Prefix_Path.all); + end if; + Setup_Libraries (False); + + Put ("environment prefix (GHDL_PREFIX): "); + if Prefix_Env = null then + Put_Line ("(not set)"); + else + Put_Line (Prefix_Env.all); + end if; + + Put_Line ("default prefix: " & Default_Pathes.Prefix); + Put_Line ("actual prefix: " & Prefix_Path.all); + Put_Line ("command_name: " & Ada.Command_Line.Command_Name); + Put_Line ("default library pathes:"); + for I in 2 .. Get_Nbr_Pathes loop + Put (' '); + Put_Line (Name_Table.Image (Get_Path (I))); + end loop; + end Perform_Action; + + -- Command Make. + 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; + procedure Perform_Action (Cmd : in out Command_Make; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Make; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-m"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Make) return String + is + pragma Unreferenced (Cmd); + begin + return "-m [OPTS] UNIT [ARCH] Make UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Types; + + Files_List : Iir_List; + File : Iir_Design_File; + + Next_Arg : Natural; + Date : Date_Type; + Unit : Iir_Design_Unit; + begin + Extract_Elab_Unit ("-m", Args, Next_Arg); + Setup_Libraries (True); + + -- Create list of files. + Files_List := Build_Dependence (Prim_Name, Sec_Name); + + Date := Get_Date (Libraries.Work_Library); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + + if Get_Library (File) = Libraries.Work_Library then + -- Mark this file as analyzed. + Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp); + + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + if Get_Date (Unit) = Date_Analyzed + or else Get_Date (Unit) in Date_Valid + then + Date := Date + 1; + Set_Date (Unit, Date); + end if; + Unit := Get_Chain (Unit); + end loop; + end if; + 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. + type Command_Gen_Makefile is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Gen_Makefile) return String; + procedure Perform_Action (Cmd : in out Command_Gen_Makefile; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--gen-makefile"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Gen_Makefile) return String + is + pragma Unreferenced (Cmd); + begin + return "--gen-makefile [OPTS] UNIT [ARCH] Generate a Makefile for UNIT"; + end Get_Short_Help; + + function Is_Makeable_File (File : Iir_Design_File) return Boolean is + begin + if File = Std_Package.Std_Standard_File then + return False; + end if; + return True; + end Is_Makeable_File; + + procedure Perform_Action (Cmd : in out Command_Gen_Makefile; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Types; + use Ada.Text_IO; + use Ada.Command_Line; + use Name_Table; + + HT : constant Character := Ada.Characters.Latin_1.HT; + Files_List : Iir_List; + File : Iir_Design_File; + + Lib : Iir_Library_Declaration; + Dir_Id : Name_Id; + + Next_Arg : Natural; + begin + Extract_Elab_Unit ("--gen-makefile", Args, Next_Arg); + Setup_Libraries (True); + Files_List := Build_Dependence (Prim_Name, Sec_Name); + + Put_Line ("# Makefile automatically generated by ghdl"); + Put ("# Version: "); + Put (Version.Ghdl_Release); + Put (" - "); + if Version_String /= null then + Put (Version_String.all); + end if; + New_Line; + Put_Line ("# Command used to generate this makefile:"); + Put ("# "); + Put (Command_Name); + for I in 1 .. Argument_Count loop + Put (' '); + Put (Argument (I)); + end loop; + New_Line; + + New_Line; + + Put ("GHDL="); + Put_Line (Command_Name); + + -- Extract options for command line. + Put ("GHDLFLAGS="); + for I in 2 .. Argument_Count loop + declare + Arg : constant String := Argument (I); + begin + if Arg (1) = '-' then + if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=") + or else (Arg'Length > 7 and then Arg (1 .. 7) = "--ieee=") + or else (Arg'Length > 6 and then Arg (1 .. 6) = "--std=") + or else (Arg'Length > 7 and then Arg (1 .. 7) = "--work=") + or else (Arg'Length > 2 and then Arg (1 .. 2) = "-P") + then + Put (" "); + Put (Arg); + end if; + end if; + end; + end loop; + New_Line; + + Put ("GHDLRUNFLAGS="); + for I in Next_Arg .. Args'Last loop + Put (' '); + Put (Args (I).all); + end loop; + New_Line; + New_Line; + + Put_Line ("# Default target : elaborate"); + Put_Line ("all : elab"); + New_Line; + + Put_Line ("# Elaborate target. Almost useless"); + Put_Line ("elab : force"); + Put (HT & "$(GHDL) -c $(GHDLFLAGS) -e "); + Put (Prim_Name.all); + if Sec_Name /= null then + Put (' '); + Put (Sec_Name.all); + end if; + New_Line; + New_Line; + + Put_Line ("# Run target"); + Put_Line ("run : force"); + Put (HT & "$(GHDL) -c $(GHDLFLAGS) -r "); + Put (Prim_Name.all); + if Sec_Name /= null then + Put (' '); + Put (Sec_Name.all); + end if; + Put (" $(GHDLRUNFLAGS)"); + New_Line; + New_Line; + + Put_Line ("# Targets to analyze libraries"); + Put_Line ("init: force"); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + Dir_Id := Get_Design_File_Directory (File); + if not Is_Makeable_File (File) then + -- Builtin file. + null; + elsif Dir_Id /= Files_Map.Get_Home_Directory then + -- Not locally built file. + Put (HT & "# "); + Put (Image (Dir_Id)); + Put (Image (Get_Design_File_Filename (File))); + New_Line; + else + + Put (HT & "$(GHDL) -a $(GHDLFLAGS)"); + Lib := Get_Library (File); + if Lib /= Libraries.Work_Library then + -- Overwrite some options. + Put (" --work="); + Put (Image (Get_Identifier (Lib))); + Dir_Id := Get_Library_Directory (Lib); + Put (" --workdir="); + if Dir_Id = Libraries.Local_Directory then + Put ("."); + else + Put (Image (Dir_Id)); + end if; + end if; + Put (' '); + Put (Image (Get_Design_File_Filename (File))); + New_Line; + end if; + end loop; + New_Line; + + Put_Line ("force:"); + end Perform_Action; + + procedure Register_Commands is + begin + Register_Command (new Command_Analyze); + Register_Command (new Command_Elab); + Register_Command (new Command_Run); + Register_Command (new Command_Compile); + Register_Command (new Command_Make); + Register_Command (new Command_Gen_Makefile); + Register_Command (new Command_Dispconfig); + end Register_Commands; + +end Ghdlcomp; diff --git a/src/translate/ghdldrv/ghdlcomp.ads b/src/translate/ghdldrv/ghdlcomp.ads new file mode 100644 index 0000000..f803ca4 --- /dev/null +++ b/src/translate/ghdldrv/ghdlcomp.ads @@ -0,0 +1,67 @@ +-- GHDL driver - compile commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package Ghdlcomp is + -- This procedure is called at start of commands which call + -- finish_compilation to generate code. + type Compile_Init_Acc is access procedure (Analyze_Only : Boolean); + + -- This procedure is called for elaboration. + -- CMD_NAME is the name of the command, used to report errors. + -- ARGS is the argument list, starting from the unit name to be elaborated. + -- The procedure should extract the unit. + -- OPT_ARG is the index of the first argument from ARGS to be used as + -- a run option. + type Compile_Elab_Acc is access procedure + (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural); + + -- Use ARGS as run options. + -- Should do all the work. + type Set_Run_Options_Acc is access + procedure (Args : Argument_List); + + -- Run the simulation. + -- All the parameters were set through calling Compile_Elab and + -- Set_Run_Options. + type Run_Acc is access procedure; + + -- Called when an analysis/elaboration option is decoded. + -- Return True if OPTION is known (and do the side effects). + -- No parameters are allowed. + type Decode_Option_Acc is access function (Option : String) return Boolean; + + -- Disp help for options decoded by Decode_Option. + type Disp_Long_Help_Acc is access procedure; + + -- All the hooks gathered. + -- A record is used to be sure all hooks are set. + type Hooks_Type is record + Compile_Init : Compile_Init_Acc := null; + Compile_Elab : Compile_Elab_Acc := null; + Set_Run_Options : Set_Run_Options_Acc := null; + Run : Run_Acc := null; + Decode_Option : Decode_Option_Acc := null; + Disp_Long_Help : Disp_Long_Help_Acc := null; + end record; + + Hooks : Hooks_Type; + + -- Register commands. + procedure Register_Commands; +end Ghdlcomp; diff --git a/src/translate/ghdldrv/ghdldrv.adb b/src/translate/ghdldrv/ghdldrv.adb new file mode 100644 index 0000000..be905f1 --- /dev/null +++ b/src/translate/ghdldrv/ghdldrv.adb @@ -0,0 +1,1818 @@ +-- GHDL driver - commands invoking gcc. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Characters.Latin_1; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Table; +with GNAT.Dynamic_Tables; +with Libraries; +with Name_Table; use Name_Table; +with Std_Package; +with Types; use Types; +with Iirs; use Iirs; +with Files_Map; +with Flags; +with Configuration; +--with Disp_Tree; +with Default_Pathes; +with Interfaces.C_Streams; +with System; +with Ghdlmain; use Ghdlmain; +with Ghdllocal; use Ghdllocal; +with Errorout; +with Version; +with Options; + +package body Ghdldrv is + -- Name of the tools used. + Compiler_Cmd : String_Access := null; + Post_Processor_Cmd : String_Access := null; + Assembler_Cmd : constant String := "as"; + Linker_Cmd : constant String := "gcc"; + + -- Path of the tools. + Compiler_Path : String_Access; + Post_Processor_Path : String_Access; + Assembler_Path : String_Access; + Linker_Path : String_Access; + + -- Set by the '-o' option: the output filename. If the option is not + -- present, then null. + Output_File : String_Access; + + -- "-o" string. + Dash_o : constant String_Access := new String'("-o"); + + -- "-c" string. + Dash_c : constant String_Access := new String'("-c"); + + -- "-quiet" option. + Dash_Quiet : constant String_Access := new String'("-quiet"); + + -- If set, do not assmble + Flag_Asm : Boolean; + + -- If true, executed commands are displayed. + Flag_Disp_Commands : Boolean; + + -- Flag not quiet + Flag_Not_Quiet : Boolean; + + -- True if failure expected. + Flag_Expect_Failure : Boolean; + + -- Argument table for the tools. + -- Each table low bound is 1 so that the length of a table is equal to + -- the last bound. + package Argument_Table_Pkg is new GNAT.Dynamic_Tables + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 4, + Table_Increment => 100); + use Argument_Table_Pkg; + + -- Arguments for tools. + Compiler_Args : Argument_Table_Pkg.Instance; + Postproc_Args : Argument_Table_Pkg.Instance; + Assembler_Args : Argument_Table_Pkg.Instance; + Linker_Args : Argument_Table_Pkg.Instance; + + -- Display the program spawned in Flag_Disp_Commands is TRUE. + -- Raise COMPILE_ERROR in case of failure. + procedure My_Spawn (Program_Name : String; Args : Argument_List) + is + Status : Integer; + begin + if Flag_Disp_Commands then + Put (Program_Name); + for I in Args'Range loop + Put (' '); + Put (Args (I).all); + end loop; + New_Line; + end if; + Status := Spawn (Program_Name, Args); + if Status = 0 then + return; + elsif Status = 1 then + Error ("compilation error"); + raise Compile_Error; + elsif Status > 127 then + Error ("executable killed by a signal"); + raise Exec_Error; + else + Error ("exec error"); + raise Exec_Error; + end if; + end My_Spawn; + + -- Compile FILE with additional argument OPTS. + procedure Do_Compile (Options : Argument_List; File : String) + is + Obj_File : String_Access; + Asm_File : String_Access; + Post_File : String_Access; + Success : Boolean; + begin + -- Create post file. + case Compile_Kind is + when Compile_Debug => + Post_File := Append_Suffix (File, Post_Suffix); + when others => + null; + end case; + + -- Create asm file. + case Compile_Kind is + when Compile_Gcc + | Compile_Debug => + Asm_File := Append_Suffix (File, Asm_Suffix); + when Compile_Llvm + | Compile_Mcode => + null; + end case; + + -- Create obj file (may not be used, but the condition isn't simple). + Obj_File := Append_Suffix (File, Get_Object_Suffix.all); + + -- Compile. + declare + P : Natural; + Nbr_Args : constant Natural := + Last (Compiler_Args) + Options'Length + 4; + Args : Argument_List (1 .. Nbr_Args); + begin + P := 0; + for I in First .. Last (Compiler_Args) loop + P := P + 1; + Args (P) := Compiler_Args.Table (I); + end loop; + for I in Options'Range loop + P := P + 1; + Args (P) := Options (I); + end loop; + + -- Add -quiet. + case Compile_Kind is + when Compile_Gcc => + if not Flag_Not_Quiet then + P := P + 1; + Args (P) := Dash_Quiet; + end if; + when Compile_Llvm => + P := P + 1; + Args (P) := Dash_c; + when Compile_Debug + | Compile_Mcode => + null; + end case; + + Args (P + 1) := Dash_o; + case Compile_Kind is + when Compile_Debug => + Args (P + 2) := Post_File; + when Compile_Gcc => + Args (P + 2) := Asm_File; + when Compile_Mcode + | Compile_Llvm => + Args (P + 2) := Obj_File; + end case; + Args (P + 3) := new String'(File); + + My_Spawn (Compiler_Path.all, Args (1 .. P + 3)); + Free (Args (P + 3)); + exception + when Compile_Error => + -- Delete temporary file in case of error. + Delete_File (Args (P + 2).all, Success); + -- FIXME: delete object file too ? + raise; + end; + + -- Post-process. + if Compile_Kind = Compile_Debug then + declare + P : Natural; + Nbr_Args : constant Natural := Last (Postproc_Args) + 4; + Args : Argument_List (1 .. Nbr_Args); + begin + P := 0; + for I in First .. Last (Postproc_Args) loop + P := P + 1; + Args (P) := Postproc_Args.Table (I); + end loop; + + if not Flag_Not_Quiet then + P := P + 1; + Args (P) := Dash_Quiet; + end if; + + Args (P + 1) := Dash_o; + Args (P + 2) := Asm_File; + Args (P + 3) := Post_File; + My_Spawn (Post_Processor_Path.all, Args (1 .. P + 3)); + end; + + Free (Post_File); + end if; + + -- Assemble. + if Compile_Kind >= Compile_Gcc then + if Flag_Expect_Failure then + Delete_File (Asm_File.all, Success); + elsif not Flag_Asm then + declare + P : Natural; + Nbr_Args : constant Natural := Last (Assembler_Args) + 4; + Args : Argument_List (1 .. Nbr_Args); + Success : Boolean; + begin + P := 0; + for I in First .. Last (Assembler_Args) loop + P := P + 1; + Args (P) := Assembler_Args.Table (I); + end loop; + + Args (P + 1) := Dash_o; + Args (P + 2) := Obj_File; + Args (P + 3) := Asm_File; + My_Spawn (Assembler_Path.all, Args (1 .. P + 3)); + Delete_File (Asm_File.all, Success); + end; + end if; + end if; + + Free (Asm_File); + Free (Obj_File); + end Do_Compile; + + package Filelist is new GNAT.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 16, + Table_Increment => 100); + + Link_Obj_Suffix : String_Access; + + -- Read a list of files from file FILENAME. + -- Lines starting with a '#' are ignored (comments) + -- Lines starting with a '>' are directory lines + -- If first character of a line is a '@', it is replaced with + -- the lib_prefix_path. + -- If TO_OBJ is true, then each file is converted to an object file name + -- (suffix is replaced by the object file extension). + procedure Add_File_List (Filename : String; To_Obj : Boolean) + is + use Interfaces.C_Streams; + use System; + use Ada.Characters.Latin_1; + + -- Replace the first '@' with the machine path. + function Substitute (Str : String) return String + is + begin + for I in Str'Range loop + if Str (I) = '@' then + return Str (Str'First .. I - 1) + & Get_Machine_Path_Prefix + & Str (I + 1 .. Str'Last); + end if; + end loop; + return Str; + end Substitute; + + Dir : String (1 .. max_path_len); + Dir_Len : Natural; + Line : String (1 .. max_path_len); + Stream : Interfaces.C_Streams.FILEs; + Mode : constant String := "rt" & Ghdllocal.Nul; + L : Natural; + File : String_Access; + begin + Line (1 .. Filename'Length) := Filename; + Line (Filename'Length + 1) := Ghdllocal.Nul; + Stream := fopen (Line'Address, Mode'Address); + if Stream = NULL_Stream then + Error ("cannot open " & Filename); + raise Compile_Error; + end if; + Dir_Len := 0; + loop + exit when fgets (Line'Address, Line'Length, Stream) = NULL_Stream; + if Line (1) /= '#' then + -- Compute string length. + L := 0; + while Line (L + 1) /= Ghdllocal.Nul loop + L := L + 1; + end loop; + + -- Remove trailing NL. + while L > 0 and then (Line (L) = LF or Line (L) = CR) loop + L := L - 1; + end loop; + + if Line (1) = '>' then + Dir_Len := L - 1; + Dir (1 .. Dir_Len) := Line (2 .. L); + else + if To_Obj then + File := new String'(Dir (1 .. Dir_Len) + & Get_Base_Name (Line (1 .. L)) + & Link_Obj_Suffix.all); + else + File := new String'(Substitute (Line (1 .. L))); + end if; + + Filelist.Increment_Last; + Filelist.Table (Filelist.Last) := File; + + Dir_Len := 0; + end if; + end if; + end loop; + if fclose (Stream) /= 0 then + Error ("cannot close " & Filename); + end if; + end Add_File_List; + + function Get_Object_Filename (File : Iir_Design_File) return String + is + Dir : Name_Id; + Name : Name_Id; + begin + Dir := Get_Library_Directory (Get_Library (File)); + Name := Get_Design_File_Filename (File); + return Image (Dir) & Get_Base_Name (Image (Name)) + & Get_Object_Suffix.all; + end Get_Object_Filename; + + Last_Stamp : Time_Stamp_Id; + Last_Stamp_File : Iir; + + function Is_File_Outdated (Design_File : Iir_Design_File) return Boolean + is + use Files_Map; + + Name : Name_Id; + + File : Source_File_Entry; + begin + -- Std.Standard is never outdated. + if Design_File = Std_Package.Std_Standard_File then + return False; + end if; + + Name := Get_Design_File_Filename (Design_File); + declare + Obj_Pathname : String := Get_Object_Filename (Design_File) & Nul; + Stamp : Time_Stamp_Id; + begin + Stamp := Get_File_Time_Stamp (Obj_Pathname'Address); + + -- If the object file does not exist, recompile the file. + if Stamp = Null_Time_Stamp then + if Flag_Verbose then + Put_Line ("no object file for " & Image (Name)); + end if; + return True; + end if; + + -- Keep the time stamp of the most recently analyzed unit. + if Last_Stamp = Null_Time_Stamp + or else Is_Gt (Stamp, Last_Stamp) + then + Last_Stamp := Stamp; + Last_Stamp_File := Design_File; + end if; + end; + + -- 2) file has been modified. + File := Load_Source_File (Get_Design_File_Directory (Design_File), + Get_Design_File_Filename (Design_File)); + if not Is_Eq (Get_File_Time_Stamp (File), + Get_File_Time_Stamp (Design_File)) + then + if Flag_Verbose then + Put_Line ("file " & Image (Get_File_Name (File)) + & " has been modified"); + end if; + return True; + end if; + + return False; + end Is_File_Outdated; + + function Is_Unit_Outdated (Unit : Iir_Design_Unit) return Boolean + is + Design_File : Iir_Design_File; + begin + -- Std.Standard is never outdated. + if Unit = Std_Package.Std_Standard_Unit then + return False; + end if; + + Design_File := Get_Design_File (Unit); + + -- 1) not yet analyzed: + if Get_Date (Unit) not in Date_Valid then + if Flag_Verbose then + Disp_Library_Unit (Get_Library_Unit (Unit)); + Put_Line (" was not analyzed"); + end if; + return True; + end if; + + -- 3) the object file does not exist. + -- Already checked. + + -- 4) one of the dependence is newer + declare + Depends : Iir_List; + El : Iir; + Dep : Iir_Design_Unit; + Stamp : Time_Stamp_Id; + Dep_File : Iir_Design_File; + begin + Depends := Get_Dependence_List (Unit); + Stamp := Get_Analysis_Time_Stamp (Design_File); + if Depends /= Null_Iir_List then + for I in Natural loop + El := Get_Nth_Element (Depends, I); + exit when El = Null_Iir; + Dep := Libraries.Find_Design_Unit (El); + if Dep = Null_Iir then + if Flag_Verbose then + Disp_Library_Unit (Unit); + Put (" depends on an unknown unit "); + Disp_Library_Unit (El); + New_Line; + end if; + return True; + end if; + Dep_File := Get_Design_File (Dep); + if Dep /= Std_Package.Std_Standard_Unit + and then Files_Map.Is_Gt (Get_Analysis_Time_Stamp (Dep_File), + Stamp) + then + if Flag_Verbose then + Disp_Library_Unit (Get_Library_Unit (Unit)); + Put (" depends on: "); + Disp_Library_Unit (Get_Library_Unit (Dep)); + Put (" (more recently analyzed)"); + New_Line; + end if; + return True; + end if; + end loop; + end if; + end; + + return False; + end Is_Unit_Outdated; + + procedure Add_Argument (Inst : in out Instance; Arg : String_Access) + is + begin + Increment_Last (Inst); + Inst.Table (Last (Inst)) := Arg; + end Add_Argument; + + -- Convert option "-Wx,OPTIONS" to arguments for tool X. + procedure Add_Arguments (Inst : in out Instance; Opt : String) is + begin + Add_Argument (Inst, new String'(Opt (Opt'First + 4 .. Opt'Last))); + end Add_Arguments; + + procedure Tool_Not_Found (Name : String) is + begin + Error ("installation problem: " & Name & " not found"); + raise Option_Error; + end Tool_Not_Found; + + -- Set the compiler command according to the configuration (and swicthes). + procedure Set_Tools_Name is + begin + -- Set tools name. + if Compiler_Cmd = null then + case Compile_Kind is + when Compile_Debug => + Compiler_Cmd := new String'(Default_Pathes.Compiler_Debug); + when Compile_Gcc => + Compiler_Cmd := new String'(Default_Pathes.Compiler_Gcc); + when Compile_Mcode => + Compiler_Cmd := new String'(Default_Pathes.Compiler_Mcode); + when Compile_Llvm => + Compiler_Cmd := new String'(Default_Pathes.Compiler_Llvm); + end case; + end if; + if Post_Processor_Cmd = null then + Post_Processor_Cmd := new String'(Default_Pathes.Post_Processor); + end if; + end Set_Tools_Name; + + function Locate_Exec_Tool (Toolname : String) return String_Access is + begin + if Is_Absolute_Path (Toolname) then + if Is_Executable_File (Toolname) then + return new String'(Toolname); + end if; + else + -- Try from install prefix + if Exec_Prefix /= null then + declare + Path : constant String := + Exec_Prefix.all & Directory_Separator & Toolname; + begin + if Is_Executable_File (Path) then + return new String'(Path); + end if; + end; + end if; + + -- Try configured prefix + declare + Path : constant String := + Default_Pathes.Install_Prefix & Directory_Separator & Toolname; + begin + if Is_Executable_File (Path) then + return new String'(Path); + end if; + end; + end if; + + -- Search the basename on path. + declare + Pos : constant Natural := Get_Basename_Pos (Toolname); + begin + if Pos = 0 then + return Locate_Exec_On_Path (Toolname); + else + return Locate_Exec_On_Path (Toolname (Pos .. Toolname'Last)); + end if; + end; + end Locate_Exec_Tool; + + procedure Locate_Tools is + begin + Compiler_Path := Locate_Exec_Tool (Compiler_Cmd.all); + if Compiler_Path = null then + Tool_Not_Found (Compiler_Cmd.all); + end if; + if Compile_Kind >= Compile_Debug then + Post_Processor_Path := Locate_Exec_Tool (Post_Processor_Cmd.all); + if Post_Processor_Path = null then + Tool_Not_Found (Post_Processor_Cmd.all); + end if; + end if; + if Compile_Kind >= Compile_Gcc then + Assembler_Path := Locate_Exec_On_Path (Assembler_Cmd); + if Assembler_Path = null and not Flag_Asm then + Tool_Not_Found (Assembler_Cmd); + end if; + end if; + Linker_Path := Locate_Exec_On_Path (Linker_Cmd); + if Linker_Path = null then + Tool_Not_Found (Linker_Cmd); + end if; + end Locate_Tools; + + procedure Setup_Compiler (Load : Boolean) + is + use Libraries; + begin + Set_Tools_Name; + Setup_Libraries (Load); + Locate_Tools; + for I in 2 .. Get_Nbr_Pathes loop + Add_Argument (Compiler_Args, + new String'("-P" & Image (Get_Path (I)))); + end loop; + end Setup_Compiler; + + type Command_Comp is abstract new Command_Lib with null record; + + -- Setup GHDL. + procedure Init (Cmd : in out Command_Comp); + + -- Handle: + -- all ghdl flags. + -- some GCC flags. + procedure Decode_Option (Cmd : in out Command_Comp; + Option : String; + Arg : String; + Res : out Option_Res); + + procedure Disp_Long_Help (Cmd : Command_Comp); + + procedure Init (Cmd : in out Command_Comp) + is + begin + -- Init options. + Flag_Not_Quiet := False; + Flag_Disp_Commands := False; + Flag_Asm := False; + Flag_Expect_Failure := False; + Output_File := null; + + -- Initialize argument tables. + Init (Compiler_Args); + Init (Postproc_Args); + Init (Assembler_Args); + Init (Linker_Args); + Init (Command_Lib (Cmd)); + end Init; + + procedure Decode_Option (Cmd : in out Command_Comp; + Option : String; + Arg : String; + Res : out Option_Res) + is + Str : String_Access; + Opt : constant String (1 .. Option'Length) := Option; + begin + Res := Option_Bad; + if Opt = "-v" and then Flag_Verbose = False then + -- Note: this is also decoded for command_lib, but we set + -- Flag_Disp_Commands too. + Flag_Verbose := True; + --Flags.Verbose := True; + Flag_Disp_Commands := True; + Res := Option_Ok; + elsif Opt'Length > 8 and then Opt (1 .. 8) = "--GHDL1=" then + Compiler_Cmd := new String'(Opt (9 .. Opt'Last)); + Res := Option_Ok; + elsif Opt = "-S" then + Flag_Asm := True; + Res := Option_Ok; + elsif Opt = "--post" then + Compile_Kind := Compile_Debug; + Res := Option_Ok; + elsif Opt = "--mcode" then + Compile_Kind := Compile_Mcode; + Res := Option_Ok; + elsif Opt = "--llvm" then + Compile_Kind := Compile_Llvm; + Res := Option_Ok; + elsif Opt = "-o" then + if Arg'Length = 0 then + Res := Option_Arg_Req; + else + Output_File := new String'(Arg); + Res := Option_Arg; + end if; + elsif Opt = "-m32" then + Add_Argument (Compiler_Args, new String'("-m32")); + Add_Argument (Assembler_Args, new String'("--32")); + Add_Argument (Linker_Args, new String'("-m32")); + Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); + elsif Opt'Length > 4 + and then Opt (2) = 'W' and then Opt (4) = ',' + then + if Opt (3) = 'c' then + Add_Arguments (Compiler_Args, Opt); + elsif Opt (3) = 'a' then + Add_Arguments (Assembler_Args, Opt); + elsif Opt (3) = 'p' then + Add_Arguments (Postproc_Args, Opt); + elsif Opt (3) = 'l' then + Add_Arguments (Linker_Args, Opt); + else + Error ("unknown tool name in '-W" & Opt (3) & ",' option"); + raise Option_Error; + end if; + Res := Option_Ok; + elsif Opt'Length >= 2 and then Opt (2) = 'g' then + -- Debugging option. + Str := new String'(Opt); + Add_Argument (Compiler_Args, Str); + Add_Argument (Linker_Args, Str); + Res := Option_Ok; + elsif Opt = "-Q" then + Flag_Not_Quiet := True; + Res := Option_Ok; + elsif Opt = "--expect-failure" then + Add_Argument (Compiler_Args, new String'(Opt)); + Flag_Expect_Failure := True; + Res := Option_Ok; + elsif Opt = "-C" then + -- Translate -C into --mb-comments, as gcc already has a definition + -- for -C. Done before Flags.Parse_Option. + Add_Argument (Compiler_Args, new String'("--mb-comments")); + Res := Option_Ok; + elsif Options.Parse_Option (Opt) then + Add_Argument (Compiler_Args, new String'(Opt)); + Res := Option_Ok; + elsif Opt'Length >= 2 + and then (Opt (2) = 'O' or Opt (2) = 'f') + then + -- Optimization option. + -- This is put after Flags.Parse_Option, since it may catch -fxxx + -- options. + Add_Argument (Compiler_Args, new String'(Opt)); + Res := Option_Ok; + else + Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); + end if; + end Decode_Option; + + procedure Disp_Long_Help (Cmd : Command_Comp) is + begin + Disp_Long_Help (Command_Lib (Cmd)); + Put_Line (" -v Be verbose"); + Put_Line (" --GHDL1=PATH Set the path of the ghdl1 compiler"); + Put_Line (" -S Do not assemble"); + Put_Line (" -o FILE Set the name of the output file"); + -- Put_Line (" -m32 Generate 32bit code on 64bit machines"); + Put_Line (" -WX,OPTION Pass OPTION to X, where X is one of"); + Put_Line (" c: compiler, a: assembler, l: linker"); + Put_Line (" -g[XX] Pass debugging option to the compiler"); + Put_Line (" -O[XX]/-f[XX] Pass optimization option to the compiler"); + Put_Line (" -Q Do not add -quiet option to compiler"); + Put_Line (" --expect-failure Expect analysis/elaboration failure"); + end Disp_Long_Help; + + -- Command dispconfig. + type Command_Dispconfig is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Dispconfig; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Dispconfig) return String; + procedure Perform_Action (Cmd : in out Command_Dispconfig; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Dispconfig; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--dispconfig" or else Name = "--disp-config"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Dispconfig) return String + is + pragma Unreferenced (Cmd); + begin + return "--disp-config Disp tools path"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Dispconfig; + Args : Argument_List) + is + use Libraries; + pragma Unreferenced (Cmd); + begin + if Args'Length /= 0 then + Error ("--dispconfig does not accept any argument"); + raise Option_Error; + end if; + + Set_Tools_Name; + Put_Line ("Pathes at configuration:"); + Put ("compiler command: "); + Put_Line (Compiler_Cmd.all); + if Compile_Kind >= Compile_Debug then + Put ("post-processor command: "); + Put_Line (Post_Processor_Cmd.all); + end if; + if Compile_Kind >= Compile_Gcc then + Put ("assembler command: "); + Put_Line (Assembler_Cmd); + end if; + Put ("linker command: "); + Put_Line (Linker_Cmd); + Put_Line ("default lib prefix: " & Default_Pathes.Lib_Prefix); + + New_Line; + + Put ("command line prefix (--PREFIX): "); + if Switch_Prefix_Path = null then + Put_Line ("(not set)"); + else + Put_Line (Switch_Prefix_Path.all); + end if; + + Put ("environment prefix (GHDL_PREFIX): "); + if Prefix_Env = null then + Put_Line ("(not set)"); + else + Put_Line (Prefix_Env.all); + end if; + + Setup_Libraries (False); + + Put ("exec prefix (from program name): "); + if Exec_Prefix = null then + Put_Line ("(not found)"); + else + Put_Line (Exec_Prefix.all); + end if; + + New_Line; + + Put_Line ("library prefix: " & Lib_Prefix_Path.all); + Put ("library directory: "); + Put_Line (Get_Machine_Path_Prefix); + Locate_Tools; + Put ("compiler path: "); + Put_Line (Compiler_Path.all); + if Compile_Kind >= Compile_Debug then + Put ("post-processor path: "); + Put_Line (Post_Processor_Path.all); + end if; + if Compile_Kind >= Compile_Gcc then + Put ("assembler path: "); + Put_Line (Assembler_Path.all); + end if; + Put ("linker path: "); + Put_Line (Linker_Path.all); + + New_Line; + + Put_Line ("default library pathes:"); + for I in 2 .. Get_Nbr_Pathes loop + Put (' '); + Put_Line (Image (Get_Path (I))); + end loop; + end Perform_Action; + + -- Command Analyze. + type Command_Analyze is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Analyze; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Analyze) return String; + procedure Perform_Action (Cmd : in out Command_Analyze; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Analyze; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-a"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Analyze) return String + is + pragma Unreferenced (Cmd); + begin + return "-a [OPTS] FILEs Analyze FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Analyze; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Nil_Opt : Argument_List (2 .. 1); + begin + if Args'Length = 0 then + Error ("no file to analyze"); + raise Option_Error; + end if; + Setup_Compiler (False); + + for I in Args'Range loop + Do_Compile (Nil_Opt, Args (I).all); + end loop; + end Perform_Action; + + -- Elaboration. + + Base_Name : String_Access; + Elab_Name : String_Access; + Filelist_Name : String_Access; + Unit_Name : String_Access; + + procedure Set_Elab_Units (Cmd_Name : String; + Args : Argument_List; + Run_Arg : out Natural) + is + begin + Extract_Elab_Unit (Cmd_Name, Args, Run_Arg); + if Sec_Name = null then + Base_Name := Prim_Name; + Unit_Name := Prim_Name; + else + Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all); + Unit_Name := new String'(Prim_Name.all & '(' & Sec_Name.all & ')'); + end if; + + Elab_Name := new String'(Elab_Prefix & Base_Name.all); + Filelist_Name := null; + + if Output_File = null then + Output_File := new String'(Base_Name.all); + end if; + end Set_Elab_Units; + + procedure Set_Elab_Units (Cmd_Name : String; Args : Argument_List) + is + Next_Arg : Natural; + begin + Set_Elab_Units (Cmd_Name, Args, Next_Arg); + if Next_Arg <= Args'Last then + Error ("too many unit names for command '" & Cmd_Name & "'"); + raise Option_Error; + end if; + end Set_Elab_Units; + + procedure Bind + is + Comp_List : Argument_List (1 .. 4); + begin + Filelist_Name := new String'(Elab_Name.all & List_Suffix); + + Comp_List (1) := new String'("--elab"); + Comp_List (2) := Unit_Name; + Comp_List (3) := new String'("-l"); + Comp_List (4) := Filelist_Name; + Do_Compile (Comp_List, Elab_Name.all); + Free (Comp_List (3)); + Free (Comp_List (1)); + end Bind; + + procedure Bind_Anaelab (Files : Argument_List) + is + Comp_List : Argument_List (1 .. Files'Length + 2); + Index : Natural; + begin + Comp_List (1) := new String'("--anaelab"); + Comp_List (2) := Unit_Name; + Index := 3; + for I in Files'Range loop + Comp_List (Index) := new String'("--ghdl-source=" & Files (I).all); + Index := Index + 1; + end loop; + Do_Compile (Comp_List, Elab_Name.all); + Free (Comp_List (1)); + for I in 3 .. Comp_List'Last loop + Free (Comp_List (I)); + end loop; + end Bind_Anaelab; + + procedure Link (Add_Std : Boolean; + Disp_Only : Boolean) + is + Last_File : Natural; + begin + Link_Obj_Suffix := Get_Object_Suffix; + + -- read files list + if Filelist_Name /= null then + Add_File_List (Filelist_Name.all, True); + end if; + Last_File := Filelist.Last; + Add_File_List (Get_Machine_Path_Prefix & "grt" & List_Suffix, False); + + -- call the linker + declare + P : Natural; + Nbr_Args : constant Natural := Last (Linker_Args) + Filelist.Last + 4; + Args : Argument_List (1 .. Nbr_Args); + Obj_File : String_Access; + Std_File : String_Access; + begin + Obj_File := Append_Suffix (Elab_Name.all, Link_Obj_Suffix.all); + P := 0; + Args (P + 1) := Dash_o; + Args (P + 2) := Output_File; + Args (P + 3) := Obj_File; + P := P + 3; + if Add_Std then + Std_File := new + String'(Get_Machine_Path_Prefix + & Get_Version_Path & Directory_Separator + & "std" & Directory_Separator + & "std_standard" & Link_Obj_Suffix.all); + P := P + 1; + Args (P) := Std_File; + else + Std_File := null; + end if; + + -- Object files of the design. + for I in Filelist.First .. Last_File loop + P := P + 1; + Args (P) := Filelist.Table (I); + end loop; + -- User added options. + for I in First .. Last (Linker_Args) loop + P := P + 1; + Args (P) := Linker_Args.Table (I); + end loop; + -- GRT files (should be the last one, since it contains an + -- optional main). + for I in Last_File + 1 .. Filelist.Last loop + P := P + 1; + Args (P) := Filelist.Table (I); + end loop; + + if Disp_Only then + for I in 3 .. P loop + Put_Line (Args (I).all); + end loop; + else + My_Spawn (Linker_Path.all, Args (1 .. P)); + end if; + + Free (Obj_File); + Free (Std_File); + end; + + for I in Filelist.First .. Filelist.Last loop + Free (Filelist.Table (I)); + end loop; + end Link; + + -- Command Elab. + type Command_Elab is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Elab; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Elab) return String; + procedure Perform_Action (Cmd : in out Command_Elab; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Elab; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-e"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Elab) return String + is + pragma Unreferenced (Cmd); + begin + return "-e [OPTS] UNIT [ARCH] Elaborate UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Elab; Args : Argument_List) + is + pragma Unreferenced (Cmd); + Success : Boolean; + pragma Unreferenced (Success); + begin + Set_Elab_Units ("-e", Args); + Setup_Compiler (False); + + Bind; + if not Flag_Expect_Failure then + Link (Add_Std => True, Disp_Only => False); + end if; + Delete_File (Filelist_Name.all, Success); + end Perform_Action; + + -- Command Run. + type Command_Run is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Run; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Run) return String; + procedure Perform_Action (Cmd : in out Command_Run; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Run; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-r"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Run) return String + is + pragma Unreferenced (Cmd); + begin + return "-r UNIT [ARCH] [OPTS] Run UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Run; Args : Argument_List) + is + pragma Unreferenced (Cmd); + Opt_Arg : Natural; + begin + Extract_Elab_Unit ("-r", Args, Opt_Arg); + if Sec_Name = null then + Base_Name := Prim_Name; + else + Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all); + end if; + if not Is_Regular_File (Base_Name.all & Nul) then + Error ("file '" & Base_Name.all & "' does not exists"); + Error ("Please elaborate your design."); + raise Exec_Error; + end if; + My_Spawn ('.' & Directory_Separator & Base_Name.all, + Args (Opt_Arg .. Args'Last)); + end Perform_Action; + + -- Command Elab_Run. + type Command_Elab_Run is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Elab_Run; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Elab_Run) return String; + procedure Perform_Action (Cmd : in out Command_Elab_Run; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Elab_Run; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--elab-run"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Elab_Run) return String + is + pragma Unreferenced (Cmd); + begin + return "--elab-run [OPTS] UNIT [ARCH] [OPTS] Elaborate and run UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Elab_Run; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Success : Boolean; + Run_Arg : Natural; + begin + Set_Elab_Units ("-elab-run", Args, Run_Arg); + Setup_Compiler (False); + + Bind; + if Flag_Expect_Failure then + Delete_File (Filelist_Name.all, Success); + else + Link (Add_Std => True, Disp_Only => False); + Delete_File (Filelist_Name.all, Success); + My_Spawn ('.' & Directory_Separator & Output_File.all, + Args (Run_Arg .. Args'Last)); + end if; + end Perform_Action; + + -- Command Bind. + type Command_Bind is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Bind; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Bind) return String; + procedure Perform_Action (Cmd : in out Command_Bind; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Bind; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--bind"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Bind) return String + is + pragma Unreferenced (Cmd); + begin + return "--bind [OPTS] UNIT [ARCH] Bind UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Bind; Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + Set_Elab_Units ("--bind", Args); + Setup_Compiler (False); + + Bind; + end Perform_Action; + + -- Command Link. + type Command_Link is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Link; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Link) return String; + procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List); + + function Decode_Command (Cmd : Command_Link; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--link"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Link) return String + is + pragma Unreferenced (Cmd); + begin + return "--link [OPTS] UNIT [ARCH] Link UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + Set_Elab_Units ("--link", Args); + Setup_Compiler (False); + + Filelist_Name := new String'(Elab_Name.all & List_Suffix); + Link (Add_Std => True, Disp_Only => False); + end Perform_Action; + + + -- Command List_Link. + type Command_List_Link is new Command_Comp with null record; + function Decode_Command (Cmd : Command_List_Link; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_List_Link) return String; + procedure Perform_Action (Cmd : in out Command_List_Link; + Args : Argument_List); + + function Decode_Command (Cmd : Command_List_Link; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--list-link"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_List_Link) return String + is + pragma Unreferenced (Cmd); + begin + return "--list-link [OPTS] UNIT [ARCH] List objects file to link UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_List_Link; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + Set_Elab_Units ("--list-link", Args); + Setup_Compiler (False); + + Filelist_Name := new String'(Elab_Name.all & List_Suffix); + Link (Add_Std => True, Disp_Only => True); + end Perform_Action; + + + -- Command analyze and elaborate + type Command_Anaelab is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Anaelab; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Anaelab) return String; + procedure Decode_Option (Cmd : in out Command_Anaelab; + Option : String; + Arg : String; + Res : out Option_Res); + + procedure Perform_Action (Cmd : in out Command_Anaelab; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Anaelab; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-c"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Anaelab) return String + is + pragma Unreferenced (Cmd); + begin + return "-c [OPTS] FILEs -e UNIT [ARCH] " + & "Generate whole code to elab UNIT from FILEs"; + end Get_Short_Help; + + procedure Decode_Option (Cmd : in out Command_Anaelab; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "-e" then + Res := Option_End; + return; + else + Decode_Option (Command_Comp (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Perform_Action (Cmd : in out Command_Anaelab; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Elab_Index : Integer; + begin + Elab_Index := -1; + for I in Args'Range loop + if Args (I).all = "-e" then + Elab_Index := I; + exit; + end if; + end loop; + if Elab_Index < 0 then + Analyze_Files (Args, True); + else + Flags.Flag_Whole_Analyze := True; + Set_Elab_Units ("-c", Args (Elab_Index + 1 .. Args'Last)); + Setup_Compiler (False); + + Bind_Anaelab (Args (Args'First .. Elab_Index - 1)); + Link (Add_Std => False, Disp_Only => False); + end if; + end Perform_Action; + + -- Command Make. + type Command_Make is new Command_Comp with record + -- Disp dependences during make. + Flag_Depend_Unit : Boolean; + + -- Force recompilation of units in work library. + Flag_Force : Boolean; + end record; + + function Decode_Command (Cmd : Command_Make; Name : String) + return Boolean; + procedure Init (Cmd : in out Command_Make); + procedure Decode_Option (Cmd : in out Command_Make; + Option : String; + Arg : String; + Res : out Option_Res); + + function Get_Short_Help (Cmd : Command_Make) return String; + procedure Disp_Long_Help (Cmd : Command_Make); + + procedure Perform_Action (Cmd : in out Command_Make; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Make; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-m"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Make) return String + is + pragma Unreferenced (Cmd); + begin + return "-m [OPTS] UNIT [ARCH] Make UNIT"; + end Get_Short_Help; + + procedure Disp_Long_Help (Cmd : Command_Make) + is + begin + Disp_Long_Help (Command_Comp (Cmd)); + Put_Line (" -f Force recompilation of work units"); + Put_Line (" -Mu Disp unit dependences (human format)"); + end Disp_Long_Help; + + procedure Init (Cmd : in out Command_Make) is + begin + Init (Command_Comp (Cmd)); + Cmd.Flag_Depend_Unit := False; + Cmd.Flag_Force := False; + end Init; + + procedure Decode_Option (Cmd : in out Command_Make; + Option : String; + Arg : String; + Res : out Option_Res) is + begin + if Option = "-Mu" then + Cmd.Flag_Depend_Unit := True; + Res := Option_Ok; + elsif Option = "-f" then + Cmd.Flag_Force := True; + Res := Option_Ok; + else + Decode_Option (Command_Comp (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List) + is + use Configuration; + + File : Iir_Design_File; + Unit : Iir; + Lib_Unit : Iir; + Lib : Iir_Library_Declaration; + In_Work : Boolean; + + Files_List : Iir_List; + + -- Set when a design file has been compiled. + Has_Compiled : Boolean; + + Need_Analyze : Boolean; + + Need_Elaboration : Boolean; + + Stamp : Time_Stamp_Id; + File_Id : Name_Id; + + Nil_Args : Argument_List (2 .. 1); + Success : Boolean; + begin + Set_Elab_Units ("-m", Args); + Setup_Compiler (True); + + -- Create list of files. + Files_List := Build_Dependence (Prim_Name, Sec_Name); + + if Cmd.Flag_Depend_Unit then + Put_Line ("Units analysis order:"); + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Put (" "); + Disp_Library_Unit (Get_Library_Unit (Unit)); + New_Line; +-- Put (" file: "); +-- File := Get_Design_File (Unit); +-- Image (Get_Design_File_Filename (File)); +-- Put_Line (Name_Buffer (1 .. Name_Length)); + end loop; + end if; + if Cmd.Flag_Depend_Unit then + Put_Line ("File analysis order:"); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + Image (Get_Design_File_Filename (File)); + Put (" "); + Put (Name_Buffer (1 .. Name_Length)); + if Flag_Verbose then + Put_Line (":"); + declare + Dep_List : Iir_List; + Dep_File : Iir; + begin + Dep_List := Get_File_Dependence_List (File); + if Dep_List /= Null_Iir_List then + for J in Natural loop + Dep_File := Get_Nth_Element (Dep_List, J); + exit when Dep_File = Null_Iir; + Image (Get_Design_File_Filename (Dep_File)); + Put (" "); + Put_Line (Name_Buffer (1 .. Name_Length)); + end loop; + end if; + end; + else + New_Line; + end if; + end loop; + end if; + + Has_Compiled := False; + Last_Stamp := Null_Time_Stamp; + + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + + Need_Analyze := False; + if Is_File_Outdated (File) then + Need_Analyze := True; + else + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + Lib_Unit := Get_Library_Unit (Unit); + if not (Get_Kind (Lib_Unit) = Iir_Kind_Configuration_Declaration + and then Get_Identifier (Lib_Unit) = Null_Identifier) + then + if Is_Unit_Outdated (Unit) then + Need_Analyze := True; + exit; + end if; + end if; + Unit := Get_Chain (Unit); + end loop; + end if; + + Lib := Get_Library (File); + In_Work := Lib = Libraries.Work_Library; + + if Need_Analyze or else (Cmd.Flag_Force and In_Work) then + File_Id := Get_Design_File_Filename (File); + if not Flag_Verbose then + Put ("analyze "); + Put (Image (File_Id)); + --Disp_Library_Unit (Get_Library_Unit (Unit)); + New_Line; + end if; + + if In_Work then + Do_Compile (Nil_Args, Image (File_Id)); + else + declare + use Libraries; + Lib_Args : Argument_List (1 .. 2); + Prev_Workdir : Name_Id; + begin + Prev_Workdir := Work_Directory; + + -- Must be set, since used to build the object filename. + Work_Directory := Get_Library_Directory (Lib); + + -- Always overwrite --work and --workdir. + Lib_Args (1) := new String' + ("--work=" & Image (Get_Identifier (Lib))); + if Work_Directory = Libraries.Local_Directory then + Lib_Args (2) := new String'("--workdir=."); + else + Lib_Args (2) := new String' + ("--workdir=" & Image (Work_Directory)); + end if; + Do_Compile (Lib_Args, Image (File_Id)); + + Work_Directory := Prev_Workdir; + + Free (Lib_Args (1)); + Free (Lib_Args (2)); + end; + end if; + + Has_Compiled := True; + -- Set the analysis time stamp since the file has just been + -- analyzed. + Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp); + end if; + end loop; + + Need_Elaboration := False; + -- Elaboration. + -- if libgrt is more recent than the executable (FIXME). + if Has_Compiled then + if Flag_Verbose then + Put_Line ("link due to a file compilation"); + end if; + Need_Elaboration := True; + else + declare + Exec_File : String := Output_File.all & Nul; + begin + Stamp := Files_Map.Get_File_Time_Stamp (Exec_File'Address); + end; + + if Stamp = Null_Time_Stamp then + if Flag_Verbose then + Put_Line ("link due to no binary file"); + end if; + Need_Elaboration := True; + else + if Files_Map.Is_Gt (Last_Stamp, Stamp) then + -- if a file is more recent than the executable. + if Flag_Verbose then + Put ("link due to outdated binary file: "); + Put (Image (Get_Design_File_Filename (Last_Stamp_File))); + Put (" ("); + Put (Files_Map.Get_Time_Stamp_String (Last_Stamp)); + Put (" > "); + Put (Files_Map.Get_Time_Stamp_String (Stamp)); + Put (")"); + New_Line; + end if; + Need_Elaboration := True; + end if; + end if; + end if; + if Need_Elaboration then + if not Flag_Verbose then + Put ("elaborate "); + Put (Prim_Name.all); + --Disp_Library_Unit (Get_Library_Unit (Unit)); + New_Line; + end if; + Bind; + Link (Add_Std => True, Disp_Only => False); + Delete_File (Filelist_Name.all, Success); + end if; + exception + when Errorout.Compilation_Error => + if Flag_Expect_Failure then + return; + else + raise; + end if; + end Perform_Action; + + -- Command Gen_Makefile. + type Command_Gen_Makefile is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Gen_Makefile) return String; + procedure Perform_Action (Cmd : in out Command_Gen_Makefile; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--gen-makefile"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Gen_Makefile) return String + is + pragma Unreferenced (Cmd); + begin + return "--gen-makefile [OPTS] UNIT [ARCH] Generate a Makefile for UNIT"; + end Get_Short_Help; + + function Is_Makeable_File (File : Iir_Design_File) return Boolean is + begin + if File = Std_Package.Std_Standard_File then + return False; + end if; + return True; + end Is_Makeable_File; + + procedure Perform_Action (Cmd : in out Command_Gen_Makefile; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + + HT : constant Character := Ada.Characters.Latin_1.HT; + Files_List : Iir_List; + File : Iir_Design_File; + + Lib : Iir_Library_Declaration; + Dir_Id : Name_Id; + + Dep_List : Iir_List; + Dep_File : Iir; + begin + Set_Elab_Units ("--gen-makefile", Args); + Setup_Libraries (True); + Files_List := Build_Dependence (Prim_Name, Sec_Name); + + Put_Line ("# Makefile automatically generated by ghdl"); + Put ("# Version: "); + Put (Version.Ghdl_Release); + Put (" - "); + if Version_String /= null then + Put (Version_String.all); + end if; + New_Line; + Put_Line ("# Command used to generate this makefile:"); + Put ("# "); + Put (Command_Name); + for I in 1 .. Argument_Count loop + Put (' '); + Put (Argument (I)); + end loop; + New_Line; + + New_Line; + + Put ("GHDL="); + Put_Line (Command_Name); + + -- Extract options for command line. + Put ("GHDLFLAGS="); + for I in 2 .. Argument_Count loop + declare + Arg : constant String := Argument (I); + begin + if Arg (1) = '-' then + if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=") + or else (Arg'Length > 7 and then Arg (1 .. 7) = "--ieee=") + or else (Arg'Length > 6 and then Arg (1 .. 6) = "--std=") + or else (Arg'Length > 7 and then Arg (1 .. 7) = "--work=") + or else (Arg'Length > 2 and then Arg (1 .. 2) = "-P") + then + Put (" "); + Put (Arg); + end if; + end if; + end; + end loop; + New_Line; + + New_Line; + + Put_Line ("# Default target"); + Put ("all: "); + Put_Line (Base_Name.all); + New_Line; + + Put_Line ("# Elaboration target"); + Put (Base_Name.all); + Put (":"); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + if Is_Makeable_File (File) then + Put (" "); + Put (Get_Object_Filename (File)); + end if; + end loop; + New_Line; + Put_Line (HT & "$(GHDL) -e $(GHDLFLAGS) $@"); + New_Line; + + Put_Line ("# Run target"); + Put_Line ("run: " & Base_Name.all); + Put_Line (HT & "$(GHDL) -r " & Base_Name.all & " $(GHDLRUNFLAGS)"); + New_Line; + + Put_Line ("# Targets to analyze files"); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + Dir_Id := Get_Design_File_Directory (File); + if not Is_Makeable_File (File) then + -- Builtin file. + null; + else + Put (Get_Object_Filename (File)); + Put (": "); + if Dir_Id /= Files_Map.Get_Home_Directory then + Put (Image (Dir_Id)); + Put (Image (Get_Design_File_Filename (File))); + New_Line; + + Put_Line + (HT & "@echo ""This file was not locally built ($<)"""); + Put_Line (HT & "exit 1"); + else + Put (Image (Get_Design_File_Filename (File))); + New_Line; + + Put (HT & "$(GHDL) -a $(GHDLFLAGS)"); + Lib := Get_Library (File); + if Lib /= Libraries.Work_Library then + -- Overwrite some options. + Put (" --work="); + Put (Image (Get_Identifier (Lib))); + Dir_Id := Get_Library_Directory (Lib); + Put (" --workdir="); + if Dir_Id = Libraries.Local_Directory then + Put ("."); + else + Put (Image (Dir_Id)); + end if; + end if; + Put_Line (" $<"); + end if; + end if; + end loop; + New_Line; + + Put_Line ("# Files dependences"); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + if Is_Makeable_File (File) then + Put (Get_Object_Filename (File)); + Put (": "); + Dep_List := Get_File_Dependence_List (File); + if Dep_List /= Null_Iir_List then + for J in Natural loop + Dep_File := Get_Nth_Element (Dep_List, J); + exit when Dep_File = Null_Iir; + if Dep_File /= File and then Is_Makeable_File (Dep_File) + then + Put (" "); + Put (Get_Object_Filename (Dep_File)); + end if; + end loop; + end if; + New_Line; + end if; + end loop; + end Perform_Action; + + procedure Register_Commands is + begin + Register_Command (new Command_Analyze); + Register_Command (new Command_Elab); + Register_Command (new Command_Run); + Register_Command (new Command_Elab_Run); + Register_Command (new Command_Bind); + Register_Command (new Command_Link); + Register_Command (new Command_List_Link); + Register_Command (new Command_Anaelab); + Register_Command (new Command_Make); + Register_Command (new Command_Gen_Makefile); + Register_Command (new Command_Dispconfig); + end Register_Commands; +end Ghdldrv; diff --git a/src/translate/ghdldrv/ghdldrv.ads b/src/translate/ghdldrv/ghdldrv.ads new file mode 100644 index 0000000..3e37b38 --- /dev/null +++ b/src/translate/ghdldrv/ghdldrv.ads @@ -0,0 +1,25 @@ +-- GHDL driver - commands invoking gcc. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Ghdldrv is + -- Compiler to use. + type Compile_Kind_Type is + (Compile_Mcode, Compile_Llvm, Compile_Gcc, Compile_Debug); + Compile_Kind : Compile_Kind_Type := Compile_Gcc; + + procedure Register_Commands; +end Ghdldrv; diff --git a/src/translate/ghdldrv/ghdllocal.adb b/src/translate/ghdldrv/ghdllocal.adb new file mode 100644 index 0000000..a1d94bd --- /dev/null +++ b/src/translate/ghdldrv/ghdllocal.adb @@ -0,0 +1,1415 @@ +-- GHDL driver - local commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Text_IO; +with Ada.Command_Line; use Ada.Command_Line; +with GNAT.Directory_Operations; +with Types; use Types; +with Libraries; +with Std_Package; +with Flags; +with Name_Table; +with Std_Names; +with Back_End; +with Disp_Vhdl; +with Default_Pathes; +with Scanner; +with Sem; +with Canon; +with Errorout; +with Configuration; +with Files_Map; +with Post_Sems; +with Disp_Tree; +with Options; +with Iirs_Utils; use Iirs_Utils; + +package body Ghdllocal is + -- Version of the IEEE library to use. This just change pathes. + type Ieee_Lib_Kind is (Lib_Standard, Lib_None, Lib_Synopsys, Lib_Mentor); + Flag_Ieee : Ieee_Lib_Kind; + + Flag_Create_Default_Config : constant Boolean := True; + + -- If TRUE, generate 32bits code on 64bits machines. + Flag_32bit : Boolean := False; + + procedure Finish_Compilation + (Unit : Iir_Design_Unit; Main : Boolean := False) + is + use Errorout; + use Ada.Text_IO; + Config : Iir_Design_Unit; + Lib : Iir; + begin + if (Main or Flags.Dump_All) and then Flags.Dump_Parse then + Disp_Tree.Disp_Tree (Unit); + end if; + + if Flags.Verbose then + Put_Line ("semantize " & Disp_Node (Get_Library_Unit (Unit))); + end if; + + Sem.Semantic (Unit); + + if (Main or Flags.Dump_All) and then Flags.Dump_Sem then + Disp_Tree.Disp_Tree (Unit); + end if; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if (Main or Flags.List_All) and then Flags.List_Sem then + Disp_Vhdl.Disp_Vhdl (Unit); + end if; + + Post_Sems.Post_Sem_Checks (Unit); + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if Flags.Flag_Elaborate then + if Flags.Verbose then + Put_Line ("canonicalize " & Disp_Node (Get_Library_Unit (Unit))); + end if; + + Canon.Canonicalize (Unit); + + if Flag_Create_Default_Config then + Lib := Get_Library_Unit (Unit); + if Get_Kind (Lib) = Iir_Kind_Architecture_Body then + Config := Canon.Create_Default_Configuration_Declaration (Lib); + Set_Default_Configuration_Declaration (Lib, Config); + end if; + end if; + end if; + end Finish_Compilation; + + procedure Init (Cmd : in out Command_Lib) + is + pragma Unreferenced (Cmd); + begin + Options.Initialize; + Flag_Ieee := Lib_Standard; + Back_End.Finish_Compilation := Finish_Compilation'Access; + Flag_Verbose := False; + end Init; + + procedure Decode_Option (Cmd : in out Command_Lib; + Option : String; + Arg : String; + Res : out Option_Res) + is + pragma Unreferenced (Cmd); + pragma Unreferenced (Arg); + Opt : constant String (1 .. Option'Length) := Option; + begin + Res := Option_Bad; + if Opt = "-v" and then Flag_Verbose = False then + Flag_Verbose := True; + Res := Option_Ok; + elsif Opt'Length > 9 and then Opt (1 .. 9) = "--PREFIX=" then + Switch_Prefix_Path := new String'(Opt (10 .. Opt'Last)); + Res := Option_Ok; + elsif Opt = "--ieee=synopsys" then + Flag_Ieee := Lib_Synopsys; + Res := Option_Ok; + elsif Opt = "--ieee=mentor" then + Flag_Ieee := Lib_Mentor; + Res := Option_Ok; + elsif Opt = "--ieee=none" then + Flag_Ieee := Lib_None; + Res := Option_Ok; + elsif Opt = "--ieee=standard" then + Flag_Ieee := Lib_Standard; + Res := Option_Ok; + elsif Opt = "-m32" then + Flag_32bit := True; + Res := Option_Ok; + elsif Opt'Length >= 2 + and then (Opt (2) = 'g' or Opt (2) = 'O') + then + -- Silently accept -g and -O. + Res := Option_Ok; + else + if Options.Parse_Option (Opt) then + Res := Option_Ok; + end if; + end if; + end Decode_Option; + + procedure Disp_Long_Help (Cmd : Command_Lib) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + procedure P (Str : String) renames Put_Line; + begin + P ("Main options (try --options-help for details):"); + P (" --std=XX Use XX as VHDL standard (87,93c,93,00 or 02)"); + P (" --work=NAME Set the name of the WORK library"); + P (" -PDIR Add DIR in the library search path"); + P (" --workdir=DIR Specify the directory of the WORK library"); + P (" --PREFIX=DIR Specify installation prefix"); + P (" --ieee=NAME Use NAME as ieee library, where name is:"); + P (" standard: standard version (default)"); + P (" synopsys, mentor: vendor version (not advised)"); + P (" none: do not use a predefined ieee library"); + end Disp_Long_Help; + + function Is_Directory_Separator (C : Character) return Boolean is + begin + return C = '/' or else C = Directory_Separator; + end Is_Directory_Separator; + + function Get_Basename_Pos (Pathname : String) return Natural is + begin + for I in reverse Pathname'Range loop + if Is_Directory_Separator (Pathname (I)) then + return I; + end if; + end loop; + return 0; + end Get_Basename_Pos; + + procedure Set_Prefix_From_Program_Path (Prog_Path : String) + is + Dir_Pos : Natural; + begin + Dir_Pos := Get_Basename_Pos (Prog_Path); + if Dir_Pos = 0 then + -- No directory in Prog_Path. This is not expected. + return; + end if; + + declare + Pathname : String := + Normalize_Pathname (Prog_Path (Dir_Pos + 1 .. Prog_Path'Last), + Prog_Path (Prog_Path'First .. Dir_Pos - 1)); + Pos : Natural; + begin + -- Stop now in case of error. + if Pathname'Length = 0 then + return; + end if; + + -- Skip executable name + Dir_Pos := Get_Basename_Pos (Pathname); + if Dir_Pos = 0 then + return; + end if; + + -- Simplify path: + -- /./ => / + -- // => / + Pos := Dir_Pos - 1; + while Pos >= Pathname'First loop + if Is_Directory_Separator (Pathname (Pos)) then + if Is_Directory_Separator (Pathname (Pos + 1)) then + -- // => / + Pathname (Pos .. Dir_Pos - 1) := + Pathname (Pos + 1 .. Dir_Pos); + Dir_Pos := Dir_Pos - 1; + elsif Pos + 2 <= Dir_Pos + and then Pathname (Pos + 1) = '.' + and then Is_Directory_Separator (Pathname (Pos + 2)) + then + -- /./ => / + Pathname (Pos .. Dir_Pos - 2) := + Pathname (Pos + 2 .. Dir_Pos); + Dir_Pos := Dir_Pos - 2; + end if; + end if; + Pos := Pos - 1; + end loop; + + -- Simplify path: + -- /xxx/../ => / + -- This is done after the previous simplication to avoid to deal + -- with cases like /xxx//../ or /xxx/./../ + Pos := Dir_Pos - 3; + while Pos >= Pathname'First loop + if Is_Directory_Separator (Pathname (Pos)) + and then Pathname (Pos + 1) = '.' + and then Pathname (Pos + 2) = '.' + and then Is_Directory_Separator (Pathname (Pos + 3)) + then + declare + Pos2 : constant Natural := + Get_Basename_Pos (Pathname (Pathname'First .. Pos - 1)); + -- /xxxxxxxxxx/../ + -- ^ ^ + -- Pos2 Pos + Len : Natural; + begin + if Pos2 = 0 then + -- Shouldn't happen. + return; + end if; + Len := Pos + 3 - Pos2; + Pathname (Pos2 + 1 .. Dir_Pos - Len) := + Pathname (Pos + 4 .. Dir_Pos); + Dir_Pos := Dir_Pos - Len; + if Pos2 < Pathname'First + 3 then + exit; + end if; + Pos := Pos2 - 3; + end; + else + Pos := Pos - 1; + end if; + end loop; + + -- Remove last '/' + Dir_Pos := Dir_Pos - 1; + + -- Skip directory. + Dir_Pos := Get_Basename_Pos (Pathname (Pathname'First .. Dir_Pos)); + if Dir_Pos = 0 then + return; + end if; + + Exec_Prefix := new String'(Pathname (Pathname'First .. Dir_Pos - 1)); + end; + end Set_Prefix_From_Program_Path; + + -- Extract Exec_Prefix from executable name. + procedure Set_Exec_Prefix + is + use GNAT.Directory_Operations; + Prog_Path : constant String := Ada.Command_Line.Command_Name; + Exec_Path : String_Access; + begin + -- If the command name is an absolute path, deduce prefix from it. + if Is_Absolute_Path (Prog_Path) then + Set_Prefix_From_Program_Path (Prog_Path); + return; + end if; + + -- If the command name is a relative path, deduce prefix from it + -- and current path. + if Get_Basename_Pos (Prog_Path) /= 0 then + if Is_Executable_File (Prog_Path) then + Set_Prefix_From_Program_Path + (Get_Current_Dir & Directory_Separator & Prog_Path); + end if; + return; + end if; + + -- Look for program name on the path. + Exec_Path := Locate_Exec_On_Path (Prog_Path); + if Exec_Path /= null then + Set_Prefix_From_Program_Path (Exec_Path.all); + Free (Exec_Path); + end if; + end Set_Exec_Prefix; + + function Get_Version_Path return String + is + use Flags; + begin + case Vhdl_Std is + when Vhdl_87 => + return "v87"; + when Vhdl_93c + | Vhdl_93 + | Vhdl_00 + | Vhdl_02 => + return "v93"; + when Vhdl_08 => + return "v08"; + end case; + end Get_Version_Path; + + function Get_Machine_Path_Prefix return String is + begin + if Flag_32bit then + return Lib_Prefix_Path.all & "32"; + else + return Lib_Prefix_Path.all; + end if; + end Get_Machine_Path_Prefix; + + procedure Add_Library_Path (Name : String) + is + begin + Libraries.Add_Library_Path + (Get_Machine_Path_Prefix & Directory_Separator + & Get_Version_Path & Directory_Separator + & Name & Directory_Separator); + end Add_Library_Path; + + procedure Setup_Libraries (Load : Boolean) + is + begin + -- Get environment variable. + Prefix_Env := GNAT.OS_Lib.Getenv ("GHDL_PREFIX"); + if Prefix_Env = null or else Prefix_Env.all = "" then + Prefix_Env := null; + end if; + + -- Compute Exec_Prefix. + Set_Exec_Prefix; + + -- Set prefix path. + -- If not set by command line, try environment variable. + if Switch_Prefix_Path /= null then + Lib_Prefix_Path := Switch_Prefix_Path; + else + Lib_Prefix_Path := Prefix_Env; + end if; + -- Else try default path. + if Lib_Prefix_Path = null then + if Is_Absolute_Path (Default_Pathes.Lib_Prefix) then + Lib_Prefix_Path := new String'(Default_Pathes.Lib_Prefix); + else + if Exec_Prefix /= null then + Lib_Prefix_Path := new + String'(Exec_Prefix.all & Directory_Separator + & Default_Pathes.Lib_Prefix); + end if; + if Lib_Prefix_Path = null + or else not Is_Directory (Lib_Prefix_Path.all) + then + Free (Lib_Prefix_Path); + Lib_Prefix_Path := new + String'(Default_Pathes.Install_Prefix + & Directory_Separator + & Default_Pathes.Lib_Prefix); + end if; + end if; + else + -- Assume the user has set the correct path, so do not insert 32. + Flag_32bit := False; + end if; + + -- Add pathes for predefined libraries. + if not Flags.Bootstrap then + Add_Library_Path ("std"); + case Flag_Ieee is + when Lib_Standard => + Add_Library_Path ("ieee"); + when Lib_Synopsys => + Add_Library_Path ("synopsys"); + when Lib_Mentor => + Add_Library_Path ("mentor"); + when Lib_None => + null; + end case; + end if; + if Load then + Libraries.Load_Std_Library; + Libraries.Load_Work_Library; + end if; + end Setup_Libraries; + + procedure Disp_Library_Unit (Unit : Iir) + is + use Ada.Text_IO; + use Name_Table; + Id : Name_Id; + begin + Id := Get_Identifier (Unit); + case Get_Kind (Unit) is + when Iir_Kind_Entity_Declaration => + Put ("entity "); + when Iir_Kind_Architecture_Body => + Put ("architecture "); + when Iir_Kind_Configuration_Declaration => + Put ("configuration "); + when Iir_Kind_Package_Declaration => + Put ("package "); + when Iir_Kind_Package_Instantiation_Declaration => + Put ("package instance "); + when Iir_Kind_Package_Body => + Put ("package body "); + when others => + Put ("???"); + return; + end case; + Image (Id); + Put (Name_Buffer (1 .. Name_Length)); + case Get_Kind (Unit) is + when Iir_Kind_Architecture_Body => + Put (" of "); + Image (Get_Entity_Identifier_Of_Architecture (Unit)); + Put (Name_Buffer (1 .. Name_Length)); + when Iir_Kind_Configuration_Declaration => + if Id = Null_Identifier then + Put ("<default> of entity "); + Image (Get_Entity_Identifier_Of_Architecture (Unit)); + Put (Name_Buffer (1 .. Name_Length)); + end if; + when others => + null; + end case; + end Disp_Library_Unit; + + procedure Disp_Library (Name : Name_Id) + is + use Ada.Text_IO; + use Libraries; + Lib : Iir_Library_Declaration; + File : Iir_Design_File; + Unit : Iir; + begin + if Name = Std_Names.Name_Work then + Lib := Work_Library; + elsif Name = Std_Names.Name_Std then + Lib := Std_Library; + else + Lib := Get_Library (Name, Command_Line_Location); + end if; + + -- Disp contents of files. + File := Get_Design_File_Chain (Lib); + while File /= Null_Iir loop + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + Disp_Library_Unit (Get_Library_Unit (Unit)); + New_Line; + Unit := Get_Chain (Unit); + end loop; + File := Get_Chain (File); + end loop; + end Disp_Library; + + -- Return FILENAME without the extension. + function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True) + return String + is + First : Natural; + Last : Natural; + begin + First := Filename'First; + Last := Filename'Last; + for I in Filename'Range loop + if Filename (I) = '.' then + Last := I - 1; + elsif Remove_Dir and then Filename (I) = Directory_Separator then + First := I + 1; + Last := Filename'Last; + end if; + end loop; + return Filename (First .. Last); + end Get_Base_Name; + + function Append_Suffix (File : String; Suffix : String) return String_Access + is + use Name_Table; + Basename : constant String := Get_Base_Name (File); + begin + Image (Libraries.Work_Directory); + Name_Buffer (Name_Length + 1 .. Name_Length + Basename'Length) := + Basename; + Name_Length := Name_Length + Basename'Length; + Name_Buffer (Name_Length + 1 .. Name_Length + Suffix'Length) := Suffix; + Name_Length := Name_Length + Suffix'Length; + return new String'(Name_Buffer (1 .. Name_Length)); + end Append_Suffix; + + + -- Command Dir. + type Command_Dir is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean; + function Get_Short_Help (Cmd : Command_Dir) return String; + procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List); + + function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-d" or else Name = "--dir"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Dir) return String + is + pragma Unreferenced (Cmd); + begin + return "-d or --dir Disp contents of the work library"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + if Args'Length /= 0 then + Error ("command '-d' does not accept any argument"); + raise Option_Error; + end if; + + Flags.Bootstrap := True; + -- Load word library. + Libraries.Load_Std_Library; + Libraries.Load_Work_Library; + + Disp_Library (Std_Names.Name_Work); + +-- else +-- for L in Libs'Range loop +-- Id := Get_Identifier (Libs (L).all); +-- Disp_Library (Id); +-- end loop; +-- end if; + end Perform_Action; + + -- Command Find. + type Command_Find is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Find; Name : String) return Boolean; + function Get_Short_Help (Cmd : Command_Find) return String; + procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List); + + function Decode_Command (Cmd : Command_Find; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-f"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Find) return String + is + pragma Unreferenced (Cmd); + begin + return "-f FILEs Disp units in FILES"; + end Get_Short_Help; + + -- Return TRUE is UNIT can be at the apex of a design hierarchy. + function Is_Top_Entity (Unit : Iir) return Boolean + is + begin + if Get_Kind (Unit) /= Iir_Kind_Entity_Declaration then + return False; + end if; + if Get_Port_Chain (Unit) /= Null_Iir then + return False; + end if; + if Get_Generic_Chain (Unit) /= Null_Iir then + return False; + end if; + return True; + end Is_Top_Entity; + + -- Disp contents design files FILES. + procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List) + is + pragma Unreferenced (Cmd); + + use Ada.Text_IO; + use Name_Table; + Id : Name_Id; + Design_File : Iir_Design_File; + Unit : Iir; + Lib : Iir; + Flag_Add : constant Boolean := False; + begin + Flags.Bootstrap := True; + Libraries.Load_Std_Library; + Libraries.Load_Work_Library; + + for I in Args'Range loop + Id := Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + if Design_File /= Null_Iir then + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + Lib := Get_Library_Unit (Unit); + Disp_Library_Unit (Lib); + if Is_Top_Entity (Lib) then + Put (" **"); + end if; + New_Line; + if Flag_Add then + Libraries.Add_Design_Unit_Into_Library (Unit); + end if; + Unit := Get_Chain (Unit); + end loop; + end if; + end loop; + if Flag_Add then + Libraries.Save_Work_Library; + end if; + end Perform_Action; + + -- Command Import. + type Command_Import is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Import; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Import) return String; + procedure Perform_Action (Cmd : in out Command_Import; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Import; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-i"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Import) return String + is + pragma Unreferenced (Cmd); + begin + return "-i [OPTS] FILEs Import units of FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Import; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + Id : Name_Id; + Design_File : Iir_Design_File; + Unit : Iir; + Next_Unit : Iir; + Lib : Iir; + begin + Setup_Libraries (True); + + -- Parse all files. + for I in Args'Range loop + Id := Name_Table.Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + if Design_File /= Null_Iir then + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + if Flag_Verbose then + Lib := Get_Library_Unit (Unit); + Disp_Library_Unit (Lib); + if Is_Top_Entity (Lib) then + Put (" **"); + end if; + New_Line; + end if; + Next_Unit := Get_Chain (Unit); + Set_Chain (Unit, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Unit); + Unit := Next_Unit; + end loop; + end if; + end loop; + + -- Analyze all files. + if False then + Design_File := Get_Design_File_Chain (Libraries.Work_Library); + while Design_File /= Null_Iir loop + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + case Get_Date (Unit) is + when Date_Valid + | Date_Analyzed => + null; + when Date_Parsed => + Back_End.Finish_Compilation (Unit, False); + when others => + raise Internal_Error; + end case; + Unit := Get_Chain (Unit); + end loop; + Design_File := Get_Chain (Design_File); + end loop; + end if; + + Libraries.Save_Work_Library; + exception + when Errorout.Compilation_Error => + Error ("importation has failed due to compilation error"); + raise; + end Perform_Action; + + -- Command Check_Syntax. + type Command_Check_Syntax is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Check_Syntax; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Check_Syntax) return String; + procedure Perform_Action (Cmd : in out Command_Check_Syntax; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Check_Syntax; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-s"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Check_Syntax) return String + is + pragma Unreferenced (Cmd); + begin + return "-s [OPTS] FILEs Check syntax of FILEs"; + end Get_Short_Help; + + procedure Analyze_One_File (File_Name : String) + is + use Ada.Text_IO; + Id : Name_Id; + Design_File : Iir_Design_File; + Unit : Iir; + Next_Unit : Iir; + begin + Id := Name_Table.Get_Identifier (File_Name); + if Flag_Verbose then + Put (File_Name); + Put_Line (":"); + end if; + Design_File := Libraries.Load_File (Id); + if Design_File = Null_Iir then + raise Errorout.Compilation_Error; + end if; + + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + if Flag_Verbose then + Put (' '); + Disp_Library_Unit (Get_Library_Unit (Unit)); + New_Line; + end if; + -- Sem, canon, annotate a design unit. + Back_End.Finish_Compilation (Unit, True); + + Next_Unit := Get_Chain (Unit); + if Errorout.Nbr_Errors = 0 then + Set_Chain (Unit, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Unit); + end if; + + Unit := Next_Unit; + end loop; + + if Errorout.Nbr_Errors > 0 then + raise Errorout.Compilation_Error; + end if; + end Analyze_One_File; + + procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) is + begin + Setup_Libraries (True); + + -- Parse all files. + for I in Files'Range loop + Analyze_One_File (Files (I).all); + end loop; + + if Save_Library then + Libraries.Save_Work_Library; + end if; + end Analyze_Files; + + procedure Perform_Action (Cmd : in out Command_Check_Syntax; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + Analyze_Files (Args, False); + end Perform_Action; + + -- 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; + procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List); + + function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--clean"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Clean) return String + is + pragma Unreferenced (Cmd); + begin + return "--clean Remove generated files"; + end Get_Short_Help; + + procedure Delete (Str : String) + is + use Ada.Text_IO; + Status : Boolean; + begin + Delete_File (Str'Address, Status); + if Flag_Verbose and Status then + Put_Line ("delete " & Str (Str'First .. Str'Last - 1)); + end if; + end Delete; + + procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Name_Table; + + procedure Delete_Asm_Obj (Str : String) is + begin + Delete (Str & Get_Object_Suffix.all & Nul); + Delete (Str & Asm_Suffix & Nul); + end Delete_Asm_Obj; + + procedure Delete_Top_Unit (Str : String) is + begin + -- Delete elaboration file + Delete_Asm_Obj (Image (Libraries.Work_Directory) & Elab_Prefix & Str); + + -- Delete file list. + Delete (Image (Libraries.Work_Directory) & Str & List_Suffix & Nul); + + -- Delete executable. + Delete (Str & Nul); + end Delete_Top_Unit; + + File : Iir_Design_File; + Design_Unit : Iir_Design_Unit; + Lib_Unit : Iir; + Str : String_Access; + begin + if Args'Length /= 0 then + Error ("command '--clean' does not accept any argument"); + raise Option_Error; + end if; + + Flags.Bootstrap := True; + -- Load libraries. + Libraries.Load_Std_Library; + Libraries.Load_Work_Library; + + File := Get_Design_File_Chain (Libraries.Work_Library); + while File /= Null_Iir loop + -- Delete compiled file. + Str := Append_Suffix (Image (Get_Design_File_Filename (File)), ""); + Delete_Asm_Obj (Str.all); + Free (Str); + + Design_Unit := Get_First_Design_Unit (File); + while Design_Unit /= Null_Iir loop + Lib_Unit := Get_Library_Unit (Design_Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration => + Delete_Top_Unit (Image (Get_Identifier (Lib_Unit))); + when Iir_Kind_Architecture_Body => + Delete_Top_Unit + (Image (Get_Entity_Identifier_Of_Architecture (Lib_Unit)) + & '-' + & Image (Get_Identifier (Lib_Unit))); + when others => + null; + end case; + Design_Unit := Get_Chain (Design_Unit); + end loop; + File := Get_Chain (File); + 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; + function Get_Short_Help (Cmd : Command_Remove) return String; + procedure Perform_Action (Cmd : in out Command_Remove; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Remove; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--remove"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Remove) return String + is + pragma Unreferenced (Cmd); + begin + return "--remove Remove generated files and library file"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Remove; Args : Argument_List) + is + use Name_Table; + begin + if Args'Length /= 0 then + Error ("command '--remove' does not accept any argument"); + raise Option_Error; + end if; + Perform_Action (Command_Clean (Cmd), Args); + Delete (Image (Libraries.Work_Directory) + & Back_End.Library_To_File_Name (Libraries.Work_Library) + & 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) + return Boolean; + function Get_Short_Help (Cmd : Command_Disp_Standard) return String; + procedure Perform_Action (Cmd : in out Command_Disp_Standard; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Disp_Standard; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--disp-standard"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Disp_Standard) return String + is + pragma Unreferenced (Cmd); + begin + return "--disp-standard Disp std.standard in pseudo-vhdl"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Disp_Standard; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + if Args'Length /= 0 then + Error ("command '--disp-standard' does not accept any argument"); + raise Option_Error; + end if; + Flags.Bootstrap := True; + Libraries.Load_Std_Library; + Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit); + end Perform_Action; + + procedure Load_All_Libraries_And_Files + is + use Files_Map; + use Libraries; + use Errorout; + + procedure Extract_Library_Clauses (Unit : Iir_Design_Unit) + is + Lib1 : Iir_Library_Declaration; + pragma Unreferenced (Lib1); + Ctxt_Item : Iir; + begin + -- Extract library clauses. + Ctxt_Item := Get_Context_Items (Unit); + while Ctxt_Item /= Null_Iir loop + if Get_Kind (Ctxt_Item) = Iir_Kind_Library_Clause then + Lib1 := Get_Library (Get_Identifier (Ctxt_Item), + Get_Location (Ctxt_Item)); + end if; + Ctxt_Item := Get_Chain (Ctxt_Item); + end loop; + end Extract_Library_Clauses; + + Lib : Iir_Library_Declaration; + Fe : Source_File_Entry; + File, Next_File : Iir_Design_File; + Unit, Next_Unit : Iir_Design_Unit; + Design_File : Iir_Design_File; + + Old_Work : Iir_Library_Declaration; + begin + Lib := Std_Library; + Lib := Get_Chain (Lib); + Old_Work := Work_Library; + while Lib /= Null_Iir loop + -- Design units are always put in the work library. + Work_Library := Lib; + + File := Get_Design_File_Chain (Lib); + while File /= Null_Iir loop + Next_File := Get_Chain (File); + Fe := Load_Source_File (Get_Design_File_Directory (File), + Get_Design_File_Filename (File)); + if Fe = No_Source_File_Entry then + -- FIXME: should remove all the design file from the library. + null; + elsif Is_Eq (Get_File_Time_Stamp (Fe), + Get_File_Time_Stamp (File)) + then + -- File has not been modified. + -- Extract libraries. + -- Note: we can't parse it only, since we need to keep the + -- date. + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + Load_Parse_Design_Unit (Unit, Null_Iir); + Extract_Library_Clauses (Unit); + Unit := Get_Chain (Unit); + end loop; + else + -- File has been modified. + -- Parse it. + Design_File := Load_File (Fe); + + -- Exit now in case of parse error. + if Design_File = Null_Iir + or else Nbr_Errors > 0 + then + raise Compilation_Error; + end if; + + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + Extract_Library_Clauses (Unit); + + Next_Unit := Get_Chain (Unit); + Set_Chain (Unit, Null_Iir); + Add_Design_Unit_Into_Library (Unit); + Unit := Next_Unit; + end loop; + end if; + File := Next_File; + end loop; + Lib := Get_Chain (Lib); + end loop; + Work_Library := Old_Work; + end Load_All_Libraries_And_Files; + + procedure Check_No_Elab_Flag (Lib : Iir_Library_Declaration) + is + File : Iir_Design_File; + Unit : Iir_Design_Unit; + begin + File := Get_Design_File_Chain (Lib); + while File /= Null_Iir loop + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + if Get_Elab_Flag (Unit) then + raise Internal_Error; + end if; + Unit := Get_Chain (Unit); + end loop; + File := Get_Chain (File); + end loop; + end Check_No_Elab_Flag; + + function Build_Dependence (Prim : String_Access; Sec : String_Access) + return Iir_List + is + procedure Build_Dependence_List (File : Iir_Design_File; List : Iir_List) + is + El : Iir_Design_File; + Depend_List : Iir_List; + begin + if Get_Elab_Flag (File) then + return; + end if; + + Set_Elab_Flag (File, True); + Depend_List := Get_File_Dependence_List (File); + if Depend_List /= Null_Iir_List then + for I in Natural loop + El := Get_Nth_Element (Depend_List, I); + exit when El = Null_Iir; + Build_Dependence_List (El, List); + end loop; + end if; + Append_Element (List, File); + end Build_Dependence_List; + + use Configuration; + use Name_Table; + + Top : Iir; + Primary_Id : Name_Id; + Secondary_Id : Name_Id; + + File : Iir_Design_File; + Unit : Iir; + + Files_List : Iir_List; + begin + Check_No_Elab_Flag (Libraries.Work_Library); + + Primary_Id := Get_Identifier (Prim.all); + if Sec /= null then + Secondary_Id := Get_Identifier (Sec.all); + else + Secondary_Id := Null_Identifier; + end if; + + if True then + Load_All_Libraries_And_Files; + else + -- Re-parse modified files in order configure could find all design + -- units. + declare + use Files_Map; + Fe : Source_File_Entry; + Next_File : Iir_Design_File; + Design_File : Iir_Design_File; + begin + File := Get_Design_File_Chain (Libraries.Work_Library); + while File /= Null_Iir loop + Next_File := Get_Chain (File); + Fe := Load_Source_File (Get_Design_File_Directory (File), + Get_Design_File_Filename (File)); + if Fe = No_Source_File_Entry then + -- FIXME: should remove all the design file from + -- the library. + null; + else + if not Is_Eq (Get_File_Time_Stamp (Fe), + Get_File_Time_Stamp (File)) + then + -- FILE has been modified. + Design_File := Libraries.Load_File (Fe); + if Design_File /= Null_Iir then + Libraries.Add_Design_File_Into_Library (Design_File); + end if; + end if; + end if; + File := Next_File; + end loop; + end; + end if; + + Flags.Flag_Elaborate := True; + Flags.Flag_Elaborate_With_Outdated := True; + Flag_Load_All_Design_Units := True; + Flag_Build_File_Dependence := True; + + Top := Configure (Primary_Id, Secondary_Id); + if Top = Null_Iir then + --Error ("cannot find primary unit " & Prim.all); + raise Option_Error; + end if; + + -- Add unused design units. + declare + N : Natural; + begin + N := Design_Units.First; + while N <= Design_Units.Last loop + Unit := Design_Units.Table (N); + N := N + 1; + File := Get_Design_File (Unit); + if not Get_Elab_Flag (File) then + Set_Elab_Flag (File, True); + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + if not Get_Elab_Flag (Unit) then + Add_Design_Unit (Unit, Null_Iir); + end if; + Unit := Get_Chain (Unit); + end loop; + end if; + end loop; + end; + + -- Clear elab flag on design files. + for I in reverse Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + File := Get_Design_File (Unit); + Set_Elab_Flag (File, False); + end loop; + + -- Create a list of files, from the last to the first. + Files_List := Create_Iir_List; + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + File := Get_Design_File (Unit); + Build_Dependence_List (File, Files_List); + end loop; + + return Files_List; + end Build_Dependence; + + -- Convert NAME to lower cases, unless it is an extended identifier. + function Convert_Name (Name : String_Access) return String_Access + is + use Name_Table; + + function Is_Bad_Unit_Name return Boolean is + begin + if Name_Length = 0 then + return True; + end if; + -- Don't try to handle extended identifier. + if Name_Buffer (1) = '\' then + return False; + end if; + -- Look for suspicious characters. + -- Do not try to be exhaustive as the correct check will be done + -- by convert_identifier. + for I in 1 .. Name_Length loop + case Name_Buffer (I) is + when '.' | '/' | '\' => + return True; + when others => + null; + end case; + end loop; + return False; + end Is_Bad_Unit_Name; + + function Is_A_File_Name return Boolean is + begin + -- Check .vhd + if Name_Length > 4 + and then Name_Buffer (Name_Length - 3 .. Name_Length) = ".vhd" + then + return True; + end if; + -- Check .vhdl + if Name_Length > 5 + and then Name_Buffer (Name_Length - 4 .. Name_Length) = ".vhdl" + then + return True; + end if; + -- Check ../ + if Name_Length > 3 + and then Name_Buffer (1 .. 3) = "../" + then + return True; + end if; + -- Check ..\ + if Name_Length > 3 + and then Name_Buffer (1 .. 3) = "..\" + then + return True; + end if; + -- Should try to find the file ? + return False; + end Is_A_File_Name; + begin + Name_Length := Name'Length; + Name_Buffer (1 .. Name_Length) := Name.all; + + -- Try to identifier bad names (such as file names), so that + -- friendly message can be displayed. + if Is_Bad_Unit_Name then + Errorout.Error_Msg_Option_NR ("bad unit name '" & Name.all & "'"); + if Is_A_File_Name then + Errorout.Error_Msg_Option_NR + ("(a unit name is required instead of a filename)"); + end if; + raise Option_Error; + end if; + Scanner.Convert_Identifier; + return new String'(Name_Buffer (1 .. Name_Length)); + end Convert_Name; + + procedure Extract_Elab_Unit + (Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural) + is + begin + if Args'Length = 0 then + Error ("command '" & Cmd_Name & "' required an unit name"); + raise Option_Error; + end if; + + Prim_Name := Convert_Name (Args (Args'First)); + Next_Arg := Args'First + 1; + Sec_Name := null; + + if Args'Length >= 2 then + declare + Sec : constant String_Access := Args (Next_Arg); + begin + if Sec (Sec'First) /= '-' then + Sec_Name := Convert_Name (Sec); + Next_Arg := Args'First + 2; + end if; + end; + end if; + end Extract_Elab_Unit; + + procedure Register_Commands is + begin + Register_Command (new Command_Import); + Register_Command (new Command_Check_Syntax); + Register_Command (new Command_Dir); + 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/src/translate/ghdldrv/ghdllocal.ads b/src/translate/ghdldrv/ghdllocal.ads new file mode 100644 index 0000000..2c7018a --- /dev/null +++ b/src/translate/ghdldrv/ghdllocal.ads @@ -0,0 +1,116 @@ +-- GHDL driver - local commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Ghdlmain; use Ghdlmain; +with Iirs; use Iirs; + +package Ghdllocal is + type Command_Lib is abstract new Command_Type with null record; + + -- Setup GHDL. + procedure Init (Cmd : in out Command_Lib); + + -- Handle: + -- --std=xx, --work=xx, -Pxxx, --workdir=x, --ieee=x, -Px, and -v + procedure Decode_Option (Cmd : in out Command_Lib; + Option : String; + Arg : String; + Res : out Option_Res); + + -- Disp detailled help. + procedure Disp_Long_Help (Cmd : Command_Lib); + + -- Value of --PREFIX + Switch_Prefix_Path : String_Access := null; + + -- getenv ("GHDL_PREFIX"). Set by Setup_Libraries. + Prefix_Env : String_Access := null; + + -- Installation prefix (deduced from executable path). + Exec_Prefix : String_Access; + + -- Path prefix for libraries. + Lib_Prefix_Path : String_Access := null; + + -- Set with -v option. + Flag_Verbose : Boolean := False; + + -- Suffix for asm files. + Asm_Suffix : constant String := ".s"; + + -- Suffix for llvm byte-code files. + Llvm_Suffix : constant String := ".bc"; + + -- Suffix for post files. + Post_Suffix : constant String := ".on"; + + -- Suffix for list files. + List_Suffix : constant String := ".lst"; + + -- Prefix for elab files. + Elab_Prefix : constant String := "e~"; + + Nul : constant Character := Character'Val (0); + + -- Return FILENAME without the extension. + function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True) + return String; + + -- Get the position of the last directory separator or 0 if none. + function Get_Basename_Pos (Pathname : String) return Natural; + + function Append_Suffix (File : String; Suffix : String) + return String_Access; + + -- Return TRUE is UNIT can be at the apex of a design hierarchy. + function Is_Top_Entity (Unit : Iir) return Boolean; + + -- Display the name of library unit UNIT. + procedure Disp_Library_Unit (Unit : Iir); + + -- Translate vhdl version into a path element. + -- Used to search Std and IEEE libraries. + function Get_Version_Path return String; + + -- Get Prefix_Path, but with 32 added if -m32 is requested + function Get_Machine_Path_Prefix return String; + + -- Setup standard libaries path. If LOAD is true, then load them now. + procedure Setup_Libraries (Load : Boolean); + + -- Setup library, analyze FILES, and if SAVE_LIBRARY is set save the + -- work library only + procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean); + + -- Load and parse all libraries and files, starting from the work library. + -- The work library must already be loaded. + -- Raise errorout.compilation_error in case of error (parse error). + procedure Load_All_Libraries_And_Files; + + function Build_Dependence (Prim : String_Access; Sec : String_Access) + return Iir_List; + + Prim_Name : String_Access; + Sec_Name : String_Access; + + -- Set PRIM_NAME and SEC_NAME. + procedure Extract_Elab_Unit + (Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural); + + procedure Register_Commands; +end Ghdllocal; diff --git a/src/translate/ghdldrv/ghdlmain.adb b/src/translate/ghdldrv/ghdlmain.adb new file mode 100644 index 0000000..45d9615 --- /dev/null +++ b/src/translate/ghdldrv/ghdlmain.adb @@ -0,0 +1,359 @@ +-- GHDL driver - main part. +-- 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 +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Text_IO; +with Ada.Command_Line; +with Version; +with Bug; +with Options; + +package body Ghdlmain is + procedure Init (Cmd : in out Command_Type) + is + pragma Unreferenced (Cmd); + begin + null; + end Init; + + procedure Decode_Option (Cmd : in out Command_Type; + Option : String; + Arg : String; + Res : out Option_Res) + is + pragma Unreferenced (Cmd); + pragma Unreferenced (Option); + pragma Unreferenced (Arg); + begin + Res := Option_Bad; + end Decode_Option; + + procedure Disp_Long_Help (Cmd : Command_Type) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + begin + Put_Line ("This command does not accept options."); + end Disp_Long_Help; + + First_Cmd : Command_Acc := null; + Last_Cmd : Command_Acc := null; + + procedure Register_Command (Cmd : Command_Acc) is + begin + if First_Cmd = null then + First_Cmd := Cmd; + else + Last_Cmd.Next := Cmd; + end if; + Last_Cmd := Cmd; + end Register_Command; + + -- Find the command. + function Find_Command (Action : String) return Command_Acc + is + Cmd : Command_Acc; + begin + Cmd := First_Cmd; + while Cmd /= null loop + if Decode_Command (Cmd.all, Action) then + return Cmd; + end if; + Cmd := Cmd.Next; + end loop; + return null; + end Find_Command; + + -- Command help. + type Command_Help is new Command_Type with null record; + function Decode_Command (Cmd : Command_Help; Name : String) return Boolean; + procedure Decode_Option (Cmd : in out Command_Help; + Option : String; + Arg : String; + Res : out Option_Res); + + function Get_Short_Help (Cmd : Command_Help) return String; + procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List); + + function Decode_Command (Cmd : Command_Help; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-h" or else Name = "--help"; + end Decode_Command; + + procedure Decode_Option (Cmd : in out Command_Help; + Option : String; + Arg : String; + Res : out Option_Res) + is + pragma Unreferenced (Cmd); + pragma Unreferenced (Option); + pragma Unreferenced (Arg); + begin + Res := Option_End; + end Decode_Option; + + function Get_Short_Help (Cmd : Command_Help) return String + is + pragma Unreferenced (Cmd); + begin + return "-h or --help [CMD] Disp this help or [help on CMD]"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List) + is + pragma Unreferenced (Cmd); + + use Ada.Text_IO; + use Ada.Command_Line; + C : Command_Acc; + begin + if Args'Length = 0 then + Put_Line ("usage: " & Command_Name & " COMMAND [OPTIONS] ..."); + Put_Line ("COMMAND is one of:"); + C := First_Cmd; + while C /= null loop + Put_Line (Get_Short_Help (C.all)); + C := C.Next; + end loop; + New_Line; + Put_Line ("To display the options of a GHDL program,"); + Put_Line (" run your program with the --help option."); + Put_Line ("Also see --options-help for analyzer options."); + New_Line; + Put_Line ("Please, refer to the GHDL manual for more information."); + Put_Line ("Report bugs on http://gna.org/projects/ghdl"); + elsif Args'Length = 1 then + C := Find_Command (Args (1).all); + if C = null then + Error ("Command '" & Args (1).all & "' is unknown."); + raise Option_Error; + end if; + Put_Line (Get_Short_Help (C.all)); + Disp_Long_Help (C.all); + else + Error ("Command '--help' accepts at most one argument."); + raise Option_Error; + end if; + end Perform_Action; + + -- Command options help. + type Command_Option_Help is new Command_Type with null record; + function Decode_Command (Cmd : Command_Option_Help; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Option_Help) return String; + procedure Perform_Action (Cmd : in out Command_Option_Help; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Option_Help; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--options-help"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Option_Help) return String + is + pragma Unreferenced (Cmd); + begin + return "--options-help Disp help for analyzer options"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Option_Help; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + if Args'Length /= 0 then + Error + ("warning: command '--option-help' does not accept any argument"); + end if; + Options.Disp_Options_Help; + end Perform_Action; + + -- Command Version + type Command_Version is new Command_Type with null record; + function Decode_Command (Cmd : Command_Version; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Version) return String; + procedure Perform_Action (Cmd : in out Command_Version; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Version; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-v" or Name = "--version"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Version) return String + is + pragma Unreferenced (Cmd); + begin + return "-v or --version Disp ghdl version"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Version; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + begin + Put_Line (Version.Ghdl_Release); + Put_Line (" Compiled with " & Bug.Get_Gnat_Version); + if Version_String /= null then + Put (" "); + Put (Version_String.all); + end if; + New_Line; + Put_Line ("Written by Tristan Gingold."); + New_Line; + -- Display copyright. Assume 80 cols terminal. + Put_Line ("Copyright (C) 2003 - 2014 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" + & " FITNESS FOR A PARTICULAR PURPOSE."); + if Args'Length /= 0 then + Error ("warning: command '--version' does not accept any argument"); + end if; + end Perform_Action; + + -- Disp MSG on the standard output with the command name. + procedure Error (Msg : String) + is + use Ada.Command_Line; + use Ada.Text_IO; + begin + Put (Standard_Error, Command_Name); + Put (Standard_Error, ": "); + Put_Line (Standard_Error, Msg); + --Has_Error := True; + end Error; + + procedure Main + is + use Ada.Command_Line; + Cmd : Command_Acc; + Arg_Index : Natural; + First_Arg : Natural; + + begin + if Argument_Count = 0 then + Error ("missing command, try " & Command_Name & " --help"); + raise Option_Error; + end if; + + Cmd := Find_Command (Argument (1)); + if Cmd = null then + Error ("unknown command '" & Argument (1) & "', try --help"); + raise Option_Error; + end if; + + Init (Cmd.all); + + -- decode options. + + First_Arg := 0; + Arg_Index := 2; + while Arg_Index <= Argument_Count loop + declare + Arg : constant String := Argument (Arg_Index); + Res : Option_Res; + begin + if Arg (1) = '-' then + -- Argument is an option. + + if First_Arg > 0 then + Error ("options after file"); + raise Option_Error; + end if; + + Decode_Option (Cmd.all, Arg, "", Res); + case Res is + when Option_Bad => + Error ("unknown option '" & Arg & "' for command '" + & Argument (1) & "'"); + raise Option_Error; + when Option_Ok => + Arg_Index := Arg_Index + 1; + when Option_Arg_Req => + if Arg_Index + 1 > Argument_Count then + Error ("option '" & Arg & "' requires an argument"); + raise Option_Error; + end if; + Decode_Option + (Cmd.all, Arg, Argument (Arg_Index + 1), Res); + if Res /= Option_Arg then + raise Program_Error; + end if; + Arg_Index := Arg_Index + 2; + when Option_Arg => + raise Program_Error; + when Option_End => + First_Arg := Arg_Index; + exit; + end case; + else + First_Arg := Arg_Index; + exit; + end if; + end; + end loop; + + if First_Arg = 0 then + First_Arg := Argument_Count + 1; + end if; + + declare + Args : Argument_List (1 .. Argument_Count - First_Arg + 1); + begin + for I in Args'Range loop + Args (I) := new String'(Argument (First_Arg + I - 1)); + end loop; + Perform_Action (Cmd.all, Args); + for I in Args'Range loop + Free (Args (I)); + end loop; + end; + --if Flags.Dump_Stats then + -- Name_Table.Disp_Stats; + -- Iirs.Disp_Stats; + --end if; + Set_Exit_Status (Success); + exception + when Option_Error + | Compile_Error + | Errorout.Compilation_Error => + Set_Exit_Status (Failure); + when Exec_Error => + Set_Exit_Status (3); + when E: others => + Bug.Disp_Bug_Box (E); + Set_Exit_Status (2); + end Main; + + procedure Register_Commands is + begin + Register_Command (new Command_Help); + Register_Command (new Command_Version); + Register_Command (new Command_Option_Help); + end Register_Commands; +end Ghdlmain; + diff --git a/src/translate/ghdldrv/ghdlmain.ads b/src/translate/ghdldrv/ghdlmain.ads new file mode 100644 index 0000000..c01f1d6 --- /dev/null +++ b/src/translate/ghdldrv/ghdlmain.ads @@ -0,0 +1,85 @@ +-- GHDL driver - main part. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Errorout; + +package Ghdlmain is + type Command_Type; + + type Command_Acc is access all Command_Type'Class; + + type Command_Type is abstract tagged record + Next : Command_Acc; + end record; + + -- Return TRUE iff CMD handle action ACTION. + function Decode_Command (Cmd : Command_Type; Name : String) return Boolean + is abstract; + + -- Initialize the command, before decoding actions. + procedure Init (Cmd : in out Command_Type); + + -- Option_OK: OPTION is handled. + -- Option_Bad: OPTION is unknown. + -- Option_Arg_Req: OPTION requires an argument. Must be set only when + -- ARG = "", the manager will recall Decode_Option. + -- Option_Arg: OPTION used the argument. + type Option_Res is + (Option_Bad, Option_Ok, Option_Arg, Option_Arg_Req, Option_End); + procedure Decode_Option (Cmd : in out Command_Type; + Option : String; + Arg : String; + Res : out Option_Res); + + -- Get a one-line help for the command. + function Get_Short_Help (Cmd : Command_Type) return String + is abstract; + + -- Disp detailled help. + procedure Disp_Long_Help (Cmd : Command_Type); + + -- Perform the action. + procedure Perform_Action (Cmd : in out Command_Type; Args : Argument_List) + is abstract; + + -- Register a command. + procedure Register_Command (Cmd : Command_Acc); + + -- Disp MSG on the standard output with the command name. + procedure Error (Msg : String); + + -- May be raise by perform_action if the arguments are bad. + Option_Error : exception renames Errorout.Option_Error; + + -- Action failed. + Compile_Error : exception; + + -- Exec failed: either the program was not found, or failed. + Exec_Error : exception; + + procedure Main; + + -- Additionnal one-line message displayed by the --version command, + -- if defined. + -- Used to customize. + type String_Cst_Acc is access constant String; + Version_String : String_Cst_Acc := null; + + -- Registers all commands in this package. + procedure Register_Commands; +end Ghdlmain; diff --git a/src/translate/ghdldrv/ghdlprint.adb b/src/translate/ghdldrv/ghdlprint.adb new file mode 100644 index 0000000..45e70e1 --- /dev/null +++ b/src/translate/ghdldrv/ghdlprint.adb @@ -0,0 +1,1757 @@ +-- GHDL driver - print commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Characters.Latin_1; +with Ada.Text_IO; use Ada.Text_IO; +with GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Table; +with Types; use Types; +with Flags; +with Name_Table; use Name_Table; +with Files_Map; +with Libraries; +with Errorout; use Errorout; +with Iirs; use Iirs; +with Iirs_Utils; use Iirs_Utils; +with Tokens; +with Scanner; +with Parse; +with Version; +with Xrefs; +with Ghdlmain; use Ghdlmain; +with Ghdllocal; use Ghdllocal; +with Disp_Vhdl; +with Back_End; + +package body Ghdlprint is + type Html_Format_Type is (Html_2, Html_Css); + Html_Format : Html_Format_Type := Html_2; + + procedure Put_Html (C : Character) is + begin + case C is + when '>' => + Put (">"); + when '<' => + Put ("<"); + when '&' => + Put ("&"); + when others => + Put (C); + end case; + end Put_Html; + + procedure Put_Html (S : String) is + begin + for I in S'Range loop + Put_Html (S (I)); + end loop; + end Put_Html; + + package Nat_IO is new Ada.Text_IO.Integer_IO (Num => Natural); + procedure Put_Nat (N : Natural) is + begin + Nat_IO.Put (N, Width => 0); + end Put_Nat; + + type Filexref_Info_Type is record + Output : String_Acc; + Referenced : Boolean; + end record; + type Filexref_Info_Arr is array (Source_File_Entry range <>) + of Filexref_Info_Type; + type Filexref_Info_Arr_Acc is access Filexref_Info_Arr; + Filexref_Info : Filexref_Info_Arr_Acc := null; + + -- If True, at least one xref is missing. + Missing_Xref : Boolean := False; + + procedure PP_Html_File (File : Source_File_Entry) + is + use Flags; + use Scanner; + use Tokens; + use Files_Map; + use Ada.Characters.Latin_1; + + Line : Natural; + Buf : File_Buffer_Acc; + Prev_Tok : Token_Type; + + -- Current logical column number. Used to expand TABs. + Col : Natural; + + -- Position just after the last token. + Last_Tok : Source_Ptr; + + -- Position just before the current token. + Bef_Tok : Source_Ptr; + + -- Position just after the current token. + Aft_Tok : Source_Ptr; + + procedure Disp_Ln + is + N : Natural; + Str : String (1 .. 5); + begin + case Html_Format is + when Html_2 => + Put ("<font size=-1>"); + when Html_Css => + Put ("<i>"); + end case; + N := Line; + for I in reverse Str'Range loop + if N = 0 then + Str (I) := ' '; + else + Str (I) := Character'Val (48 + N mod 10); + N := N / 10; + end if; + end loop; + Put (Str); + case Html_Format is + when Html_2 => + Put ("</font>"); + when Html_Css => + Put ("</i>"); + end case; + Put (" "); + Col := 0; + end Disp_Ln; + + procedure Disp_Spaces + is + C : Character; + P : Source_Ptr; + N_Col : Natural; + begin + P := Last_Tok; + while P < Bef_Tok loop + C := Buf (P); + if C = HT then + -- Expand TABS. + N_Col := Col + 8; + N_Col := N_Col - N_Col mod 8; + while Col < N_Col loop + Put (' '); + Col := Col + 1; + end loop; + else + Put (' '); + Col := Col + 1; + end if; + P := P + 1; + end loop; + end Disp_Spaces; + + procedure Disp_Text + is + P : Source_Ptr; + begin + P := Bef_Tok; + while P < Aft_Tok loop + Put_Html (Buf (P)); + Col := Col + 1; + P := P + 1; + end loop; + end Disp_Text; + + procedure Disp_Reserved is + begin + Disp_Spaces; + case Html_Format is + when Html_2 => + Put ("<font color=red>"); + Disp_Text; + Put ("</font>"); + when Html_Css => + Put ("<em>"); + Disp_Text; + Put ("</em>"); + end case; + end Disp_Reserved; + + procedure Disp_Href (Loc : Location_Type) + is + L_File : Source_File_Entry; + L_Pos : Source_Ptr; + begin + Location_To_File_Pos (Loc, L_File, L_Pos); + Put (" href="""); + if L_File /= File then + -- External reference. + if Filexref_Info (L_File).Output /= null then + Put (Filexref_Info (L_File).Output.all); + Put ("#"); + Put_Nat (Natural (L_Pos)); + else + -- Reference to an unused file. + Put ("index.html#f"); + Put_Nat (Natural (L_File)); + Filexref_Info (L_File).Referenced := True; + end if; + else + -- Local reference. + Put ("#"); + Put_Nat (Natural (L_Pos)); + end if; + Put (""""); + end Disp_Href; + + procedure Disp_Anchor (Loc : Location_Type) + is + L_File : Source_File_Entry; + L_Pos : Source_Ptr; + begin + Put (" name="""); + Location_To_File_Pos (Loc, L_File, L_Pos); + Put_Nat (Natural (L_Pos)); + Put (""""); + end Disp_Anchor; + + procedure Disp_Identifier + is + use Xrefs; + Ref : Xref; + Decl : Iir; + Bod : Iir; + Loc : Location_Type; + begin + Disp_Spaces; + if Flags.Flag_Xref then + Loc := File_Pos_To_Location (File, Bef_Tok); + Ref := Find (Loc); + if Ref = Bad_Xref then + Disp_Text; + Warning_Msg_Sem ("cannot find xref", Loc); + Missing_Xref := True; + return; + end if; + else + Disp_Text; + return; + end if; + case Get_Xref_Kind (Ref) is + when Xref_Decl => + Put ("<a"); + Disp_Anchor (Loc); + Decl := Get_Xref_Node (Ref); + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Bod := Get_Subprogram_Body (Decl); + when Iir_Kind_Package_Declaration => + Bod := Get_Package_Body (Decl); + when Iir_Kind_Type_Declaration => + Decl := Get_Type (Decl); + case Get_Kind (Decl) is + when Iir_Kind_Protected_Type_Declaration => + Bod := Get_Protected_Type_Body (Decl); + when Iir_Kind_Incomplete_Type_Definition => + Bod := Get_Type_Declarator (Decl); + when others => + Bod := Null_Iir; + end case; + when others => + Bod := Null_Iir; + end case; + if Bod /= Null_Iir then + Disp_Href (Get_Location (Bod)); + end if; + Put (">"); + Disp_Text; + Put ("</a>"); + when Xref_Ref + | Xref_End => + Decl := Get_Xref_Node (Ref); + Loc := Get_Location (Decl); + if Loc /= Location_Nil then + Put ("<a"); + Disp_Href (Loc); + Put (">"); + Disp_Text; + Put ("</a>"); + else + -- This may happen for overload list, in use clauses. + Disp_Text; + end if; + when Xref_Body => + Put ("<a"); + Disp_Anchor (Loc); + Disp_Href (Get_Location (Get_Xref_Node (Ref))); + Put (">"); + Disp_Text; + Put ("</a>"); + end case; + end Disp_Identifier; + + procedure Disp_Attribute + is + use Xrefs; + Ref : Xref; + Decl : Iir; + Loc : Location_Type; + begin + Disp_Spaces; + if Flags.Flag_Xref then + Loc := File_Pos_To_Location (File, Bef_Tok); + Ref := Find (Loc); + else + Ref := Bad_Xref; + end if; + if Ref = Bad_Xref then + case Html_Format is + when Html_2 => + Put ("<font color=orange>"); + Disp_Text; + Put ("</font>"); + when Html_Css => + Put ("<var>"); + Disp_Text; + Put ("</var>"); + end case; + else + Decl := Get_Xref_Node (Ref); + Loc := Get_Location (Decl); + Put ("<a"); + Disp_Href (Loc); + Put (">"); + Disp_Text; + Put ("</a>"); + end if; + end Disp_Attribute; + begin + Scanner.Flag_Comment := True; + Scanner.Flag_Newline := True; + + Set_File (File); + Buf := Get_File_Source (File); + + Put_Line ("<pre>"); + Line := 1; + Disp_Ln; + Last_Tok := Source_Ptr_Org; + Prev_Tok := Tok_Invalid; + loop + Scan; + Bef_Tok := Get_Token_Position; + Aft_Tok := Get_Position; + case Current_Token is + when Tok_Eof => + exit; + when Tok_Newline => + New_Line; + Line := Line + 1; + Disp_Ln; + when Tok_Comment => + Disp_Spaces; + case Html_Format is + when Html_2 => + Put ("<font color=green>"); + Disp_Text; + Put ("</font>"); + when Html_Css => + Put ("<tt>"); + Disp_Text; + Put ("</tt>"); + end case; + when Tok_Access .. Tok_Elsif + | Tok_Entity .. Tok_With + | Tok_Mod .. Tok_Rem + | Tok_And .. Tok_Not => + Disp_Reserved; + when Tok_End => + Disp_Reserved; + when Tok_Semi_Colon => + Disp_Spaces; + Disp_Text; + when Tok_Xnor .. Tok_Ror => + Disp_Reserved; + when Tok_Protected => + Disp_Reserved; + when Tok_Across .. Tok_Tolerance => + Disp_Reserved; + when Tok_Psl_Default + | Tok_Psl_Clock + | Tok_Psl_Property + | Tok_Psl_Sequence + | Tok_Psl_Endpoint + | Tok_Psl_Assert + | Tok_Psl_Cover + | 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 => + Disp_Spaces; + case Html_Format is + when Html_2 => + Put ("<font color=blue>"); + Disp_Text; + Put ("</font>"); + when Html_Css => + Put ("<kbd>"); + Disp_Text; + Put ("</kbd>"); + end case; + when Tok_Identifier => + if Prev_Tok = Tok_Tick then + Disp_Attribute; + else + Disp_Identifier; + end if; + when Tok_Left_Paren .. Tok_Colon + | Tok_Comma .. Tok_Dot + | Tok_Equal_Equal + | Tok_Integer + | Tok_Real + | Tok_Equal .. Tok_Slash + | Tok_Invalid => + Disp_Spaces; + Disp_Text; + end case; + Last_Tok := Aft_Tok; + Prev_Tok := Current_Token; + end loop; + Close_File; + New_Line; + Put_Line ("</pre>"); + Put_Line ("<hr/>"); + end PP_Html_File; + + procedure Put_Html_Header + is + begin + Put ("<html>"); + Put_Line (" <head>"); + case Html_Format is + when Html_2 => + null; + when Html_Css => + Put_Line (" <link rel=stylesheet type=""text/css"""); + Put_Line (" href=""ghdl.css"" title=""default""/>"); + end case; + --Put_Line ("<?xml version=""1.0"" encoding=""utf-8"" ?>"); + --Put_Line("<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.0 Strict//EN"""); + --Put_Line ("""http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"">"); + --Put_Line ("<html xmlns=""http://www.w3.org/1999/xhtml""" + -- & " xml:lang=""en"">"); + --Put_Line ("<head>"); + end Put_Html_Header; + + procedure Put_Css is + begin + Put_Line ("/* EM is used for reserved words */"); + Put_Line ("EM { color : red; font-style: normal }"); + New_Line; + Put_Line ("/* TT is used for comments */"); + Put_Line ("TT { color : green; font-style: normal }"); + New_Line; + Put_Line ("/* KBD is used for literals and strings */"); + Put_Line ("KBD { color : blue; font-style: normal }"); + New_Line; + Put_Line ("/* I is used for line numbers */"); + Put_Line ("I { color : gray; font-size: 50% }"); + New_Line; + Put_Line ("/* VAR is used for attributes name */"); + Put_Line ("VAR { color : orange; font-style: normal }"); + New_Line; + Put_Line ("/* A is used for identifiers. */"); + Put_Line ("A { color: blue; font-style: normal;"); + Put_Line (" text-decoration: none }"); + end Put_Css; + + procedure Put_Html_Foot + is + begin + Put_Line ("<p>"); + Put ("<small>This page was generated using "); + Put ("<a href=""http://ghdl.free.fr"">"); + Put (Version.Ghdl_Release); + Put ("</a>, a program written by"); + Put (" Tristan Gingold"); + New_Line; + Put_Line ("</p>"); + Put_Line ("</body>"); + Put_Line ("</html>"); + end Put_Html_Foot; + + function Create_Output_Filename (Name : String; Num : Natural) + return String_Acc + is + -- Position of the extension. 0 if none. + Ext_Pos : Natural; + + Num_Str : String := Natural'Image (Num); + begin + -- Search for the extension. + Ext_Pos := 0; + for I in reverse Name'Range loop + exit when Name (I) = Directory_Separator; + if Name (I) = '.' then + Ext_Pos := I - 1; + exit; + end if; + end loop; + if Ext_Pos = 0 then + Ext_Pos := Name'Last; + end if; + Num_Str (1) := '.'; + return new String'(Name (Name'First .. Ext_Pos) & Num_Str & ".html"); + end Create_Output_Filename; + + -- Command --chop. + type Command_Chop is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Chop; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Chop) return String; + procedure Perform_Action (Cmd : in out Command_Chop; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Chop; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--chop"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Chop) return String + is + pragma Unreferenced (Cmd); + begin + return "--chop [OPTS] FILEs Chop FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Chop; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Ada.Characters.Latin_1; + + function Build_File_Name_Length (Lib : Iir) return Natural + is + Id : constant Name_Id := Get_Identifier (Lib); + Len : Natural; + Id1 : Name_Id; + begin + Len := Get_Name_Length (Id); + case Get_Kind (Lib) is + when Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + null; + when Iir_Kind_Package_Body => + Len := Len + 1 + 4; -- add -body + when Iir_Kind_Architecture_Body => + Id1 := Get_Entity_Identifier_Of_Architecture (Lib); + Len := Len + 1 + Get_Name_Length (Id1); + when others => + Error_Kind ("build_file_name", Lib); + end case; + Len := Len + 1 + 4; -- add .vhdl + return Len; + end Build_File_Name_Length; + + procedure Build_File_Name (Lib : Iir; Res : out String) + is + Id : constant Name_Id := Get_Identifier (Lib); + P : Natural; + + procedure Append (Str : String) is + begin + Res (P + 1 .. P + Str'Length) := Str; + P := P + Str'Length; + end Append; + begin + P := Res'First - 1; + case Get_Kind (Lib) is + when Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + Image (Id); + Append (Name_Buffer (1 .. Name_Length)); + when Iir_Kind_Package_Body => + Image (Id); + Append (Name_Buffer (1 .. Name_Length)); + Append ("-body"); + when Iir_Kind_Architecture_Body => + Image (Get_Entity_Identifier_Of_Architecture (Lib)); + Append (Name_Buffer (1 .. Name_Length)); + Append ("-"); + Image (Id); + Append (Name_Buffer (1 .. Name_Length)); + when others => + raise Internal_Error; + end case; + Append (".vhdl"); + end Build_File_Name; + + -- Scan source file BUF+START until end of line. + -- Return line kind to KIND and position of next line to NEXT. + type Line_Type is (Line_Blank, Line_Comment, Line_Text); + procedure Find_Eol (Buf : File_Buffer_Acc; + Start : Source_Ptr; + Next : out Source_Ptr; + Kind : out Line_Type) + is + P : Source_Ptr; + begin + P := Start; + + Kind := Line_Blank; + + -- Skip blanks. + while Buf (P) = ' ' or Buf (P) = HT loop + P := P + 1; + end loop; + + -- Skip comment if any. + if Buf (P) = '-' and Buf (P + 1) = '-' then + Kind := Line_Comment; + P := P + 2; + elsif Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT then + Kind := Line_Text; + end if; + + -- Skip until end of line. + while Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT loop + P := P + 1; + end loop; + + if Buf (P) = CR then + P := P + 1; + if Buf (P) = LF then + P := P + 1; + end if; + elsif Buf (P) = LF then + P := P + 1; + if Buf (P) = CR then + P := P + 1; + end if; + end if; + + Next := P; + end Find_Eol; + + Id : Name_Id; + Design_File : Iir_Design_File; + Unit : Iir; + Lib : Iir; + Len : Natural; + begin + Flags.Bootstrap := True; + -- Load word library. + Libraries.Load_Std_Library; + Libraries.Load_Work_Library; + + -- First loop: parse source file, check destination file does not + -- exist. + for I in Args'Range loop + Id := Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + if Design_File = Null_Iir then + raise Compile_Error; + end if; + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + Lib := Get_Library_Unit (Unit); + Len := Build_File_Name_Length (Lib); + declare + Filename : String (1 .. Len + 1); + begin + Build_File_Name (Lib, Filename); + Filename (Len + 1) := Ghdllocal.Nul; + if Is_Regular_File (Filename) then + Error ("file '" & Filename (1 .. Len) & "' already exists"); + raise Compile_Error; + end if; + Put (Filename (1 .. Len)); + Put (" (for "); + Disp_Library_Unit (Lib); + Put (")"); + New_Line; + end; + Unit := Get_Chain (Unit); + end loop; + end loop; + + -- Second loop: do the real work. + for I in Args'Range loop + Id := Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + Unit := Get_First_Design_Unit (Design_File); + declare + use Files_Map; + + File_Entry : Source_File_Entry; + Buffer : File_Buffer_Acc; + + Start : Source_Ptr; + Lend : Source_Ptr; + First : Source_Ptr; + Next : Source_Ptr; + Kind : Line_Type; + begin + -- A design_file must have at least one design unit. + if Unit = Null_Iir then + raise Compile_Error; + end if; + + Location_To_File_Pos + (Get_Location (Unit), File_Entry, Start); + Buffer := Get_File_Source (File_Entry); + + First := Source_Ptr_Org; + if Get_Chain (Unit) /= Null_Iir then + -- If there is only one unit, then the whole file is written. + -- First last blank line. + Next := Source_Ptr_Org; + loop + Start := Next; + Find_Eol (Buffer, Start, Next, Kind); + exit when Kind = Line_Text; + if Kind = Line_Blank then + First := Next; + end if; + end loop; + + -- FIXME: write header. + end if; + + while Unit /= Null_Iir loop + Lib := Get_Library_Unit (Unit); + + Location_To_File_Pos + (Get_End_Location (Unit), File_Entry, Lend); + if Lend < First then + raise Internal_Error; + end if; + + Location_To_File_Pos + (Get_End_Location (Unit), File_Entry, Lend); + -- Find the ';'. + while Buffer (Lend) /= ';' loop + Lend := Lend + 1; + end loop; + Lend := Lend + 1; + -- Find end of line. + Find_Eol (Buffer, Lend, Next, Kind); + if Kind = Line_Text then + -- There is another unit on the same line. + Next := Lend; + -- Skip blanks. + while Buffer (Next) = ' ' or Buffer (Next) = HT loop + Next := Next + 1; + end loop; + else + -- Find first blank line. + loop + Start := Next; + Find_Eol (Buffer, Start, Next, Kind); + exit when Kind /= Line_Comment; + end loop; + if Kind = Line_Text then + -- There is not blank lines. + -- All the comments are supposed to belong to the next + -- unit. + Find_Eol (Buffer, Lend, Next, Kind); + Lend := Next; + else + Lend := Start; + end if; + end if; + + if Get_Chain (Unit) = Null_Iir then + -- Last unit. + -- Put the end of the file in it. + Lend := Get_File_Length (File_Entry); + end if; + + -- FIXME: file with only one unit. + -- FIXME: set extension. + Len := Build_File_Name_Length (Lib); + declare + Filename : String (1 .. Len + 1); + Fd : File_Descriptor; + + Wlen : Integer; + begin + Build_File_Name (Lib, Filename); + Filename (Len + 1) := Character'Val (0); + Fd := Create_File (Filename, Binary); + if Fd = Invalid_FD then + Error + ("cannot create file '" & Filename (1 .. Len) & "'"); + raise Compile_Error; + end if; + Wlen := Integer (Lend - First); + if Write (Fd, Buffer (First)'Address, Wlen) /= Wlen then + Error ("cannot write to '" & Filename (1 .. Len) & "'"); + raise Compile_Error; + end if; + Close (Fd); + end; + First := Next; + + Unit := Get_Chain (Unit); + end loop; + end; + end loop; + end Perform_Action; + + -- Command --lines. + type Command_Lines is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Lines; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Lines) return String; + procedure Perform_Action (Cmd : in out Command_Lines; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Lines; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--lines"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Lines) return String + is + pragma Unreferenced (Cmd); + begin + return "--lines FILEs Precede line with its number"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Lines; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Scanner; + use Tokens; + use Files_Map; + use Ada.Characters.Latin_1; + + Id : Name_Id; + Fe : Source_File_Entry; + Local_Id : Name_Id; + Line : Natural; + File : Source_File_Entry; + Buf : File_Buffer_Acc; + Ptr : Source_Ptr; + Eptr : Source_Ptr; + C : Character; + N : Natural; + Log : Natural; + Str : String (1 .. 10); + begin + Local_Id := Get_Identifier (""); + for I in Args'Range loop + -- Load the file. + Id := Get_Identifier (Args (I).all); + Fe := Files_Map.Load_Source_File (Local_Id, Id); + if Fe = No_Source_File_Entry then + Error ("cannot open file " & Args (I).all); + raise Compile_Error; + end if; + Set_File (Fe); + + -- Scan the content, to compute the number of lines. + loop + Scan; + exit when Current_Token = Tok_Eof; + end loop; + File := Get_Current_Source_File; + Line := Get_Current_Line; + Close_File; + + -- Compute log10 of line. + N := Line; + Log := 0; + loop + N := N / 10; + Log := Log + 1; + exit when N = 0; + end loop; + + -- Disp file name. + Put (Args (I).all); + Put (':'); + New_Line; + + Buf := Get_File_Source (File); + for J in 1 .. Line loop + Ptr := Line_To_Position (File, J); + exit when Ptr = Source_Ptr_Bad; + exit when Buf (Ptr) = Files_Map.EOT; + + -- Disp line number. + N := J; + for K in reverse 1 .. Log loop + if N = 0 then + Str (K) := ' '; + else + Str (K) := Character'Val (48 + N mod 10); + N := N / 10; + end if; + end loop; + Put (Str (1 .. Log)); + Put (": "); + + -- Search for end of line (or end of file). + Eptr := Ptr; + loop + C := Buf (Eptr); + exit when C = Files_Map.EOT or C = LF or C = CR; + Eptr := Eptr + 1; + end loop; + + -- Disp line. + if Eptr > Ptr then + -- Avoid constraint error on conversion of nul array. + Put (String (Buf (Ptr .. Eptr - 1))); + end if; + New_Line; + end loop; + end loop; + end Perform_Action; + + -- Command Reprint. + type Command_Reprint is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Reprint; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Reprint) return String; + procedure Perform_Action (Cmd : in out Command_Reprint; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Reprint; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--reprint"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Reprint) return String + is + pragma Unreferenced (Cmd); + begin + return "--reprint [OPTS] FILEs Redisplay FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Reprint; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Design_File : Iir_Design_File; + Unit : Iir; + + Id : Name_Id; + Next_Unit : Iir; + begin + Setup_Libraries (True); + Parse.Flag_Parse_Parenthesis := True; + + -- Parse all files. + for I in Args'Range loop + Id := Name_Table.Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + if Design_File = Null_Iir then + raise Errorout.Compilation_Error; + end if; + + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + -- Analyze the design unit. + Back_End.Finish_Compilation (Unit, True); + + Next_Unit := Get_Chain (Unit); + if Errorout.Nbr_Errors = 0 then + Disp_Vhdl.Disp_Vhdl (Unit); + Set_Chain (Unit, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Unit); + end if; + + Unit := Next_Unit; + end loop; + + if Errorout.Nbr_Errors > 0 then + raise Errorout.Compilation_Error; + end if; + end loop; + end Perform_Action; + + -- Command compare tokens. + type Command_Compare_Tokens is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Compare_Tokens) return String; + procedure Perform_Action (Cmd : in out Command_Compare_Tokens; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--compare-tokens"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Compare_Tokens) return String + is + pragma Unreferenced (Cmd); + begin + return "--compare-tokens [OPTS] REF FILEs Compare FILEs with REF"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Compare_Tokens; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Tokens; + use Scanner; + + package Ref_Tokens is new GNAT.Table + (Table_Component_Type => Token_Type, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 1024, + Table_Increment => 100); + + Id : Name_Id; + Fe : Source_File_Entry; + Local_Id : Name_Id; + Tok_Idx : Natural; + begin + if Args'Length < 1 then + Error ("missing ref file"); + raise Compile_Error; + end if; + + Local_Id := Get_Identifier (""); + + for I in Args'Range loop + -- Load the file. + Id := Get_Identifier (Args (I).all); + Fe := Files_Map.Load_Source_File (Local_Id, Id); + if Fe = No_Source_File_Entry then + Error ("cannot open file " & Args (I).all); + raise Compile_Error; + end if; + Set_File (Fe); + + if I = Args'First then + -- Scan ref file + loop + Scan; + Ref_Tokens.Append (Current_Token); + exit when Current_Token = Tok_Eof; + end loop; + else + -- Scane file + Tok_Idx := Ref_Tokens.First; + loop + Scan; + if Ref_Tokens.Table (Tok_Idx) /= Current_Token then + Error_Msg_Parse ("token mismatch"); + exit; + end if; + case Current_Token is + when Tok_Eof => + exit; + when others => + null; + end case; + Tok_Idx := Tok_Idx + 1; + end loop; + end if; + Close_File; + end loop; + + Ref_Tokens.Free; + + if Nbr_Errors /= 0 then + raise Compilation_Error; + end if; + end Perform_Action; + + -- Command html. + type Command_Html is abstract new Command_Lib with null record; + + procedure Decode_Option (Cmd : in out Command_Html; + Option : String; + Arg : String; + Res : out Option_Res); + + procedure Disp_Long_Help (Cmd : Command_Html); + + procedure Decode_Option (Cmd : in out Command_Html; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "--format=css" then + Html_Format := Html_Css; + Res := Option_Ok; + elsif Option = "--format=html2" then + Html_Format := Html_2; + Res := Option_Ok; + else + Decode_Option (Command_Lib (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Disp_Long_Help (Cmd : Command_Html) is + begin + Disp_Long_Help (Command_Lib (Cmd)); + Put_Line ("--format=html2 Use FONT attributes"); + Put_Line ("--format=css Use ghdl.css file"); + end Disp_Long_Help; + + -- Command --pp-html. + type Command_PP_Html is new Command_Html with null record; + function Decode_Command (Cmd : Command_PP_Html; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_PP_Html) return String; + procedure Perform_Action (Cmd : in out Command_PP_Html; + Files : Argument_List); + + function Decode_Command (Cmd : Command_PP_Html; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--pp-html"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_PP_Html) return String + is + pragma Unreferenced (Cmd); + begin + return "--pp-html FILEs Pretty-print FILEs in HTML"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_PP_Html; + Files : Argument_List) + is + pragma Unreferenced (Cmd); + use Scanner; + use Tokens; + use Files_Map; + use Ada.Characters.Latin_1; + + Id : Name_Id; + Fe : Source_File_Entry; + Local_Id : Name_Id; + begin + Local_Id := Get_Identifier (""); + Put_Html_Header; + Put_Line (" <title>"); + for I in Files'Range loop + Put (" "); + Put_Line (Files (I).all); + end loop; + Put_Line (" </title>"); + Put_Line ("</head>"); + New_Line; + Put_Line ("<body>"); + + for I in Files'Range loop + Id := Get_Identifier (Files (I).all); + Fe := Files_Map.Load_Source_File (Local_Id, Id); + if Fe = No_Source_File_Entry then + Error ("cannot open file " & Files (I).all); + raise Compile_Error; + end if; + Put (" <h1>"); + Put (Files (I).all); + Put ("</h1>"); + New_Line; + + PP_Html_File (Fe); + end loop; + Put_Html_Foot; + end Perform_Action; + + -- Command --xref-html. + type Command_Xref_Html is new Command_Html with record + Output_Dir : String_Access := null; + Check_Missing : Boolean := False; + end record; + + function Decode_Command (Cmd : Command_Xref_Html; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Xref_Html) return String; + procedure Decode_Option (Cmd : in out Command_Xref_Html; + Option : String; + Arg : String; + Res : out Option_Res); + procedure Disp_Long_Help (Cmd : Command_Xref_Html); + + procedure Perform_Action (Cmd : in out Command_Xref_Html; + Files_Name : Argument_List); + + function Decode_Command (Cmd : Command_Xref_Html; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--xref-html"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Xref_Html) return String + is + pragma Unreferenced (Cmd); + begin + return "--xref-html FILEs Display FILEs in HTML with xrefs"; + end Get_Short_Help; + + procedure Decode_Option (Cmd : in out Command_Xref_Html; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "-o" then + if Arg = "" then + Res := Option_Arg_Req; + else + Cmd.Output_Dir := new String'(Arg); + Res := Option_Arg; + end if; + elsif Option = "--check-missing" then + Cmd.Check_Missing := True; + Res := Option_Ok; + else + Decode_Option (Command_Html (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Disp_Long_Help (Cmd : Command_Xref_Html) is + begin + Disp_Long_Help (Command_Html (Cmd)); + Put_Line ("-o DIR Put generated files into DIR (def: html/)"); + Put_Line ("--check-missing Fail if a reference is missing"); + New_Line; + Put_Line ("When format is css, the CSS file 'ghdl.css' " + & "is never overwritten."); + end Disp_Long_Help; + + procedure Analyze_Design_File_Units (File : Iir_Design_File) + is + Unit : Iir_Design_Unit; + begin + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + case Get_Date_State (Unit) is + when Date_Extern + | Date_Disk => + raise Internal_Error; + when Date_Parse => + Libraries.Load_Design_Unit (Unit, Null_Iir); + when Date_Analyze => + null; + end case; + Unit := Get_Chain (Unit); + end loop; + end Analyze_Design_File_Units; + + procedure Perform_Action + (Cmd : in out Command_Xref_Html; Files_Name : Argument_List) + is + use GNAT.Directory_Operations; + + Id : Name_Id; + File : Source_File_Entry; + + type File_Data is record + Fe : Source_File_Entry; + Design_File : Iir; + Output : String_Acc; + end record; + type File_Data_Array is array (Files_Name'Range) of File_Data; + + Files : File_Data_Array; + Output : File_Type; + begin + Xrefs.Init; + Flags.Flag_Xref := True; + + -- Load work library. + Setup_Libraries (True); + + if Cmd.Output_Dir = null then + Cmd.Output_Dir := new String'("html"); + elsif Cmd.Output_Dir.all = "-" then + Cmd.Output_Dir := null; + end if; + + -- Try to create the directory. + if Cmd.Output_Dir /= null + and then not Is_Directory (Cmd.Output_Dir.all) + then + declare + begin + Make_Dir (Cmd.Output_Dir.all); + exception + when Directory_Error => + Error ("cannot create directory " & Cmd.Output_Dir.all); + return; + end; + end if; + + -- Parse all files. + for I in Files'Range loop + Id := Get_Identifier (Files_Name (I).all); + File := Files_Map.Load_Source_File (Libraries.Local_Directory, Id); + if File = No_Source_File_Entry then + Error ("cannot open " & Image (Id)); + return; + end if; + Files (I).Fe := File; + Files (I).Design_File := Libraries.Load_File (File); + if Files (I).Design_File = Null_Iir then + return; + end if; + Files (I).Output := Create_Output_Filename + (Base_Name (Files_Name (I).all), I); + if Is_Regular_File (Files (I).Output.all) then + -- Prevent overwrite. + null; + end if; + -- Put units in library. + Libraries.Add_Design_File_Into_Library (Files (I).Design_File); + end loop; + + -- Analyze all files. + for I in Files'Range loop + Analyze_Design_File_Units (Files (I).Design_File); + end loop; + + Xrefs.Sort_By_Location; + + if False then + for I in 1 .. Xrefs.Get_Last_Xref loop + declare + use Xrefs; + + procedure Put_Loc (L : Location_Type) + is + use Files_Map; + + L_File : Source_File_Entry; + L_Pos : Source_Ptr; + begin + Files_Map.Location_To_File_Pos (L, L_File, L_Pos); + Put_Nat (Natural (L_File)); + --Image (Get_File_Name (L_File)); + --Put (Name_Buffer (1 .. Name_Length)); + Put (":"); + Put_Nat (Natural (L_Pos)); + end Put_Loc; + begin + Put_Loc (Get_Xref_Location (I)); + case Get_Xref_Kind (I) is + when Xref_Decl => + Put (" decl "); + Put (Image (Get_Identifier (Get_Xref_Node (I)))); + when Xref_Ref => + Put (" use "); + Put_Loc (Get_Location (Get_Xref_Node (I))); + when Xref_End => + Put (" end "); + when Xref_Body => + Put (" body "); + end case; + New_Line; + end; + end loop; + end if; + + -- Create filexref_info. + Filexref_Info := new Filexref_Info_Arr + (No_Source_File_Entry .. Files_Map.Get_Last_Source_File_Entry); + Filexref_Info.all := (others => (Output => null, + Referenced => False)); + for I in Files'Range loop + Filexref_Info (Files (I).Fe).Output := Files (I).Output; + end loop; + + for I in Files'Range loop + if Cmd.Output_Dir /= null then + Create (Output, Out_File, + Cmd.Output_Dir.all & Directory_Separator + & Files (I).Output.all); + + Set_Output (Output); + end if; + + Put_Html_Header; + Put_Line (" <title>"); + Put_Html (Files_Name (I).all); + Put ("</title>"); + Put_Line ("</head>"); + New_Line; + Put_Line ("<body>"); + + Put ("<h1>"); + Put_Html (Files_Name (I).all); + Put ("</h1>"); + New_Line; + + PP_Html_File (Files (I).Fe); + Put_Html_Foot; + + if Cmd.Output_Dir /= null then + Close (Output); + end if; + end loop; + + -- Create indexes. + if Cmd.Output_Dir /= null then + Create (Output, Out_File, + Cmd.Output_Dir.all & Directory_Separator & "index.html"); + Set_Output (Output); + + Put_Html_Header; + Put_Line (" <title>Xrefs indexes</title>"); + Put_Line ("</head>"); + New_Line; + Put_Line ("<body>"); + Put_Line ("<p>list of files:"); + Put_Line ("<ul>"); + for I in Files'Range loop + Put ("<li>"); + Put ("<a href="""); + Put (Files (I).Output.all); + Put (""">"); + Put_Html (Files_Name (I).all); + Put ("</a>"); + Put ("</li>"); + New_Line; + end loop; + Put_Line ("</ul></p>"); + Put_Line ("<hr>"); + + -- TODO: list of design units. + + Put_Line ("<p>list of files referenced but not available:"); + Put_Line ("<ul>"); + for I in No_Source_File_Entry + 1 .. Filexref_Info'Last loop + if Filexref_Info (I).Output = null + and then Filexref_Info (I).Referenced + then + Put ("<li><a name=""f"); + Put_Nat (Natural (I)); + Put (""">"); + Put_Html (Image (Files_Map.Get_File_Name (I))); + Put ("</a></li>"); + New_Line; + end if; + end loop; + Put_Line ("</ul></p><hr>"); + Put_Html_Foot; + + Close (Output); + end if; + + if Html_Format = Html_Css + and then Cmd.Output_Dir /= null + then + declare + Css_Filename : constant String := + Cmd.Output_Dir.all & Directory_Separator & "ghdl.css"; + begin + if not Is_Regular_File (Css_Filename & Nul) then + Create (Output, Out_File, Css_Filename); + Set_Output (Output); + Put_Css; + Close (Output); + end if; + end; + end if; + + if Missing_Xref and Cmd.Check_Missing then + Error ("missing xrefs"); + raise Compile_Error; + end if; + exception + when Compilation_Error => + Error ("xrefs has failed due to compilation error"); + end Perform_Action; + + + -- Command --xref + type Command_Xref is new Command_Lib with null record; + + function Decode_Command (Cmd : Command_Xref; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Xref) return String; + + procedure Perform_Action (Cmd : in out Command_Xref; + Files_Name : Argument_List); + + function Decode_Command (Cmd : Command_Xref; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--xref"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Xref) return String + is + pragma Unreferenced (Cmd); + begin + return "--xref FILEs Generate xrefs"; + end Get_Short_Help; + + procedure Perform_Action + (Cmd : in out Command_Xref; Files_Name : Argument_List) + is + pragma Unreferenced (Cmd); + + use Files_Map; + + Id : Name_Id; + File : Source_File_Entry; + + type File_Data is record + Fe : Source_File_Entry; + Design_File : Iir; + end record; + type File_Data_Array is array (Files_Name'Range) of File_Data; + + Files : File_Data_Array; + begin + -- Load work library. + Setup_Libraries (True); + + Xrefs.Init; + Flags.Flag_Xref := True; + + -- Parse all files. + for I in Files'Range loop + Id := Get_Identifier (Files_Name (I).all); + File := Load_Source_File (Libraries.Local_Directory, Id); + if File = No_Source_File_Entry then + Error ("cannot open " & Image (Id)); + return; + end if; + Files (I).Fe := File; + Files (I).Design_File := Libraries.Load_File (File); + if Files (I).Design_File = Null_Iir then + return; + end if; + -- Put units in library. + -- Note: design_units stay while design_file get empty. + Libraries.Add_Design_File_Into_Library (Files (I).Design_File); + end loop; + + -- Analyze all files. + for I in Files'Range loop + Analyze_Design_File_Units (Files (I).Design_File); + end loop; + + Xrefs.Fix_End_Xrefs; + Xrefs.Sort_By_Node_Location; + + for F in Files'Range loop + + Put ("GHDL-XREF V0"); + + declare + use Xrefs; + + Cur_Decl : Iir; + Cur_File : Source_File_Entry; + + procedure Emit_Loc (Loc : Location_Type; C : Character) + is + L_File : Source_File_Entry; + L_Pos : Source_Ptr; + L_Line : Natural; + L_Off : Natural; + begin + Location_To_Coord (Loc, L_File, L_Pos, L_Line, L_Off); + --Put_Nat (Natural (L_File)); + --Put (':'); + Put_Nat (L_Line); + Put (C); + Put_Nat (L_Off); + end Emit_Loc; + + procedure Emit_Decl (N : Iir) + is + Loc : Location_Type; + Loc_File : Source_File_Entry; + Loc_Pos : Source_Ptr; + C : Character; + Dir : Name_Id; + begin + New_Line; + Cur_Decl := N; + Loc := Get_Location (N); + Location_To_File_Pos (Loc, Loc_File, Loc_Pos); + if Loc_File /= Cur_File then + Cur_File := Loc_File; + Put ("XFILE: "); + Dir := Get_Source_File_Directory (Cur_File); + if Dir /= Null_Identifier then + Image (Dir); + Put (Name_Buffer (1 .. Name_Length)); + end if; + Image (Get_File_Name (Cur_File)); + Put (Name_Buffer (1 .. Name_Length)); + New_Line; + end if; + + -- Letters: + -- b d fgh jk no qr uvwxyz + -- D H JK MNO QR U WXYZ + case Get_Kind (N) is + when Iir_Kind_Type_Declaration => + C := 'T'; + when Iir_Kind_Subtype_Declaration => + C := 't'; + when Iir_Kind_Entity_Declaration => + C := 'E'; + when Iir_Kind_Architecture_Body => + C := 'A'; + when Iir_Kind_Library_Declaration => + C := 'L'; + when Iir_Kind_Package_Declaration => + C := 'P'; + when Iir_Kind_Package_Body => + C := 'B'; + when Iir_Kind_Function_Declaration => + C := 'F'; + when Iir_Kind_Procedure_Declaration => + C := 'p'; + when Iir_Kind_Interface_Signal_Declaration => + C := 's'; + when Iir_Kind_Signal_Declaration => + C := 'S'; + when Iir_Kind_Interface_Constant_Declaration => + C := 'c'; + when Iir_Kind_Constant_Declaration => + C := 'C'; + when Iir_Kind_Variable_Declaration => + C := 'V'; + when Iir_Kind_Element_Declaration => + C := 'e'; + when Iir_Kind_Iterator_Declaration => + C := 'i'; + when Iir_Kind_Attribute_Declaration => + C := 'a'; + when Iir_Kind_Enumeration_Literal => + C := 'l'; + when Iir_Kind_Component_Declaration => + C := 'm'; + when Iir_Kind_Component_Instantiation_Statement => + C := 'I'; + when Iir_Kind_Generate_Statement => + C := 'G'; + when others => + C := '?'; + end case; + Emit_Loc (Loc, C); + --Disp_Tree.Disp_Iir_Address (N); + Put (' '); + case Get_Kind (N) is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + when others => + Image (Get_Identifier (N)); + Put (Name_Buffer (1 .. Name_Length)); + end case; + end Emit_Decl; + + procedure Emit_Ref (R : Xref; T : Character) + is + N : Iir; + begin + N := Get_Xref_Node (R); + if N /= Cur_Decl then + Emit_Decl (N); + end if; + Put (' '); + Emit_Loc (Get_Xref_Location (R), T); + end Emit_Ref; + + Loc : Location_Type; + Loc_File : Source_File_Entry; + Loc_Pos : Source_Ptr; + begin + Cur_Decl := Null_Iir; + Cur_File := No_Source_File_Entry; + + for I in First_Xref .. Get_Last_Xref loop + Loc := Get_Xref_Location (I); + Location_To_File_Pos (Loc, Loc_File, Loc_Pos); + if Loc_File = Files (F).Fe then + -- This is a local location. + case Get_Xref_Kind (I) is + when Xref_Decl => + Emit_Decl (Get_Xref_Node (I)); + when Xref_End => + Emit_Ref (I, 'e'); + when Xref_Ref => + Emit_Ref (I, 'r'); + when Xref_Body => + Emit_Ref (I, 'b'); + end case; + end if; + end loop; + New_Line; + end; + end loop; + exception + when Compilation_Error => + Error ("xrefs has failed due to compilation error"); + end Perform_Action; + + procedure Register_Commands is + begin + Register_Command (new Command_Chop); + Register_Command (new Command_Lines); + Register_Command (new Command_Reprint); + Register_Command (new Command_Compare_Tokens); + Register_Command (new Command_PP_Html); + Register_Command (new Command_Xref_Html); + Register_Command (new Command_Xref); + end Register_Commands; +end Ghdlprint; diff --git a/src/translate/ghdldrv/ghdlprint.ads b/src/translate/ghdldrv/ghdlprint.ads new file mode 100644 index 0000000..82c3e60 --- /dev/null +++ b/src/translate/ghdldrv/ghdlprint.ads @@ -0,0 +1,20 @@ +-- GHDL driver - print commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Ghdlprint is + procedure Register_Commands; +end Ghdlprint; diff --git a/src/translate/ghdldrv/ghdlrun.adb b/src/translate/ghdldrv/ghdlrun.adb new file mode 100644 index 0000000..f623721 --- /dev/null +++ b/src/translate/ghdldrv/ghdlrun.adb @@ -0,0 +1,661 @@ +-- GHDL driver - JIT commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Interfaces.C; + +with Ghdlmain; use Ghdlmain; +with Ghdllocal; use Ghdllocal; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with Ada.Unchecked_Conversion; +with Ada.Command_Line; +with Ada.Text_IO; + +with Ortho_Jit; +with Ortho_Nodes; use Ortho_Nodes; +with Interfaces; +with System; use System; +with Trans_Decls; +with Iirs; use Iirs; +with Flags; +with Errorout; use Errorout; +with Libraries; +with Canon; +with Trans_Be; +with Translation; +with Ieee.Std_Logic_1164; + +with Lists; +with Str_Table; +with Nodes; +with Files_Map; +with Name_Table; + +with Grt.Main; +with Grt.Modules; +with Grt.Lib; +with Grt.Processes; +with Grt.Rtis; +with Grt.Files; +with Grt.Signals; +with Grt.Options; +with Grt.Types; +with Grt.Images; +with Grt.Values; +with Grt.Names; +with Grt.Std_Logic_1164; + +with Ghdlcomp; +with Foreigns; +with Grtlink; + +package body Ghdlrun is + procedure Foreign_Hook (Decl : Iir; + Info : Translation.Foreign_Info_Type; + Ortho : O_Dnode); + + procedure Compile_Init (Analyze_Only : Boolean) is + begin + if Analyze_Only then + return; + end if; + + Translation.Foreign_Hook := Foreign_Hook'Access; + + -- FIXME: add a flag to force unnesting. + -- Translation.Flag_Unnest_Subprograms := True; + + -- The design is always analyzed in whole. + Flags.Flag_Whole_Analyze := True; + + Setup_Libraries (False); + Libraries.Load_Std_Library; + + Ortho_Jit.Init; + + Translation.Initialize; + Canon.Canon_Flag_Add_Labels := True; + end Compile_Init; + + procedure Compile_Elab + (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural) + is + begin + Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg); + if Sec_Name = null then + Sec_Name := new String'(""); + end if; + + Flags.Flag_Elaborate := True; + Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True); + + if Errorout.Nbr_Errors > 0 then + -- This may happen (bad entity for example). + raise Compilation_Error; + end if; + 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 + use Interfaces.C; + use Grt.Options; + use Grt.Types; + + function Malloc (Size : size_t) return Argv_Type; + pragma Import (C, Malloc); + + function Strdup (Str : String) return Ghdl_C_String; + pragma Import (C, Strdup); +-- is +-- T : Grt.Types.String_Access; +-- begin +-- T := new String'(Str & Ghdllocal.Nul); +-- return To_Ghdl_C_String (T.all'Address); +-- end Strdup; + begin + Argc := 1 + Args'Length; + Argv := Malloc + (size_t (Argc * (Ghdl_C_String'Size / System.Storage_Unit))); + Argv (0) := Strdup (Ada.Command_Line.Command_Name & Ghdllocal.Nul); + Progname := Argv (0); + for I in Args'Range loop + Argv (1 + I - Args'First) := Strdup (Args (I).all & Ghdllocal.Nul); + end loop; + end Set_Run_Options; + + procedure Ghdl_Elaborate; + pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE"); + + type Elaborate_Acc is access procedure; + pragma Convention (C, Elaborate_Acc); + Elaborate_Proc : Elaborate_Acc := null; + + procedure Ghdl_Elaborate is + begin + --Ada.Text_IO.Put_Line (Standard_Error, "ghdl_elaborate"); + Elaborate_Proc.all; + end Ghdl_Elaborate; + + procedure Def (Decl : O_Dnode; Addr : Address) + renames Ortho_Jit.Set_Address; + + procedure Foreign_Hook (Decl : Iir; + Info : Translation.Foreign_Info_Type; + Ortho : O_Dnode) + is + use Translation; + Res : Address; + begin + case Info.Kind is + when Foreign_Vhpidirect => + declare + Name : constant String := + Name_Table.Name_Buffer (Info.Subprg_First + .. Info.Subprg_Last); + begin + Res := Foreigns.Find_Foreign (Name); + if Res /= Null_Address then + Def (Ortho, Res); + else + Error_Msg_Sem ("unknown foreign VHPIDIRECT '" & Name & "'", + Decl); + end if; + end; + when Foreign_Intrinsic => + Name_Table.Image (Get_Identifier (Decl)); + declare + Name : constant String := + Name_Table.Name_Buffer (1 .. Name_Table.Name_Length); + begin + if Name = "untruncated_text_read" then + Def (Ortho, Grt.Files.Ghdl_Untruncated_Text_Read'Address); + elsif Name = "control_simulation" then + Def (Ortho, Grt.Lib.Ghdl_Control_Simulation'Address); + elsif Name = "get_resolution_limit" then + Def (Ortho, Grt.Lib.Ghdl_Get_Resolution_Limit'Address); + else + Error_Msg_Sem ("unknown foreign intrinsic '" & Name & "'", + Decl); + end if; + end; + when Foreign_Unknown => + null; + end case; + end Foreign_Hook; + + procedure Run + is + use Interfaces; + --use Ortho_Code.Binary; + + function Conv is new Ada.Unchecked_Conversion + (Source => Address, Target => Elaborate_Acc); + Err : Boolean; + Decl : O_Dnode; + begin + if Flag_Verbose then + Ada.Text_IO.Put_Line ("Linking in memory"); + end if; + + Def (Trans_Decls.Ghdl_Memcpy, + Grt.Lib.Ghdl_Memcpy'Address); + Def (Trans_Decls.Ghdl_Bound_Check_Failed_L1, + Grt.Lib.Ghdl_Bound_Check_Failed_L1'Address); + Def (Trans_Decls.Ghdl_Malloc0, + Grt.Lib.Ghdl_Malloc0'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_Ieee_Assert_Failed, + Grt.Lib.Ghdl_Ieee_Assert_Failed'Address); + Def (Trans_Decls.Ghdl_Psl_Assert_Failed, + Grt.Lib.Ghdl_Psl_Assert_Failed'Address); + Def (Trans_Decls.Ghdl_Psl_Cover, + Grt.Lib.Ghdl_Psl_Cover'Address); + Def (Trans_Decls.Ghdl_Psl_Cover_Failed, + Grt.Lib.Ghdl_Psl_Cover_Failed'Address); + Def (Trans_Decls.Ghdl_Program_Error, + Grt.Lib.Ghdl_Program_Error'Address); + Def (Trans_Decls.Ghdl_Malloc, + Grt.Lib.Ghdl_Malloc'Address); + Def (Trans_Decls.Ghdl_Deallocate, + Grt.Lib.Ghdl_Deallocate'Address); + Def (Trans_Decls.Ghdl_Real_Exp, + Grt.Lib.Ghdl_Real_Exp'Address); + Def (Trans_Decls.Ghdl_Integer_Exp, + Grt.Lib.Ghdl_Integer_Exp'Address); + + Def (Trans_Decls.Ghdl_Sensitized_Process_Register, + Grt.Processes.Ghdl_Sensitized_Process_Register'Address); + Def (Trans_Decls.Ghdl_Process_Register, + Grt.Processes.Ghdl_Process_Register'Address); + Def (Trans_Decls.Ghdl_Postponed_Sensitized_Process_Register, + 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, + Grt.Processes.Ghdl_Stack2_Mark'Address); + Def (Trans_Decls.Ghdl_Stack2_Release, + Grt.Processes.Ghdl_Stack2_Release'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Exit, + Grt.Processes.Ghdl_Process_Wait_Exit'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Suspend, + Grt.Processes.Ghdl_Process_Wait_Suspend'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Timeout, + Grt.Processes.Ghdl_Process_Wait_Timeout'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Set_Timeout, + Grt.Processes.Ghdl_Process_Wait_Set_Timeout'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Add_Sensitivity, + Grt.Processes.Ghdl_Process_Wait_Add_Sensitivity'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Close, + Grt.Processes.Ghdl_Process_Wait_Close'Address); + + Def (Trans_Decls.Ghdl_Process_Add_Sensitivity, + Grt.Processes.Ghdl_Process_Add_Sensitivity'Address); + + Def (Trans_Decls.Ghdl_Now, + Grt.Types.Current_Time'Address); + + Def (Trans_Decls.Ghdl_Process_Add_Driver, + Grt.Signals.Ghdl_Process_Add_Driver'Address); + Def (Trans_Decls.Ghdl_Signal_Add_Direct_Driver, + Grt.Signals.Ghdl_Signal_Add_Direct_Driver'Address); + + Def (Trans_Decls.Ghdl_Signal_Add_Source, + Grt.Signals.Ghdl_Signal_Add_Source'Address); + Def (Trans_Decls.Ghdl_Signal_In_Conversion, + Grt.Signals.Ghdl_Signal_In_Conversion'Address); + Def (Trans_Decls.Ghdl_Signal_Out_Conversion, + Grt.Signals.Ghdl_Signal_Out_Conversion'Address); + Def (Trans_Decls.Ghdl_Signal_Effective_Value, + Grt.Signals.Ghdl_Signal_Effective_Value'Address); + Def (Trans_Decls.Ghdl_Signal_Create_Resolution, + Grt.Signals.Ghdl_Signal_Create_Resolution'Address); + + Def (Trans_Decls.Ghdl_Signal_Disconnect, + Grt.Signals.Ghdl_Signal_Disconnect'Address); + Def (Trans_Decls.Ghdl_Signal_Set_Disconnect, + Grt.Signals.Ghdl_Signal_Set_Disconnect'Address); + Def (Trans_Decls.Ghdl_Signal_Merge_Rti, + Grt.Signals.Ghdl_Signal_Merge_Rti'Address); + Def (Trans_Decls.Ghdl_Signal_Name_Rti, + Grt.Signals.Ghdl_Signal_Name_Rti'Address); + Def (Trans_Decls.Ghdl_Signal_Read_Port, + Grt.Signals.Ghdl_Signal_Read_Port'Address); + Def (Trans_Decls.Ghdl_Signal_Read_Driver, + Grt.Signals.Ghdl_Signal_Read_Driver'Address); + + Def (Trans_Decls.Ghdl_Signal_Driving, + Grt.Signals.Ghdl_Signal_Driving'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_B1, + Grt.Signals.Ghdl_Signal_Driving_Value_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_E8, + Grt.Signals.Ghdl_Signal_Driving_Value_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_E32, + Grt.Signals.Ghdl_Signal_Driving_Value_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_I32, + Grt.Signals.Ghdl_Signal_Driving_Value_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_I64, + Grt.Signals.Ghdl_Signal_Driving_Value_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_F64, + Grt.Signals.Ghdl_Signal_Driving_Value_F64'Address); + + Def (Trans_Decls.Ghdl_Signal_Create_Guard, + Grt.Signals.Ghdl_Signal_Create_Guard'Address); + Def (Trans_Decls.Ghdl_Signal_Guard_Dependence, + Grt.Signals.Ghdl_Signal_Guard_Dependence'Address); + + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_Error, + Grt.Signals.Ghdl_Signal_Simple_Assign_Error'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_Error, + Grt.Signals.Ghdl_Signal_Start_Assign_Error'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_Error, + Grt.Signals.Ghdl_Signal_Next_Assign_Error'Address); + + Def (Trans_Decls.Ghdl_Signal_Start_Assign_Null, + Grt.Signals.Ghdl_Signal_Start_Assign_Null'Address); + + Def (Trans_Decls.Ghdl_Signal_Direct_Assign, + Grt.Signals.Ghdl_Signal_Direct_Assign'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_B1, + Grt.Signals.Ghdl_Create_Signal_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Init_B1, + Grt.Signals.Ghdl_Signal_Init_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_B1, + Grt.Signals.Ghdl_Signal_Simple_Assign_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_B1, + Grt.Signals.Ghdl_Signal_Start_Assign_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_B1, + Grt.Signals.Ghdl_Signal_Next_Assign_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_B1, + Grt.Signals.Ghdl_Signal_Associate_B1'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_E8, + Grt.Signals.Ghdl_Create_Signal_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Init_E8, + Grt.Signals.Ghdl_Signal_Init_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E8, + Grt.Signals.Ghdl_Signal_Simple_Assign_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_E8, + Grt.Signals.Ghdl_Signal_Start_Assign_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_E8, + Grt.Signals.Ghdl_Signal_Next_Assign_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_E8, + Grt.Signals.Ghdl_Signal_Associate_E8'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_E32, + Grt.Signals.Ghdl_Create_Signal_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Init_E32, + Grt.Signals.Ghdl_Signal_Init_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E32, + Grt.Signals.Ghdl_Signal_Simple_Assign_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_E32, + Grt.Signals.Ghdl_Signal_Start_Assign_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_E32, + Grt.Signals.Ghdl_Signal_Next_Assign_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_E32, + Grt.Signals.Ghdl_Signal_Associate_E32'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_I32, + Grt.Signals.Ghdl_Create_Signal_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Init_I32, + Grt.Signals.Ghdl_Signal_Init_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I32, + Grt.Signals.Ghdl_Signal_Simple_Assign_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_I32, + Grt.Signals.Ghdl_Signal_Start_Assign_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_I32, + Grt.Signals.Ghdl_Signal_Next_Assign_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_I32, + Grt.Signals.Ghdl_Signal_Associate_I32'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_I64, + Grt.Signals.Ghdl_Create_Signal_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Init_I64, + Grt.Signals.Ghdl_Signal_Init_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I64, + Grt.Signals.Ghdl_Signal_Simple_Assign_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_I64, + Grt.Signals.Ghdl_Signal_Start_Assign_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_I64, + Grt.Signals.Ghdl_Signal_Next_Assign_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_I64, + Grt.Signals.Ghdl_Signal_Associate_I64'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_F64, + Grt.Signals.Ghdl_Create_Signal_F64'Address); + Def (Trans_Decls.Ghdl_Signal_Init_F64, + Grt.Signals.Ghdl_Signal_Init_F64'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_F64, + Grt.Signals.Ghdl_Signal_Simple_Assign_F64'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_F64, + Grt.Signals.Ghdl_Signal_Start_Assign_F64'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_F64, + Grt.Signals.Ghdl_Signal_Next_Assign_F64'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_F64, + Grt.Signals.Ghdl_Signal_Associate_F64'Address); + + Def (Trans_Decls.Ghdl_Signal_Attribute_Register_Prefix, + Grt.Signals.Ghdl_Signal_Attribute_Register_Prefix'Address); + Def (Trans_Decls.Ghdl_Create_Stable_Signal, + Grt.Signals.Ghdl_Create_Stable_Signal'Address); + Def (Trans_Decls.Ghdl_Create_Quiet_Signal, + Grt.Signals.Ghdl_Create_Quiet_Signal'Address); + Def (Trans_Decls.Ghdl_Create_Transaction_Signal, + Grt.Signals.Ghdl_Create_Transaction_Signal'Address); + Def (Trans_Decls.Ghdl_Create_Delayed_Signal, + Grt.Signals.Ghdl_Create_Delayed_Signal'Address); + + Def (Trans_Decls.Ghdl_Rti_Add_Package, + Grt.Rtis.Ghdl_Rti_Add_Package'Address); + Def (Trans_Decls.Ghdl_Rti_Add_Top, + Grt.Rtis.Ghdl_Rti_Add_Top'Address); + + Def (Trans_Decls.Ghdl_Protected_Enter, + Grt.Processes.Ghdl_Protected_Enter'Address); + Def (Trans_Decls.Ghdl_Protected_Leave, + Grt.Processes.Ghdl_Protected_Leave'Address); + Def (Trans_Decls.Ghdl_Protected_Init, + Grt.Processes.Ghdl_Protected_Init'Address); + Def (Trans_Decls.Ghdl_Protected_Fini, + Grt.Processes.Ghdl_Protected_Fini'Address); + + Def (Trans_Decls.Ghdl_Text_File_Elaborate, + Grt.Files.Ghdl_Text_File_Elaborate'Address); + Def (Trans_Decls.Ghdl_Text_File_Finalize, + Grt.Files.Ghdl_Text_File_Finalize'Address); + Def (Trans_Decls.Ghdl_Text_File_Open, + Grt.Files.Ghdl_Text_File_Open'Address); + Def (Trans_Decls.Ghdl_Text_File_Open_Status, + Grt.Files.Ghdl_Text_File_Open_Status'Address); + Def (Trans_Decls.Ghdl_Text_Write, + Grt.Files.Ghdl_Text_Write'Address); + Def (Trans_Decls.Ghdl_Text_Read_Length, + Grt.Files.Ghdl_Text_Read_Length'Address); + Def (Trans_Decls.Ghdl_Text_File_Close, + Grt.Files.Ghdl_Text_File_Close'Address); + + Def (Trans_Decls.Ghdl_File_Elaborate, + Grt.Files.Ghdl_File_Elaborate'Address); + Def (Trans_Decls.Ghdl_File_Finalize, + Grt.Files.Ghdl_File_Finalize'Address); + Def (Trans_Decls.Ghdl_File_Open, + Grt.Files.Ghdl_File_Open'Address); + Def (Trans_Decls.Ghdl_File_Open_Status, + Grt.Files.Ghdl_File_Open_Status'Address); + Def (Trans_Decls.Ghdl_File_Close, + Grt.Files.Ghdl_File_Close'Address); + Def (Trans_Decls.Ghdl_File_Flush, + Grt.Files.Ghdl_File_Flush'Address); + Def (Trans_Decls.Ghdl_Write_Scalar, + Grt.Files.Ghdl_Write_Scalar'Address); + Def (Trans_Decls.Ghdl_Read_Scalar, + Grt.Files.Ghdl_Read_Scalar'Address); + + Def (Trans_Decls.Ghdl_File_Endfile, + Grt.Files.Ghdl_File_Endfile'Address); + + Def (Trans_Decls.Ghdl_Image_B1, + Grt.Images.Ghdl_Image_B1'Address); + Def (Trans_Decls.Ghdl_Image_E8, + Grt.Images.Ghdl_Image_E8'Address); + Def (Trans_Decls.Ghdl_Image_E32, + Grt.Images.Ghdl_Image_E32'Address); + Def (Trans_Decls.Ghdl_Image_I32, + Grt.Images.Ghdl_Image_I32'Address); + Def (Trans_Decls.Ghdl_Image_F64, + Grt.Images.Ghdl_Image_F64'Address); + Def (Trans_Decls.Ghdl_Image_P64, + Grt.Images.Ghdl_Image_P64'Address); + Def (Trans_Decls.Ghdl_Image_P32, + Grt.Images.Ghdl_Image_P32'Address); + + Def (Trans_Decls.Ghdl_Value_B1, + Grt.Values.Ghdl_Value_B1'Address); + Def (Trans_Decls.Ghdl_Value_E8, + Grt.Values.Ghdl_Value_E8'Address); + Def (Trans_Decls.Ghdl_Value_E32, + Grt.Values.Ghdl_Value_E32'Address); + Def (Trans_Decls.Ghdl_Value_I32, + Grt.Values.Ghdl_Value_I32'Address); + Def (Trans_Decls.Ghdl_Value_F64, + Grt.Values.Ghdl_Value_F64'Address); + Def (Trans_Decls.Ghdl_Value_P32, + Grt.Values.Ghdl_Value_P32'Address); + Def (Trans_Decls.Ghdl_Value_P64, + Grt.Values.Ghdl_Value_P64'Address); + + Def (Trans_Decls.Ghdl_Get_Path_Name, + Grt.Names.Ghdl_Get_Path_Name'Address); + Def (Trans_Decls.Ghdl_Get_Instance_Name, + Grt.Names.Ghdl_Get_Instance_Name'Address); + + Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Eq, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Eq'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Ne, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Ne'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Lt, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Lt'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Le, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Le'Address); + + Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Eq, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Eq'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Ne, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Ne'Address); + + Def (Trans_Decls.Ghdl_To_String_I32, + Grt.Images.Ghdl_To_String_I32'Address); + Def (Trans_Decls.Ghdl_To_String_F64, + Grt.Images.Ghdl_To_String_F64'Address); + Def (Trans_Decls.Ghdl_To_String_F64_Digits, + Grt.Images.Ghdl_To_String_F64_Digits'Address); + Def (Trans_Decls.Ghdl_To_String_F64_Format, + Grt.Images.Ghdl_To_String_F64_Format'Address); + Def (Trans_Decls.Ghdl_To_String_B1, + Grt.Images.Ghdl_To_String_B1'Address); + Def (Trans_Decls.Ghdl_To_String_E8, + Grt.Images.Ghdl_To_String_E8'Address); + Def (Trans_Decls.Ghdl_To_String_E32, + Grt.Images.Ghdl_To_String_E32'Address); + Def (Trans_Decls.Ghdl_To_String_Char, + Grt.Images.Ghdl_To_String_Char'Address); + Def (Trans_Decls.Ghdl_To_String_P32, + Grt.Images.Ghdl_To_String_P32'Address); + Def (Trans_Decls.Ghdl_To_String_P64, + Grt.Images.Ghdl_To_String_P64'Address); + Def (Trans_Decls.Ghdl_Time_To_String_Unit, + Grt.Images.Ghdl_Time_To_String_Unit'Address); + Def (Trans_Decls.Ghdl_BV_To_Ostring, + Grt.Images.Ghdl_BV_To_Ostring'Address); + Def (Trans_Decls.Ghdl_BV_To_Hstring, + Grt.Images.Ghdl_BV_To_Hstring'Address); + Def (Trans_Decls.Ghdl_Array_Char_To_String_B1, + Grt.Images.Ghdl_Array_Char_To_String_B1'Address); + Def (Trans_Decls.Ghdl_Array_Char_To_String_E8, + Grt.Images.Ghdl_Array_Char_To_String_E8'Address); + Def (Trans_Decls.Ghdl_Array_Char_To_String_E32, + Grt.Images.Ghdl_Array_Char_To_String_E32'Address); + + Ortho_Jit.Link (Err); + if Err then + raise Compile_Error; + end if; + + Grtlink.Std_Standard_Boolean_RTI_Ptr := + Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Boolean_Rti); + Grtlink.Std_Standard_Bit_RTI_Ptr := + Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Bit_Rti); + if Ieee.Std_Logic_1164.Resolved /= Null_Iir then + Decl := Translation.Get_Resolv_Ortho_Decl + (Ieee.Std_Logic_1164.Resolved); + if Decl /= O_Dnode_Null then + Grtlink.Ieee_Std_Logic_1164_Resolved_Resolv_Ptr := + Ortho_Jit.Get_Address (Decl); + end if; + end if; + + Grtlink.Flag_String := Flags.Flag_String; + + Elaborate_Proc := + Conv (Ortho_Jit.Get_Address (Trans_Decls.Ghdl_Elaborate)); + + Ortho_Jit.Finish; + + Translation.Finalize; + Lists.Initialize; + Str_Table.Initialize; + Nodes.Initialize; + Files_Map.Initialize; + Name_Table.Initialize; + + if Flag_Verbose then + Ada.Text_IO.Put_Line ("Starting simulation"); + end if; + + Grt.Main.Run; + --V := Ghdl_Main (1, Gnat_Argv); + end Run; + + + -- Command run help. + type Command_Run_Help is new Command_Type with null record; + function Decode_Command (Cmd : Command_Run_Help; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Run_Help) return String; + procedure Perform_Action (Cmd : in out Command_Run_Help; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Run_Help; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--run-help"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Run_Help) return String + is + pragma Unreferenced (Cmd); + begin + return "--run-help Disp help for RUNOPTS options"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Run_Help; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + begin + if Args'Length /= 0 then + Error + ("warning: command '--run-help' does not accept any argument"); + end if; + Put_Line ("These options can only be placed at [RUNOPTS]"); + -- Register modules, since they add commands. + Grt.Modules.Register_Modules; + -- Bypass usual help header. + Grt.Options.Argc := 0; + Grt.Options.Help; + end Perform_Action; + + procedure Register_Commands + is + begin + Ghdlcomp.Hooks := (Compile_Init'Access, + Compile_Elab'Access, + Set_Run_Options'Access, + Run'Access, + Ortho_Jit.Decode_Option'Access, + Ortho_Jit.Disp_Help'Access); + Ghdlcomp.Register_Commands; + Register_Command (new Command_Run_Help); + Trans_Be.Register_Translation_Back_End; + end Register_Commands; +end Ghdlrun; diff --git a/src/translate/ghdldrv/ghdlrun.ads b/src/translate/ghdldrv/ghdlrun.ads new file mode 100644 index 0000000..07095bd --- /dev/null +++ b/src/translate/ghdldrv/ghdlrun.ads @@ -0,0 +1,20 @@ +-- GHDL driver - JIT commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Ghdlrun is + procedure Register_Commands; +end Ghdlrun; diff --git a/src/translate/ghdldrv/ghdlsimul.adb b/src/translate/ghdldrv/ghdlsimul.adb new file mode 100644 index 0000000..17cece7 --- /dev/null +++ b/src/translate/ghdldrv/ghdlsimul.adb @@ -0,0 +1,209 @@ +-- GHDL driver - simulator commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Text_IO; +with Ada.Command_Line; + +with Ghdllocal; use Ghdllocal; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with Types; +with Iirs; use Iirs; +with Flags; +with Back_End; +with Name_Table; +with Errorout; use Errorout; +with Std_Package; +with Libraries; +with Canon; +with Configuration; +with Iirs_Utils; +with Annotations; +with Elaboration; +with Sim_Be; +with Simulation; +with Execution; + +with Ghdlcomp; + +with Grt.Vpi; +pragma Unreferenced (Grt.Vpi); +with Grt.Types; +with Grt.Options; +with Grtlink; + +package body Ghdlsimul is + + -- FIXME: reuse simulation.top_config + Top_Conf : Iir; + + procedure Compile_Init (Analyze_Only : Boolean) is + begin + if Analyze_Only then + return; + end if; + + -- Initialize. + Back_End.Finish_Compilation := Sim_Be.Finish_Compilation'Access; + Back_End.Sem_Foreign := null; + + Setup_Libraries (False); + Libraries.Load_Std_Library; + + -- Here, time_base can be set. + Annotations.Annotate (Std_Package.Std_Standard_Unit); + + Canon.Canon_Flag_Add_Labels := True; + Canon.Canon_Flag_Sequentials_Stmts := True; + Canon.Canon_Flag_Expressions := True; + Canon.Canon_Flag_All_Sensitivity := True; + end Compile_Init; + + procedure Compile_Elab + (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural) + is + use Name_Table; + use Types; + + First_Id : Name_Id; + Sec_Id : Name_Id; + begin + Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg); + + Flags.Flag_Elaborate := True; + -- Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True); + + if Errorout.Nbr_Errors > 0 then + -- This may happen (bad entity for example). + raise Compilation_Error; + end if; + + First_Id := Get_Identifier (Prim_Name.all); + if Sec_Name = null then + Sec_Id := Null_Identifier; + else + Sec_Id := Get_Identifier (Sec_Name.all); + end if; + Top_Conf := Configuration.Configure (First_Id, Sec_Id); + if Top_Conf = Null_Iir then + raise Compilation_Error; + end if; + + -- Check (and possibly abandon) if entity can be at the top of the + -- hierarchy. + declare + Conf_Unit : constant Iir := Get_Library_Unit (Top_Conf); + Arch : constant Iir := + Get_Block_Specification (Get_Block_Configuration (Conf_Unit)); + Entity : constant Iir := Iirs_Utils.Get_Entity (Arch); + begin + Configuration.Check_Entity_Declaration_Top (Entity); + if Nbr_Errors > 0 then + raise Compilation_Error; + end if; + end; + end Compile_Elab; + + -- Set options. + procedure Set_Run_Options (Args : Argument_List) + is + use Grt.Options; + use Types; + Arg : String_Access; + Status : Decode_Option_Status; + Argv0 : String_Acc; + begin + -- Set progname (used for grt error messages) + Argv0 := new String'(Ada.Command_Line.Command_Name & ASCII.Nul); + Grt.Options.Progname := Grt.Types.To_Ghdl_C_String (Argv0.all'Address); + + for I in Args'Range loop + Arg := Args (I); + if Arg.all = "--disp-tree" then + Simulation.Disp_Tree := True; + elsif Arg.all = "--expect-failure" then + Decode_Option (Arg.all, Status); + pragma Assert (Status = Decode_Option_Ok); + elsif Arg.all = "--trace-elab" then + Elaboration.Trace_Elaboration := True; + elsif Arg.all = "--trace-drivers" then + Elaboration.Trace_Drivers := True; + elsif Arg.all = "--trace-annotation" then + Annotations.Trace_Annotation := True; + elsif Arg.all = "--trace-simu" then + Simulation.Trace_Simulation := True; + elsif Arg.all = "--trace-stmt" then + Execution.Trace_Statements := True; + elsif Arg.all = "--stats" then + Simulation.Disp_Stats := True; + elsif Arg.all = "-i" then + Simulation.Flag_Interractive := True; + else + Decode_Option (Arg.all, Status); + case Status is + when Decode_Option_Last => + exit; + when Decode_Option_Help => + -- FIXME: is that correct ? + exit; + when Decode_Option_Ok => + null; + end case; + -- Ghdlmain.Error ("unknown run options '" & Arg.all & "'"); + -- raise Option_Error; + end if; + end loop; + end Set_Run_Options; + + procedure Run is + begin + Grtlink.Flag_String := Flags.Flag_String; + + Simulation.Simulation_Entity (Top_Conf); + end Run; + + function Decode_Option (Option : String) return Boolean + is + begin + if Option = "--debug" then + Simulation.Flag_Debugger := True; + else + return False; + end if; + return True; + end Decode_Option; + + procedure Disp_Long_Help + is + use Ada.Text_IO; + begin + Put_Line (" --debug Run with debugger"); + end Disp_Long_Help; + + procedure Register_Commands + is + begin + Ghdlcomp.Hooks := (Compile_Init'Access, + Compile_Elab'Access, + Set_Run_Options'Access, + Run'Access, + Decode_Option'Access, + Disp_Long_Help'Access); + Ghdlcomp.Register_Commands; + end Register_Commands; +end Ghdlsimul; diff --git a/src/translate/ghdldrv/ghdlsimul.ads b/src/translate/ghdldrv/ghdlsimul.ads new file mode 100644 index 0000000..264cbf8 --- /dev/null +++ b/src/translate/ghdldrv/ghdlsimul.ads @@ -0,0 +1,20 @@ +-- GHDL driver - simulator commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Ghdlsimul is + procedure Register_Commands; +end Ghdlsimul; diff --git a/src/translate/ghdldrv/grtlink.ads b/src/translate/ghdldrv/grtlink.ads new file mode 100644 index 0000000..4b3951e --- /dev/null +++ b/src/translate/ghdldrv/grtlink.ads @@ -0,0 +1,39 @@ +-- GHDL driver - shared variables with grt. +-- Copyright (C) 2011 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System; use System; + +package Grtlink is + + Flag_String : String (1 .. 5); + pragma Export (C, Flag_String, "__ghdl_flag_string"); + + Std_Standard_Bit_RTI_Ptr : Address := Null_Address; + + Std_Standard_Boolean_RTI_Ptr : Address := Null_Address; + + pragma Export (C, Std_Standard_Bit_RTI_Ptr, + "std__standard__bit__RTI_ptr"); + + pragma Export (C, Std_Standard_Boolean_RTI_Ptr, + "std__standard__boolean__RTI_ptr"); + + Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address := Null_Address; + pragma Export (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr, + "ieee__std_logic_1164__resolved_RESOLV_ptr"); + +end Grtlink; diff --git a/src/translate/grt/Makefile b/src/translate/grt/Makefile new file mode 100644 index 0000000..107aef7 --- /dev/null +++ b/src/translate/grt/Makefile @@ -0,0 +1,56 @@ +# -*- Makefile -*- for the GHDL Run Time library. +# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +# +# GHDL is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any later +# version. +# +# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING. If not, write to the Free +# Software Foundation, 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. +GRT_FLAGS=-g -O +GRT_ADAFLAGS=-gnatn + +ADAC=gcc +CC=gcc +GNATFLAGS=$(CFLAGS) -gnatf -gnaty3befhkmr -gnatwlu +GHDL1=../ghdl1-gcc +GRTSRCDIR=. +GRT_RANLIB=ranlib + +INSTALL=install +INSTALL_DATA=$(INSTALL) -m 644 + +prefix=/usr/local +exec_prefix=$(prefix) +libdir=$(exec_prefix)/lib +grt_libdir=$(libdir) + +target:=$(shell $(CC) -dumpmachine) + +all: grt-all +install: grt-install +clean: grt-clean + $(RM) *~ + +show_target: + echo "Target is $(target)" + +include Makefile.inc + + +GRT_CFLAGS=$(GRT_FLAGS) -Wall +ghwdump: ghwdump.o ghwlib.o + $(CC) $(GRT_CFLAGS) -o $@ ghwdump.o ghwlib.o + +ghwlib.o: ghwlib.c ghwlib.h + $(CC) -c $(GRT_CFLAGS) -o $@ $< +ghwdump.o: ghwdump.c ghwlib.h + $(CC) -c $(GRT_CFLAGS) -o $@ $< diff --git a/src/translate/grt/Makefile.inc b/src/translate/grt/Makefile.inc new file mode 100644 index 0000000..ec1b0df --- /dev/null +++ b/src/translate/grt/Makefile.inc @@ -0,0 +1,226 @@ +# -*- Makefile -*- for the GHDL Run Time library. +# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +# +# GHDL is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any later +# version. +# +# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING. If not, write to the Free +# Software Foundation, 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. + +# Variables used: +# AR: ar command +# RM +# CC +# ADAC: the GNAT compiler +# GHDL1: the ghdl compiler +# GRT_RANLIB: the ranlib tool for the grt library. +# grt_libdir: the place to put grt. +# GRTSRCDIR: the source directory of grt. +# target: GCC target +# GRT_FLAGS: common (Ada + C + asm) compilation flags. +# GRT_ADAFLAGS: compilation flags for Ada + +# Convert the target variable into a space separated list of architecture, +# manufacturer, and operating system and assign each of those to its own +# variable. + +target1:=$(subst -gnu,,$(target)) +targ:=$(subst -, ,$(target1)) +arch:=$(word 1,$(targ)) +ifeq ($(words $(targ)),2) + osys:=$(word 2,$(targ)) +else + osys:=$(word 3,$(targ)) +endif + +GRT_ELF_OPTS:=-Wl,--version-script=@/grt.ver -Wl,--export-dynamic + +# Set target files. +ifeq ($(filter-out i%86 linux,$(arch) $(osys)),) + GRT_TARGET_OBJS=i386.o linux.o times.o + GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) +endif +ifeq ($(filter-out x86_64 linux,$(arch) $(osys)),) + GRT_TARGET_OBJS=amd64.o linux.o times.o + GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) +endif +ifeq ($(filter-out i%86 freebsd%,$(arch) $(osys)),) + GRT_TARGET_OBJS=i386.o linux.o times.o + GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS) + ADAC=ada +endif +ifeq ($(filter-out x86_64 freebsd%,$(arch) $(osys)),) + GRT_TARGET_OBJS=amd64.o linux.o times.o + GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS) + ADAC=ada +endif +ifeq ($(filter-out i%86 darwin%,$(arch) $(osys)),) + GRT_TARGET_OBJS=i386.o linux.o times.o + GRT_EXTRA_LIB= +endif +ifeq ($(filter-out x86_64 darwin%,$(arch) $(osys)),) + GRT_TARGET_OBJS=amd64.o linux.o times.o + GRT_EXTRA_LIB= +endif +ifeq ($(filter-out sparc solaris%,$(arch) $(osys)),) + GRT_TARGET_OBJS=sparc.o linux.o times.o + GRT_EXTRA_LIB=-ldl -lm +endif +ifeq ($(filter-out powerpc linux%,$(arch) $(osys)),) + GRT_TARGET_OBJS=ppc.o linux.o times.o + GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) +endif +ifeq ($(filter-out ia64 linux,$(arch) $(osys)),) + GRT_TARGET_OBJS=ia64.o linux.o times.o + GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) +endif +ifeq ($(filter-out i%86 mingw32,$(arch) $(osys)),) + GRT_TARGET_OBJS=win32.o clock.o +endif +# Doesn't work for unknown reasons. +#ifeq ($(filter-out i%86 cygwin,$(arch) $(osys)),) +# GRT_TARGET_OBJS=win32.o clock.o +#endif +# Fall-back: use a generic implementation based on pthreads. +ifndef GRT_TARGET_OBJS + GRT_TARGET_OBJS=pthread.o times.o + GRT_EXTRA_LIB=-lpthread -ldl -lm +endif + +# Additionnal object files (C or asm files). +GRT_ADD_OBJS:=$(GRT_TARGET_OBJS) grt-cbinding.o grt-cvpi.o + +#GRT_USE_PTHREADS=y +ifeq ($(GRT_USE_PTHREADS),y) + GRT_CFLAGS+=-DUSE_THREADS + GRT_ADD_OBJS+=grt-cthreads.o + GRT_EXTRA_LIB+=-lpthread +endif + +GRT_ARCH?=None + +# Configuration pragmas. +GRT_PRAGMA_FLAG=-gnatec$(GRTSRCDIR)/grt.adc -gnat05 + +# Rule to compile an Ada file. +GRT_ADACOMPILE=$(ADAC) -c $(GRT_FLAGS) $(GRT_PRAGMA_FLAG) -o $@ $< + +grt-all: libgrt.a grt.lst + +libgrt.a: $(GRT_ADD_OBJS) run-bind.o main.o grt-files # grt-arch.ads + $(RM) -f $@ + $(AR) rcv $@ `sed -e "/^-/d" < grt-files` $(GRT_ADD_OBJS) \ + run-bind.o main.o + $(GRT_RANLIB) $@ + +run-bind.adb: grt-force + gnatmake -c $(GNATFLAGS) -aI$(GRTSRCDIR) $(GRT_PRAGMA_FLAG) \ + ghdl_main $(GRT_ADAFLAGS) -cargs $(GRT_FLAGS) + gnatbind -Lgrt_ -o run-bind.adb -n ghdl_main.ali + +#system.ads: +# sed -e "/Configurable_Run_Time/s/False/True/" \ +# -e "/Suppress_Standard_Library/s/False/True/" \ +# < `$(ADAC) -print-file-name=adainclude/system.ads` > $@ + +run-bind.o: run-bind.adb + $(GRT_ADACOMPILE) + +main.o: $(GRTSRCDIR)/main.adb + $(GRT_ADACOMPILE) + +i386.o: $(GRTSRCDIR)/config/i386.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +chkstk.o: $(GRTSRCDIR)/config/chkstk.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +sparc.o: $(GRTSRCDIR)/config/sparc.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +ppc.o: $(GRTSRCDIR)/config/ppc.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +ia64.o: $(GRTSRCDIR)/config/ia64.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +amd64.o: $(GRTSRCDIR)/config/amd64.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +linux.o: $(GRTSRCDIR)/config/linux.c + $(CC) -c $(GRT_FLAGS) $(GRT_CFLAGS) -o $@ $< + +win32.o: $(GRTSRCDIR)/config/win32.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +win32thr.o: $(GRTSRCDIR)/config/win32thr.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +pthread.o: $(GRTSRCDIR)/config/pthread.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +times.o : $(GRTSRCDIR)/config/times.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +clock.o : $(GRTSRCDIR)/config/clock.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-cbinding.o: $(GRTSRCDIR)/grt-cbinding.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-cvpi.o: $(GRTSRCDIR)/grt-cvpi.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-cthreads.o: $(GRTSRCDIR)/grt-cthreads.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-disp-config: + @echo "target: $(target)" + @echo "targ: $(targ)" + @echo "arch: $(arch)" + @echo "osys: $(osys)" + +grt-files: run-bind.adb + sed -e "1,/-- *BEGIN/d" -e "/-- *END/,\$$d" \ + -e "s/ -- //" < $< > $@ + +grt-arch.ads: + echo "With Grt.Arch_$(GRT_ARCH);" > $@ + echo "Package Grt.Arch renames Grt.Arch_$(GRT_ARCH);" >> $@ + +# Remove local files (they are now in the libgrt library). +# Also, remove the -shared option, in order not to build a shared library +# instead of an executable. +# Also remove -lgnat and its associated -L flags. This appears to be required +# with GNAT GPL 2005. +grt-files.in: grt-files + sed -e "\!^./!d" -e "/-shared/d" -e "/-static/d" -e "/-lgnat/d" \ + -e "\X-L/Xd" < $< > $@ + +grt.lst: grt-files.in + echo "@/libgrt.a" > $@ +ifdef GRT_EXTRA_LIB + for i in $(GRT_EXTRA_LIB); do echo $$i >> $@; done +endif + cat $< >> $@ + +grt-install: libgrt.a grt.lst + $(INSTALL_DATA) libgrt.a $(DESTDIR)$(grt_libdir)/libgrt.a + $(INSTALL_DATA) grt.lst $(DESTDIR)$(grt_libdir)/grt.lst + +grt-force: + +grt-clean: grt-force + $(RM) *.o *.ali run-bind.adb run-bind.ads *.a std_standard.s + $(RM) grt-files grt-files.in grt.lst + +.PHONY: grt-all grt-force grt-clean grt-install diff --git a/src/translate/grt/config/Makefile b/src/translate/grt/config/Makefile new file mode 100644 index 0000000..7d5f57d --- /dev/null +++ b/src/translate/grt/config/Makefile @@ -0,0 +1,14 @@ +CFLAGS=-Wall -g + +#ARCH_OBJS=i386.o linux.o +ARCH_OBJS=ppc.o linux.o + +teststack: teststack.o $(ARCH_OBJS) + $(CC) -o $@ $< $(ARCH_OBJS) + +ppc.o: ppc.S + $(CC) -c -o $@ -g $< + +clean: + $(RM) -f *.o *~ teststack + diff --git a/src/translate/grt/config/amd64.S b/src/translate/grt/config/amd64.S new file mode 100644 index 0000000..0a7f004 --- /dev/null +++ b/src/translate/grt/config/amd64.S @@ -0,0 +1,131 @@ +/* GRT stack implementation for amd64 (x86_64) + Copyright (C) 2005 - 2014 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. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "amd64.S" + +#ifdef __ELF__ +#define ENTRY(func) .align 4; .globl func; .type func,@function; func: +#define END(func) .size func, . - func +#define NAME(name) name +#elif __APPLE__ +#define ENTRY(func) .align 4; .globl _##func; _##func: +#define END(func) +#define NAME(name) _##name +#else +#define ENTRY(func) .align 4; func: +#define END(func) +#define NAME(name) name +#endif + .text + + /* Function called to loop on the process. */ +ENTRY(grt_stack_loop) + mov 0(%rsp),%rdi + call *8(%rsp) + jmp NAME(grt_stack_loop) +END(grt_stack_loop) + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; + Args: FUNC (RDI), ARG (RSI) + */ +ENTRY(grt_stack_create) + /* Standard prologue. */ + pushq %rbp + movq %rsp,%rbp + /* Save args. */ + sub $0x10,%rsp + mov %rdi,-8(%rbp) + mov %rsi,-16(%rbp) + + /* Allocate the stack, and exit in case of failure */ + callq NAME(grt_stack_allocate) + test %rax,%rax + je .Ldone + + /* Note: %RAX contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + /* The function to be executed. */ + mov -8(%rbp), %rdi + mov %rdi, -8(%rax) + /* The argument. */ + mov -16(%rbp), %rsi + mov %rsi, -16(%rax) + /* The return function. Must be 8 mod 16. */ +#if __APPLE__ + movq _grt_stack_loop@GOTPCREL(%rip), %rsi + movq %rsi, -24(%rax) +#else + movq $grt_stack_loop, -24(%rax) +#endif + /* The context. */ + mov %rbp, -32(%rax) + mov %rbx, -40(%rax) + mov %r12, -48(%rax) + mov %r13, -56(%rax) + mov %r14, -64(%rax) + mov %r15, -72(%rax) + + /* Save the new stack pointer to the stack context. */ + lea -72(%rax), %rsi + mov %rsi, (%rax) + +.Ldone: + leave + ret +END(grt_stack_create) + + + + /* Arguments: TO (RDI), FROM (RSI) [VAL (RDX)] + Both are pointers to a stack_context. */ +ENTRY(grt_stack_switch) + /* Save call-used registers. */ + pushq %rbp + pushq %rbx + pushq %r12 + pushq %r13 + pushq %r14 + pushq %r15 + /* Save the current stack. */ + movq %rsp, (%rsi) + /* Stack switch. */ + movq (%rdi), %rsp + /* Restore call-used registers. */ + popq %r15 + popq %r14 + popq %r13 + popq %r12 + popq %rbx + popq %rbp + /* Return val. */ + movq %rdx, %rax + /* Run. */ + ret +END(grt_stack_switch) + + .ident "Written by T.Gingold" diff --git a/src/translate/grt/config/chkstk.S b/src/translate/grt/config/chkstk.S new file mode 100644 index 0000000..ab244d0 --- /dev/null +++ b/src/translate/grt/config/chkstk.S @@ -0,0 +1,53 @@ +/* GRT stack implementation for x86. + Copyright (C) 2002 - 2014 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. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "chkstk.S" + .version "01.01" + + .text + +#ifdef __APPLE__ +#define __chkstk ___chkstk +#endif + + /* Function called to loop on the process. */ + .align 4 +#ifdef __ELF__ + .type __chkstk,@function +#endif + .globl __chkstk +__chkstk: + testl %eax,%eax + je 0f + subl $4,%eax /* 4 bytes already used by call. */ + subl %eax,%esp + jmp *(%esp,%eax) +0: + ret +#ifdef __ELF__ + .size __chkstk, . - __chkstk +#endif + + .ident "Written by T.Gingold" diff --git a/src/translate/grt/config/clock.c b/src/translate/grt/config/clock.c new file mode 100644 index 0000000..242af60 --- /dev/null +++ b/src/translate/grt/config/clock.c @@ -0,0 +1,43 @@ +/* GRT C bindings for time. + Copyright (C) 2002 - 2014 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. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ +#include <time.h> + +int +grt_get_clk_tck (void) +{ + return CLOCKS_PER_SEC; +} + +void +grt_get_times (int *wall, int *user, int *sys) +{ + clock_t res; + + *wall = clock (); + *user = 0; + *sys = 0; +} + diff --git a/src/translate/grt/config/i386.S b/src/translate/grt/config/i386.S new file mode 100644 index 0000000..00d4719 --- /dev/null +++ b/src/translate/grt/config/i386.S @@ -0,0 +1,141 @@ +/* GRT stack implementation for x86. + Copyright (C) 2002 - 2014 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. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "i386.S" + .version "01.01" + + .text + +#ifdef __ELF__ +#define ENTRY(func) .align 4; .globl func; .type func,@function; func: +#define END(func) .size func, . - func +#define NAME(name) name +#elif __APPLE__ +#define ENTRY(func) .align 4; .globl _##func; _##func: +#define END(func) +#define NAME(name) _##name +#else +#define ENTRY(func) .align 4; func: +#define END(func) +#define NAME(name) name +#endif + + /* Function called to loop on the process. */ +ENTRY(grt_stack_loop) + call *4(%esp) + jmp NAME(grt_stack_loop) +END(grt_stack_loop) + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; + */ +ENTRY(grt_stack_create) + /* Standard prologue. */ + pushl %ebp + movl %esp,%ebp + /* Keep aligned (call + pushl + 8 = 16 bytes). */ + subl $8,%esp + + /* Allocate the stack, and exit in case of failure */ + call NAME(grt_stack_allocate) + testl %eax,%eax + je .Ldone + + /* Note: %EAX contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + /* The function to be executed. */ + movl 8(%ebp), %ecx + movl %ecx, -4(%eax) + /* The argument. */ + movl 12(%ebp), %ecx + movl %ecx, -8(%eax) + /* The return function. */ +#if __APPLE__ + call ___x86.get_pc_thunk.cx +L1$pb: + movl L_grt_stack_loop$non_lazy_ptr-L1$pb(%ecx), %ecx + movl %ecx,-12(%eax) +#else + movl $NAME(grt_stack_loop), -12(%eax) +#endif + /* The context. */ + movl %ebx, -16(%eax) + movl %esi, -20(%eax) + movl %edi, -24(%eax) + movl %ebp, -28(%eax) + + /* Save the new stack pointer to the stack context. */ + leal -28(%eax), %ecx + movl %ecx, (%eax) + +.Ldone: + leave + ret +END(grt_stack_create) + + + /* Arguments: TO, FROM + Both are pointers to a stack_context. */ +ENTRY(grt_stack_switch) + /* TO -> ECX. */ + movl 4(%esp), %ecx + /* FROM -> EDX. */ + movl 8(%esp), %edx + /* Save call-used registers. */ + pushl %ebx + pushl %esi + pushl %edi + pushl %ebp + /* Save the current stack. */ + movl %esp, (%edx) + /* Stack switch. */ + movl (%ecx), %esp + /* Restore call-used registers. */ + popl %ebp + popl %edi + popl %esi + popl %ebx + /* Run. */ + ret +END(grt_stack_switch) + + +#if __APPLE__ + .section __TEXT,__textcoal_nt,coalesced,pure_instructions + .weak_definition ___x86.get_pc_thunk.cx + .private_extern ___x86.get_pc_thunk.cx +___x86.get_pc_thunk.cx: + movl (%esp), %ecx + ret + + .section __IMPORT,__pointers,non_lazy_symbol_pointers +L_grt_stack_loop$non_lazy_ptr: + .indirect_symbol _grt_stack_loop + .long 0 +#endif + + .ident "Written by T.Gingold" diff --git a/src/translate/grt/config/ia64.S b/src/translate/grt/config/ia64.S new file mode 100644 index 0000000..9ce3800 --- /dev/null +++ b/src/translate/grt/config/ia64.S @@ -0,0 +1,331 @@ +/* GRT stack implementation for ia64. + Copyright (C) 2002 - 2014 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. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "ia64.S" + .pred.safe_across_calls p1-p5,p16-p63 + + .text + .align 16 + .proc grt_stack_loop +grt_stack_loop: + alloc r32 = ar.pfs, 0, 1, 1, 0 + .body + ;; +1: mov r33 = r4 + br.call.sptk.many b0 = b1 + ;; + br 1b + .endp + + frame_size = 480 + + .global grt_stack_switch# + .proc grt_stack_switch# + /* r32: struct stack_context *TO, r33: struct stack_context *FROM. */ + // Registers to be saved: + // ar.rsc, ar.bsp, ar.pfs, ar.lc, ar.rnat [5] + // gp, r4-r7 (+ Nat) [6] + // f2-f5, f16-f31 [20] + // p1-p5, p16-p63 [1] ??? + // b1-b5 [5] + // f2-f5, f16-f31 [20*16] +grt_stack_switch: + .prologue 2, 2 + .vframe r2 + { + alloc r31=ar.pfs, 2, 0, 0, 0 + mov r14 = ar.rsc + adds r12 = -frame_size, r12 + .body + ;; + } + // Save ar.rsc, ar.bsp, ar.pfs + { + st8 [r12] = r14 // sp + 0 <- ar.rsc + mov r15 = ar.bsp + adds r22 = (5*8), r12 + ;; + } + { + st8.spill [r22] = r1, 8 // sp + 40 <- r1 + ;; + st8.spill [r22] = r4, 8 // sp + 48 <- r4 + adds r20 = 8, r12 + ;; + } + st8 [r20] = r15, 8 // sp + 8 <- ar.bsp + st8.spill [r22] = r5, 8 // sp + 56 <- r5 + mov r15 = ar.lc + ;; + { + st8 [r20] = r31, 8 // sp + 16 <- ar.pfs + // Flush dirty registers to the backing store + flushrs + mov r14 = b0 + ;; + } + { + st8 [r20] = r15, 8 // sp + 24 <- ar.lc + // Set the RSE in enforced lazy mode. + mov ar.rsc = 0 + ;; + } + { + // Save sp. + st8 [r33] = r12 + mov r15 = ar.rnat + mov r16 = b1 + ;; + } + { + st8.spill [r22] = r6, 8 // sp + 64 <- r6 + st8 [r20] = r15, 64 // sp + 32 <- ar.rnat + ;; + } + { + st8.spill [r22] = r7, 16 // sp + 72 <- r7 + st8 [r20] = r14, 8 // sp + 96 <- b0 + mov r15 = b2 + ;; + } + { + mov r17 = ar.unat + ;; + st8 [r22] = r17, 24 // sp + 88 <- ar.unat + mov r14 = b3 + ;; + } + { + st8 [r20] = r16, 16 // sp + 104 <- b1 + st8 [r22] = r15, 16 // sp + 112 <- b2 + mov r17 = b4 + ;; + } + { + st8 [r20] = r14, 16 // sp + 120 <- b3 + st8 [r22] = r17, 16 // sp + 128 <- b4 + mov r15 = b5 + ;; + } + { + // Read new sp. + ld8 r21 = [r32] + ;; + st8 [r20] = r15, 24 // sp + 136 <- b5 + mov r14 = pr + ;; + } + ;; + st8 [r22] = r14, 32 // sp + 144 <- pr + stf.spill [r20] = f2, 32 // sp + 160 <- f2 + ;; + stf.spill [r22] = f3, 32 // sp + 176 <- f3 + stf.spill [r20] = f4, 32 // sp + 192 <- f4 + ;; + stf.spill [r22] = f5, 32 // sp + 208 <- f5 + stf.spill [r20] = f16, 32 // sp + 224 <- f16 + ;; + stf.spill [r22] = f17, 32 // sp + 240 <- f17 + stf.spill [r20] = f18, 32 // sp + 256 <- f18 + ;; + stf.spill [r22] = f19, 32 // sp + 272 <- f19 + stf.spill [r20] = f20, 32 // sp + 288 <- f20 + ;; + stf.spill [r22] = f21, 32 // sp + 304 <- f21 + stf.spill [r20] = f22, 32 // sp + 320 <- f22 + ;; + stf.spill [r22] = f23, 32 // sp + 336 <- f23 + stf.spill [r20] = f24, 32 // sp + 352 <- f24 + ;; + stf.spill [r22] = f25, 32 // sp + 368 <- f25 + stf.spill [r20] = f26, 32 // sp + 384 <- f26 + ;; + stf.spill [r22] = f27, 32 // sp + 400 <- f27 + stf.spill [r20] = f28, 32 // sp + 416 <- f28 + ;; + stf.spill [r22] = f29, 32 // sp + 432 <- f29 + stf.spill [r20] = f30, 32 // sp + 448 <- f30 + ;; + { + stf.spill [r22] = f31, 32 // sp + 464 <- f31 + invala + adds r20 = 8, r21 + ;; + } + ld8 r14 = [r21], 88 // sp + 0 (ar.rsc) + ld8 r16 = [r20], 8 // sp + 8 (ar.bsp) + ;; + ld8 r15 = [r21], -56 // sp + 88 (ar.unat) + ;; + ld8 r18 = [r20], 8 // sp + 16 (ar.pfs) + mov ar.unat = r15 + ld8 r17 = [r21], 8 // sp + 32 (ar.rnat) + ;; + ld8 r15 = [r20], 72 // sp + 24 (ar.lc) + ld8.fill r1 = [r21], 8 // sp + 40 (r1) + mov ar.bspstore = r16 + ;; + ld8.fill r4 = [r21], 8 // sp + 48 (r4) + mov ar.pfs = r18 + mov ar.rnat = r17 + ;; + mov ar.rsc = r14 + mov ar.lc = r15 + ld8 r17 = [r20], 8 // sp + 96 (b0) + ;; + { + ld8.fill r5 = [r21], 8 // sp + 56 (r5) + ld8 r14 = [r20], 8 // sp + 104 (b1) + mov b0 = r17 + ;; + } + { + ld8.fill r6 = [r21], 8 // sp + 64 (r6) + ld8 r15 = [r20], 8 // sp + 112 (b2) + mov b1 = r14 + ;; + } + ld8.fill r7 = [r21], 64 // sp + 72 (r7) + ld8 r14 = [r20], 8 // sp + 120 (b3) + mov b2 = r15 + ;; + ld8 r15 = [r20], 16 // sp + 128 (b4) + ld8 r16 = [r21], 40 // sp + 136 (b5) + mov b3 = r14 + ;; + { + ld8 r14 = [r20], 16 // sp + 144 (pr) + ;; + ldf.fill f2 = [r20], 32 // sp + 160 (f2) + mov b4 = r15 + ;; + } + ldf.fill f3 = [r21], 32 // sp + 176 (f3) + ldf.fill f4 = [r20], 32 // sp + 192 (f4) + mov b5 = r16 + ;; + ldf.fill f5 = [r21], 32 // sp + 208 (f5) + ldf.fill f16 = [r20], 32 // sp + 224 (f16) + mov pr = r14, -1 + ;; + ldf.fill f17 = [r21], 32 // sp + 240 (f17) + ldf.fill f18 = [r20], 32 // sp + 256 (f18) + ;; + ldf.fill f19 = [r21], 32 // sp + 272 (f19) + ldf.fill f20 = [r20], 32 // sp + 288 (f20) + ;; + ldf.fill f21 = [r21], 32 // sp + 304 (f21) + ldf.fill f22 = [r20], 32 // sp + 320 (f22) + ;; + ldf.fill f23 = [r21], 32 // sp + 336 (f23) + ldf.fill f24 = [r20], 32 // sp + 352 (f24) + ;; + ldf.fill f25 = [r21], 32 // sp + 368 (f25) + ldf.fill f26 = [r20], 32 // sp + 384 (f26) + ;; + ldf.fill f27 = [r21], 32 // sp + 400 (f27) + ldf.fill f28 = [r20], 32 // sp + 416 (f28) + ;; + ldf.fill f29 = [r21], 32 // sp + 432 (f29) + ldf.fill f30 = [r20], 32 // sp + 448 (f30) + ;; + ldf.fill f31 = [r21], 32 // sp + 464 (f31) + mov r12 = r20 + br.ret.sptk.many b0 + ;; + .endp grt_stack_switch# + + .align 16 + // r32: func, r33: arg + .global grt_stack_create# + .proc grt_stack_create# +grt_stack_create: + .prologue 14, 34 + .save ar.pfs, r35 + alloc r35 = ar.pfs, 2, 3, 0, 0 + .save rp, r34 + // Compute backing store. + movl r14 = stack_max_size + ;; + .body + { + ld4 r36 = [r14] // r14: bsp + mov r34 = b0 + br.call.sptk.many b0 = grt_stack_allocate# + ;; + } + { + ld8 r22 = [r32], 8 // read ip (-> b1) + ;; + ld8 r23 = [r32] // read r1 from func + adds r21 = -(frame_size + 16) + 32, r8 + ;; + } + { + st8 [r21] = r0, -32 // sp + 32 (ar.rnat = 0) + ;; + st8 [r8] = r21 // Save cur_sp + mov r18 = 0x0f // ar.rsc: LE, PL=3, Eager + ;; + } + { + st8 [r21] = r18, 40 // sp + 0 (ar.rsc) + ;; + st8 [r21] = r23, 64 // sp + 40 (r1 = func.r1) + mov b0 = r34 + ;; + } + { + st8 [r21] = r22, -96 // sp + 104 (b1 = func.ip) + movl r15 = grt_stack_loop + ;; + } + sub r14 = r8, r36 // Backing store base + ;; + adds r14 = 16, r14 // Add sizeof (stack_context) + adds r20 = 40, r21 + ;; + { + st8 [r21] = r14, 88 // sp + 8 (ar.bsp) + ;; + st8 [r21] = r15, -80 // sp + 96 (b0 = grt_stack_loop) + mov r16 = (0 << 7) | 1 // CFM: sol=0, sof=1 + ;; + } + { + st8 [r21] = r16, 8 // sp + 16 (ar.pfs) + ;; + st8 [r21] = r0, 24 // sp + 24 (ar.lc) + mov ar.pfs = r35 + ;; + } + { + st8 [r20] = r0, 8 // sp + 32 (ar.rnat) + st8 [r21] = r33 // sp + 48 (r4 = arg) + br.ret.sptk.many b0 + ;; + } + .endp grt_stack_create# + .ident "GCC: (GNU) 4.0.2" diff --git a/src/translate/grt/config/linux.c b/src/translate/grt/config/linux.c new file mode 100644 index 0000000..74dce09 --- /dev/null +++ b/src/translate/grt/config/linux.c @@ -0,0 +1,361 @@ +/* GRT stacks implementation for linux and other *nix. + Copyright (C) 2002 - 2014 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. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ +#define _GNU_SOURCE +#include <unistd.h> +#include <sys/mman.h> +#include <signal.h> +#include <fcntl.h> +#include <sys/ucontext.h> +#include <stdlib.h> +//#include <stdint.h> + +#ifdef __APPLE__ +#define MAP_ANONYMOUS MAP_ANON +#endif + +/* On x86, the stack growns downward. */ +#define STACK_GROWNS_DOWNWARD 1 + +#ifdef __linux__ +/* If set, SIGSEGV is caught in order to automatically grow the stacks. */ +#define EXTEND_STACK 1 +#define STACK_SIGNAL SIGSEGV +#endif +#ifdef __FreeBSD__ +/* If set, SIGSEGV is caught in order to automatically grow the stacks. */ +#define EXTEND_STACK 1 +#define STACK_SIGNAL SIGSEGV +#endif +#ifdef __APPLE__ +/* If set, SIGSEGV is caught in order to automatically grow the stacks. */ +#define EXTEND_STACK 1 +#define STACK_SIGNAL SIGBUS +#endif + +/* Defined in Grt.Options. */ +extern unsigned int stack_size; +extern unsigned int stack_max_size; + +/* Size of a memory page. */ +static size_t page_size; + +extern void grt_stack_error_grow_failed (void); +extern void grt_stack_error_null_access (void); +extern void grt_stack_error_memory_access (void); +extern void grt_overflow_error (void); + +/* Definitions: + The base of the stack is the address before the first available byte on the + stack. If the stack grows downward, the base is equal to the high bound. +*/ + +/* Per stack context. + This context is allocated at the top (or bottom if the stack grows + upward) of the stack. + Therefore, the base of the stack can be easily deduced from the context. */ +struct stack_context +{ + /* The current stack pointer. */ + void *cur_sp; + /* The current stack length. */ + size_t cur_length; +}; + +/* If MAP_ANONYMOUS is not defined, use /dev/zero. */ +#ifndef MAP_ANONYMOUS +#define USE_DEV_ZERO +static int dev_zero_fd; +#define MAP_ANONYMOUS 0 +#define MMAP_FILEDES dev_zero_fd +#else +#define MMAP_FILEDES -1 +#endif + +#if EXTEND_STACK +/* This is the current process being run. */ +extern struct stack_context *grt_get_current_process (void); + +/* Stack used for signals. + The stack must be different from the running stack, because we want to be + able to extend the running stack. When the stack need to be extended, the + current stack pointer does not point to a valid address. Therefore, the + stack cannot be used or else a second SIGSEGV is generated while the + arguments are pushed. */ +static unsigned long sig_stack[SIGSTKSZ / sizeof (long)]; + +/* Signal stack descriptor. */ +static stack_t sig_stk; + +static struct sigaction prev_sigsegv_act; +static struct sigaction sigsegv_act; + +/* The following code assumes stack grows downward. */ +#if !STACK_GROWNS_DOWNWARD +#error "Not implemented" +#endif + +#ifdef __APPLE__ +/* Handler for SIGFPE signal, raised in case of overflow (i386). */ +static void grt_overflow_handler (int signo, siginfo_t *info, void *ptr) +{ + grt_overflow_error (); +} +#endif + +/* Handler for SIGSEGV signal, which grow the stack. */ +static void grt_sigsegv_handler (int signo, siginfo_t *info, void *ptr) +{ + static int in_handler; + void *addr; + struct stack_context *ctxt; + void *stack_high; + void *stack_low; + void *n_low; + size_t n_len; + ucontext_t *uctxt = (ucontext_t *)ptr; + + in_handler++; + +#ifdef __linux__ +#ifdef __i386__ + /* Linux generates a SIGSEGV (!) for an overflow exception. */ + if (uctxt->uc_mcontext.gregs[REG_TRAPNO] == 4) + { + grt_overflow_error (); + } +#endif +#endif + + if (info == NULL || grt_get_current_process () == NULL || in_handler > 1) + { + /* We loose. */ + sigaction (STACK_SIGNAL, &prev_sigsegv_act, NULL); + return; + } + + addr = info->si_addr; + + /* Check ADDR belong to the stack. */ + ctxt = grt_get_current_process ()->cur_sp; + stack_high = (void *)(ctxt + 1); + stack_low = stack_high - stack_max_size; + if (addr > stack_high || addr < stack_low) + { + /* Out of the stack. */ + if (addr < (void *)page_size) + grt_stack_error_null_access (); + else + grt_stack_error_memory_access (); + } + /* Compute the address of the faulting page. */ + n_low = (void *)((unsigned long)addr & ~(page_size - 1)); + + /* Should not happen. */ + if (n_low < stack_low) + abort (); + + /* Allocate one more page, if possible. */ + if (n_low != stack_low) + n_low -= page_size; + + /* Compute the new length. */ + n_len = stack_high - n_low; + + if (mmap (n_low, n_len - ctxt->cur_length, PROT_READ | PROT_WRITE, + MAP_FIXED | MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0) + != n_low) + { + /* Cannot grow the stack. */ + grt_stack_error_grow_failed (); + } + + ctxt->cur_length = n_len; + + sigaction (STACK_SIGNAL, &sigsegv_act, NULL); + + in_handler--; + + /* Hopes we can resume! */ + return; +} + +static void grt_signal_setup (void) +{ + sigsegv_act.sa_sigaction = &grt_sigsegv_handler; + sigemptyset (&sigsegv_act.sa_mask); + sigsegv_act.sa_flags = SA_ONSTACK | SA_SIGINFO; +#ifdef SA_ONESHOT + sigsegv_act.sa_flags |= SA_ONESHOT; +#elif defined (SA_RESETHAND) + sigsegv_act.sa_flags |= SA_RESETHAND; +#endif + + /* Use an alternate stack during signals. */ + sig_stk.ss_sp = sig_stack; + sig_stk.ss_size = sizeof (sig_stack); + sig_stk.ss_flags = 0; + sigaltstack (&sig_stk, NULL); + + /* We don't care about the return status. + If the handler is not installed, then some feature are lost. */ + sigaction (STACK_SIGNAL, &sigsegv_act, &prev_sigsegv_act); + +#ifdef __APPLE__ + { + struct sigaction sig_ovf_act; + + sig_ovf_act.sa_sigaction = &grt_overflow_handler; + sigemptyset (&sig_ovf_act.sa_mask); + sig_ovf_act.sa_flags = SA_SIGINFO; + + sigaction (SIGFPE, &sig_ovf_act, NULL); + } +#endif +} +#endif + +/* Context for the main stack. */ +#ifdef USE_THREADS +#define THREAD __thread +#else +#define THREAD +#endif +static THREAD struct stack_context main_stack_context; + +extern void grt_set_main_stack (struct stack_context *stack); + +void +grt_stack_new_thread (void) +{ + main_stack_context.cur_sp = NULL; + main_stack_context.cur_length = 0; + grt_set_main_stack (&main_stack_context); +} + +void +grt_stack_init (void) +{ + size_t pg_round; + + page_size = getpagesize (); + pg_round = page_size - 1; + + /* Align size. */ + stack_size = (stack_size + pg_round) & ~pg_round; + stack_max_size = (stack_max_size + pg_round) & ~pg_round; + + /* Set mimum values. */ + if (stack_size < 2 * page_size) + stack_size = 2 * page_size; + if (stack_max_size < (stack_size + 2 * page_size)) + stack_max_size = stack_size + 2 * page_size; + + /* Initialize the main stack context. */ + main_stack_context.cur_sp = NULL; + main_stack_context.cur_length = 0; + grt_set_main_stack (&main_stack_context); + +#ifdef USE_DEV_ZERO + dev_zero_fd = open ("/dev/zero", O_RDWR); + if (dev_zero_fd < 0) + abort (); +#endif + +#if EXTEND_STACK + grt_signal_setup (); +#endif +} + +/* Allocate a stack. + Called by i386.S */ +struct stack_context * +grt_stack_allocate (void) +{ + struct stack_context *res; + void *r; + void *base; + + /* Allocate the stack, but without any rights. This is a guard. */ + base = (void *)mmap (NULL, stack_max_size, PROT_NONE, + MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0); + + if (base == (void *)-1) + return NULL; + + /* Set rights on the allocated stack. */ +#if STACK_GROWNS_DOWNWARD + r = base + stack_max_size - stack_size; +#else + r = base; +#endif + if (mmap (r, stack_size, PROT_READ | PROT_WRITE, + MAP_FIXED | MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0) + != r) + return NULL; + +#if STACK_GROWNS_DOWNWARD + res = (struct stack_context *) + (base + stack_max_size - sizeof (struct stack_context)); +#else + res = (struct stack_context *)(base + sizeof (struct stack_context)); +#endif + +#ifdef __ia64__ + /* Also allocate BSP. */ + if (mmap (base, page_size, PROT_READ | PROT_WRITE, + MAP_FIXED | MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0) != base) + return NULL; +#endif + + res->cur_sp = (void *)res; + res->cur_length = stack_size; + return res; +} + +#include <setjmp.h> +static int run_env_en; +static jmp_buf run_env; + +void +__ghdl_maybe_return_via_longjump (int val) +{ + if (run_env_en) + longjmp (run_env, val); +} + +int +__ghdl_run_through_longjump (int (*func)(void)) +{ + int res; + + run_env_en = 1; + res = setjmp (run_env); + if (res == 0) + res = (*func)(); + run_env_en = 0; + return res; +} + diff --git a/src/translate/grt/config/ppc.S b/src/translate/grt/config/ppc.S new file mode 100644 index 0000000..bedd48a --- /dev/null +++ b/src/translate/grt/config/ppc.S @@ -0,0 +1,334 @@ +/* GRT stack implementation for ppc. + Copyright (C) 2005 - 2014 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. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "ppc.S" + + .section ".text" + +#define OFF 240 + +#define GREG(x) x +#define FREG(x) x + +#define r0 GREG(0) +#define r1 GREG(1) +#define r2 GREG(2) +#define r3 GREG(3) +#define r4 GREG(4) +#define r5 GREG(5) +#define r6 GREG(6) +#define r7 GREG(7) +#define r8 GREG(8) +#define r9 GREG(9) +#define r10 GREG(10) +#define r11 GREG(11) +#define r12 GREG(12) +#define r13 GREG(13) +#define r14 GREG(14) +#define r15 GREG(15) +#define r16 GREG(16) +#define r17 GREG(17) +#define r18 GREG(18) +#define r19 GREG(19) +#define r20 GREG(20) +#define r21 GREG(21) +#define r22 GREG(22) +#define r23 GREG(23) +#define r24 GREG(24) +#define r25 GREG(25) +#define r26 GREG(26) +#define r27 GREG(27) +#define r28 GREG(28) +#define r29 GREG(29) +#define r30 GREG(30) +#define r31 GREG(31) + +#define f0 FREG(0) +#define f1 FREG(1) +#define f2 FREG(2) +#define f3 FREG(3) +#define f4 FREG(4) +#define f5 FREG(5) +#define f6 FREG(6) +#define f7 FREG(7) +#define f8 FREG(8) +#define f9 FREG(9) +#define f10 FREG(10) +#define f11 FREG(11) +#define f12 FREG(12) +#define f13 FREG(13) +#define f14 FREG(14) +#define f15 FREG(15) +#define f16 FREG(16) +#define f17 FREG(17) +#define f18 FREG(18) +#define f19 FREG(19) +#define f20 FREG(20) +#define f21 FREG(21) +#define f22 FREG(22) +#define f23 FREG(23) +#define f24 FREG(24) +#define f25 FREG(25) +#define f26 FREG(26) +#define f27 FREG(27) +#define f28 FREG(28) +#define f29 FREG(29) +#define f30 FREG(30) +#define f31 FREG(31) + + /* Stack structure is: + +4 : cur_length \ Stack + +0 : cur_sp / Context + -4 : arg + -8 : func + + -12: pad + -16: pad + -20: LR save word + -24: Back chain + + -28: fp/gp saved registers. + -4 : return address + -8 : process function to be executed + -12: function argument + ... + -72: %sp + */ + + /* Function called to loop on the process. */ + .align 4 + .type grt_stack_loop,@function +grt_stack_loop: + /* Get function. */ + lwz r0,16(r1) + /* Get argument. */ + lwz r3,20(r1) + mtlr r0 + blrl + b grt_stack_loop + .size grt_stack_loop, . - grt_stack_loop + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; */ + .align 4 + .global grt_stack_create + .type grt_stack_create,@function +grt_stack_create: + /* Standard prologue. */ + stwu r1,-32(r1) + mflr r0 + stw r0,36(r1) + + /* Save arguments. */ + stw r3,24(r1) + stw r4,28(r1) + + /* Allocate the stack, and exit in case of failure */ + bl grt_stack_allocate + cmpwi 0,r3,0 + beq- .Ldone + + /* Note: r3 contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + /* Align the stack. */ + addi r5,r3,-24 + + /* Save the parameters. */ + lwz r6,24(r1) + stw r6,16(r5) + lwz r7,28(r1) + stw r7,20(r5) + + /* The return function. */ + lis r4,grt_stack_loop@ha + la r4,grt_stack_loop@l(r4) + stw r4,4(r5) + /* Back-Chain. */ + addi r4,r1,32 + stw r4,0(r5) + + /* Save register. + They should be considered as garbage. */ + addi r4,r5,-OFF + + stfd f31,(OFF - 8)(r4) + stfd f30,(OFF - 16)(r4) + stfd f29,(OFF - 24)(r4) + stfd f28,(OFF - 32)(r4) + stfd f27,(OFF - 40)(r4) + stfd f26,(OFF - 48)(r4) + stfd f25,(OFF - 56)(r4) + stfd f24,(OFF - 64)(r4) + stfd f23,(OFF - 72)(r4) + stfd f22,(OFF - 80)(r4) + stfd f21,(OFF - 88)(r4) + stfd f20,(OFF - 96)(r4) + stfd f19,(OFF - 104)(r4) + stfd f18,(OFF - 112)(r4) + stfd f17,(OFF - 120)(r4) + stfd f16,(OFF - 128)(r4) + stfd f15,(OFF - 136)(r4) + stfd f14,(OFF - 144)(r4) + stw r31,(OFF - 148)(r4) + stw r30,(OFF - 152)(r4) + stw r29,(OFF - 156)(r4) + stw r28,(OFF - 160)(r4) + stw r27,(OFF - 164)(r4) + stw r26,(OFF - 168)(r4) + stw r25,(OFF - 172)(r4) + stw r24,(OFF - 176)(r4) + stw r23,(OFF - 180)(r4) + stw r22,(OFF - 184)(r4) + stw r21,(OFF - 188)(r4) + stw r20,(OFF - 192)(r4) + stw r19,(OFF - 196)(r4) + stw r18,(OFF - 200)(r4) + stw r17,(OFF - 204)(r4) + stw r16,(OFF - 208)(r4) + stw r15,(OFF - 212)(r4) + stw r14,(OFF - 216)(r4) + mfcr r0 + stw r0, (OFF - 220)(r4) + + /* Save stack pointer. */ + stw r4, 0(r3) + +.Ldone: + lwz r0,36(r1) + mtlr r0 + addi r1,r1,32 + blr + .size grt_stack_create,. - grt_stack_create + + + .align 4 + .global grt_stack_switch + /* Arguments: TO, FROM. + Both are pointers to a stack_context. */ + .type grt_stack_switch,@function +grt_stack_switch: + /* Standard prologue, save return address. */ + stwu r1,(-OFF)(r1) + mflr r0 + stw r0,(OFF + 4)(r1) + + /* Save r14-r31, f14-f31, CR + This is 18 words + 18 double words, ie 216 bytes. */ + /* Maybe use the savefpr function ? */ + stfd f31,(OFF - 8)(r1) + stfd f30,(OFF - 16)(r1) + stfd f29,(OFF - 24)(r1) + stfd f28,(OFF - 32)(r1) + stfd f27,(OFF - 40)(r1) + stfd f26,(OFF - 48)(r1) + stfd f25,(OFF - 56)(r1) + stfd f24,(OFF - 64)(r1) + stfd f23,(OFF - 72)(r1) + stfd f22,(OFF - 80)(r1) + stfd f21,(OFF - 88)(r1) + stfd f20,(OFF - 96)(r1) + stfd f19,(OFF - 104)(r1) + stfd f18,(OFF - 112)(r1) + stfd f17,(OFF - 120)(r1) + stfd f16,(OFF - 128)(r1) + stfd f15,(OFF - 136)(r1) + stfd f14,(OFF - 144)(r1) + stw r31,(OFF - 148)(r1) + stw r30,(OFF - 152)(r1) + stw r29,(OFF - 156)(r1) + stw r28,(OFF - 160)(r1) + stw r27,(OFF - 164)(r1) + stw r26,(OFF - 168)(r1) + stw r25,(OFF - 172)(r1) + stw r24,(OFF - 176)(r1) + stw r23,(OFF - 180)(r1) + stw r22,(OFF - 184)(r1) + stw r21,(OFF - 188)(r1) + stw r20,(OFF - 192)(r1) + stw r19,(OFF - 196)(r1) + stw r18,(OFF - 200)(r1) + stw r17,(OFF - 204)(r1) + stw r16,(OFF - 208)(r1) + stw r15,(OFF - 212)(r1) + stw r14,(OFF - 216)(r1) + mfcr r0 + stw r0, (OFF - 220)(r1) + + /* Save stack pointer. */ + stw r1, 0(r4) + + /* Load stack pointer. */ + lwz r1, 0(r3) + + + lfd f31,(OFF - 8)(r1) + lfd f30,(OFF - 16)(r1) + lfd f29,(OFF - 24)(r1) + lfd f28,(OFF - 32)(r1) + lfd f27,(OFF - 40)(r1) + lfd f26,(OFF - 48)(r1) + lfd f25,(OFF - 56)(r1) + lfd f24,(OFF - 64)(r1) + lfd f23,(OFF - 72)(r1) + lfd f22,(OFF - 80)(r1) + lfd f21,(OFF - 88)(r1) + lfd f20,(OFF - 96)(r1) + lfd f19,(OFF - 104)(r1) + lfd f18,(OFF - 112)(r1) + lfd f17,(OFF - 120)(r1) + lfd f16,(OFF - 128)(r1) + lfd f15,(OFF - 136)(r1) + lfd f14,(OFF - 144)(r1) + lwz r31,(OFF - 148)(r1) + lwz r30,(OFF - 152)(r1) + lwz r29,(OFF - 156)(r1) + lwz r28,(OFF - 160)(r1) + lwz r27,(OFF - 164)(r1) + lwz r26,(OFF - 168)(r1) + lwz r25,(OFF - 172)(r1) + lwz r24,(OFF - 176)(r1) + lwz r23,(OFF - 180)(r1) + lwz r22,(OFF - 184)(r1) + lwz r21,(OFF - 188)(r1) + lwz r20,(OFF - 192)(r1) + lwz r19,(OFF - 196)(r1) + lwz r18,(OFF - 200)(r1) + lwz r17,(OFF - 204)(r1) + lwz r16,(OFF - 208)(r1) + lwz r15,(OFF - 212)(r1) + lwz r14,(OFF - 216)(r1) + lwz r0, (OFF - 220)(r1) + mtcr r0 + + lwz r0,(OFF + 4)(r1) + mtlr r0 + addi r1,r1,OFF + blr + .size grt_stack_switch, . - grt_stack_switch + + + .ident "Written by T.Gingold" diff --git a/src/translate/grt/config/pthread.c b/src/translate/grt/config/pthread.c new file mode 100644 index 0000000..189ae90 --- /dev/null +++ b/src/translate/grt/config/pthread.c @@ -0,0 +1,239 @@ +/* GRT stack implementation based on pthreads. + Copyright (C) 2003 - 2014 Felix Bertram & 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. +*/ +//----------------------------------------------------------------------------- +// Project: GHDL - VHDL Simulator +// Description: pthread port of stacks package, for use with MacOSX +// Note: Tristan's original i386/Linux used assembly-code +// to manually switch stacks for performance reasons. +// History: 2003may22, FB, created. +//----------------------------------------------------------------------------- + +#include <pthread.h> +#include <stdlib.h> +#include <stdio.h> +#include <setjmp.h> +#include <assert.h> + +//#define INFO printf +#define INFO (void) + +// GHDL names an endless loop calling FUNC with ARG a 'stack' +// at a given time, only one stack may be 'executed' +typedef struct +{ + pthread_t thread; // stack's thread + pthread_mutex_t mutex; // mutex to suspend/resume thread +#if defined(__CYGWIN__) + pthread_mutexattr_t mxAttr; +#endif + void (*Func)(void*); // stack's FUNC + void* Arg; // ARG passed to FUNC +} Stack_Type_t, *Stack_Type; + +static Stack_Type_t main_stack_context; +static Stack_Type_t *current; +extern void grt_set_main_stack (Stack_Type_t *stack); + +//---------------------------------------------------------------------------- +void grt_stack_init(void) +// Initialize the stacks package. +// This may adjust stack sizes. +// Must be called after grt.options.decode. +// => procedure Stack_Init; +{ + int res; + INFO("grt_stack_init\n"); + INFO(" main_stack_context=0x%08x\n", &main_stack_context); + + +#if defined(__CYGWIN__) + res = pthread_mutexattr_init (&main_stack_context.mxAttr); + assert (res == 0); + res = pthread_mutexattr_settype (&main_stack_context.mxAttr, + PTHREAD_MUTEX_DEFAULT); + assert (res == 0); + res = pthread_mutex_init (&main_stack_context.mutex, + &main_stack_context.mxAttr); + assert (res == 0); +#else + res = pthread_mutex_init (&main_stack_context.mutex, NULL); + assert (res == 0); +#endif + // lock the mutex, as we are currently running + res = pthread_mutex_lock (&main_stack_context.mutex); + assert (res == 0); + + current = &main_stack_context; + + grt_set_main_stack (&main_stack_context); +} + +//---------------------------------------------------------------------------- +static void* grt_stack_loop(void* pv_myStack) +{ + Stack_Type myStack= (Stack_Type)pv_myStack; + + INFO("grt_stack_loop\n"); + + INFO(" myStack=0x%08x\n", myStack); + + // block until mutex becomes available again. + // this happens when this stack is enabled for the first time + pthread_mutex_lock(&(myStack->mutex)); + + // run stack's function in endless loop + while(1) + { + INFO(" call 0x%08x with 0x%08x\n", myStack->Func, myStack->Arg); + myStack->Func(myStack->Arg); + } + + // we never get here... + return 0; +} + +//---------------------------------------------------------------------------- +Stack_Type grt_stack_create(void* Func, void* Arg) +// Create a new stack, which on first execution will call FUNC with +// an argument ARG. +// => function Stack_Create (Func : Address; Arg : Address) return Stack_Type; +{ + Stack_Type newStack; + int res; + + INFO("grt_stack_create\n"); + INFO(" call 0x%08x with 0x%08x\n", Func, Arg); + + newStack = malloc (sizeof(Stack_Type_t)); + + // init function and argument + newStack->Func = Func; + newStack->Arg = Arg; + + // create mutex +#if defined(__CYGWIN__) + res = pthread_mutexattr_init (&newStack->mxAttr); + assert (res == 0); + res = pthread_mutexattr_settype (&newStack->mxAttr, PTHREAD_MUTEX_DEFAULT); + assert (res == 0); + res = pthread_mutex_init (&newStack->mutex, &newStack->mxAttr); + assert (res == 0); +#else + res = pthread_mutex_init (&newStack->mutex, NULL); + assert (res == 0); +#endif + + // block the mutex, so that thread will blocked in grt_stack_loop + res = pthread_mutex_lock (&newStack->mutex); + assert (res == 0); + + INFO(" newStack=0x%08x\n", newStack); + + // create thread, which executes grt_stack_loop + pthread_create (&newStack->thread, NULL, grt_stack_loop, newStack); + + return newStack; +} + +static int need_longjmp; +static int run_env_en; +static jmp_buf run_env; + +//---------------------------------------------------------------------------- +void grt_stack_switch(Stack_Type To, Stack_Type From) +// Resume stack TO and save the current context to the stack pointed by +// CUR. +// => procedure Stack_Switch (To : Stack_Type; From : Stack_Type); +{ + int res; + INFO("grt_stack_switch\n"); + INFO(" from 0x%08x to 0x%08x\n", From, To); + + current = To; + + // unlock 'To' mutex. this will make the other thread either + // - starts for first time in grt_stack_loop + // - resumes at lock below + res = pthread_mutex_unlock (&To->mutex); + assert (res == 0); + + // block until 'From' mutex becomes available again + // as we are running, our mutex is locked and we block here + // when stacks are switched, with above unlock, we may proceed + res = pthread_mutex_lock (&From->mutex); + assert (res == 0); + + if (From == &main_stack_context && need_longjmp != 0) + longjmp (run_env, need_longjmp); +} + +//---------------------------------------------------------------------------- +void grt_stack_delete(Stack_Type Stack) +// Delete stack STACK, which must not be currently executed. +// => procedure Stack_Delete (Stack : Stack_Type); +{ + INFO("grt_stack_delete\n"); +} + +void +__ghdl_maybe_return_via_longjump (int val) +{ + if (!run_env_en) + return; + + if (current != &main_stack_context) + { + need_longjmp = val; + grt_stack_switch (&main_stack_context, current); + } + else + longjmp (run_env, val); +} + +int +__ghdl_run_through_longjump (int (*func)(void)) +{ + int res; + + run_env_en = 1; + res = setjmp (run_env); + if (res == 0) + res = (*func)(); + run_env_en = 0; + return res; +} + + +//---------------------------------------------------------------------------- + +#ifndef WITH_GNAT_RUN_TIME +void __gnat_raise_storage_error(void) +{ + abort (); +} + +void __gnat_raise_program_error(void) +{ + abort (); +} +#endif /* WITH_GNAT_RUN_TIME */ + +//---------------------------------------------------------------------------- +// end of file + diff --git a/src/translate/grt/config/sparc.S b/src/translate/grt/config/sparc.S new file mode 100644 index 0000000..0ffe412 --- /dev/null +++ b/src/translate/grt/config/sparc.S @@ -0,0 +1,141 @@ +/* GRT stack implementation for x86. + Copyright (C) 2002 - 2014 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. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "sparc.S" + + .section ".text" + + /* Stack structure is: + +4 : cur_length + +0 : cur_sp + -4 : return address + -8 : process function to be executed + -12: function argument + ... + -72: %sp + */ + + /* Function called to loop on the process. */ + .align 4 + .type grt_stack_loop,#function +grt_stack_loop: + ld [%sp + 64], %o1 + jmpl %o1 + 0, %o7 + ld [%sp + 68], %o0 + ba grt_stack_loop + nop + .size grt_stack_loop, . - grt_stack_loop + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; */ + .align 4 + .global grt_stack_create + .type grt_stack_create,#function +grt_stack_create: + /* Standard prologue. */ + save %sp,-80,%sp + + /* Allocate the stack, and exit in case of failure */ + call grt_stack_allocate + nop + cmp %o0, 0 + be .Ldone + nop + + /* Note: %o0 contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + + /* The return function. */ + sethi %hi(grt_stack_loop - 8), %l2 + or %lo(grt_stack_loop - 8), %l2, %l2 + + /* Create a frame for grt_stack_loop. */ + sub %o0, (64 + 8), %l1 + + /* The function to be executed. */ + st %i0, [%l1 + 64] + /* The argument. */ + st %i1, [%l1 + 68] + + /* Create a frame for grt_stack_switch. */ + sub %l1, 64, %l0 + + /* Save frame pointer. */ + st %l1, [%l0 + 56] + /* Save return address. */ + st %l2, [%l0 + 60] + + /* Save stack pointer. */ + st %l0, [%o0] + +.Ldone: + ret + restore %o0, %g0, %o0 + .size grt_stack_create,. - grt_stack_create + + + .align 4 + .global grt_stack_switch + /* Arguments: TO, FROM. + Both are pointers to a stack_context. */ + .type grt_stack_switch,#function +grt_stack_switch: + /* Standard prologue. */ + save %sp,-80,%sp + + /* Flush and invalidate windows. + It is not clear wether the current window is saved or not, + therefore, I assume it is not. + */ + ta 3 + + /* Only IN registers %fp and %i7 (return address) must be saved. + Of course, I could use std/ldd, but it is not as clear + */ + /* Save current frame pointer. */ + st %fp, [%sp + 56] + /* Save return address. */ + st %i7, [%sp + 60] + + /* Save stack pointer. */ + st %sp, [%i1] + + /* Load stack pointer. */ + ld [%i0], %sp + + /* Load return address. */ + ld [%sp + 60], %i7 + /* Load frame pointer. */ + ld [%sp + 56], %fp + + /* Return. */ + ret + restore + .size grt_stack_switch, . - grt_stack_switch + + + .ident "Written by T.Gingold" diff --git a/src/translate/grt/config/teststack.c b/src/translate/grt/config/teststack.c new file mode 100644 index 0000000..6a6966d --- /dev/null +++ b/src/translate/grt/config/teststack.c @@ -0,0 +1,174 @@ +#include <stdlib.h> +#include <stdio.h> + +extern void grt_stack_init (void); +extern void grt_stack_switch (void *from, void *to); +extern void *grt_stack_create (void (*func)(void *), void *arg); + +int stack_size = 4096; +int stack_max_size = 8 * 4096; + +static void *stack1; +static void *stack2; +void *grt_stack_main_stack; + +void *grt_cur_proc; + +static int step; + +void +grt_overflow_error (void) +{ + abort (); +} + +void +grt_stack_error_null_access (void) +{ + abort (); +} + +void +grt_stack_error_memory_access (void) +{ + abort (); +} + +void +grt_stack_error_grow_failed (void) +{ + abort (); +} + +void +error (void) +{ + printf ("Test failure at step %d\n", step); + fflush (stdout); + exit (1); +} + +static void +func1 (void *ptr) +{ + if (ptr != (void *)1) + error (); + + if (step != 0) + error (); + + step = 1; + + grt_stack_switch (grt_stack_main_stack, stack1); + + if (step != 5) + error (); + + step = 6; + + grt_stack_switch (grt_stack_main_stack, stack1); + + if (step != 7) + error (); + + step = 8; + + grt_stack_switch (stack2, stack1); + + if (step != 9) + error (); + + step = 10; + + grt_stack_switch (grt_stack_main_stack, stack1); + + error (); +} + +static void +func2 (void *ptr) +{ + if (ptr != (void *)2) + error (); + + if (step == 11) + { + step = 12; + + grt_stack_switch (grt_stack_main_stack, stack2); + + error (); + } + + if (step != 1) + error (); + + step = 2; + + grt_stack_switch (grt_stack_main_stack, stack2); + + if (step != 3) + error (); + + step = 4; + + grt_stack_switch (grt_stack_main_stack, stack2); + + if (step != 8) + error (); + + step = 9; + + grt_stack_switch (stack1, stack2); +} + +int +main (void) +{ + grt_stack_init (); + + stack1 = grt_stack_create (&func1, (void *)1); + stack2 = grt_stack_create (&func2, (void *)2); + + step = 0; + grt_stack_switch (stack1, grt_stack_main_stack); + + if (step != 1) + error (); + + grt_stack_switch (stack2, grt_stack_main_stack); + + if (step != 2) + error (); + + step = 3; + + grt_stack_switch (stack2, grt_stack_main_stack); + + if (step != 4) + error (); + + step = 5; + + grt_stack_switch (stack1, grt_stack_main_stack); + + if (step != 6) + error (); + + step = 7; + + grt_stack_switch (stack1, grt_stack_main_stack); + + if (step != 10) + error (); + + step = 11; + + grt_stack_switch (stack2, grt_stack_main_stack); + + if (step != 12) + error (); + + printf ("Test successful\n"); + return 0; +} diff --git a/src/translate/grt/config/times.c b/src/translate/grt/config/times.c new file mode 100644 index 0000000..9c0b4eb --- /dev/null +++ b/src/translate/grt/config/times.c @@ -0,0 +1,55 @@ +/* GRT C bindings for time. + Copyright (C) 2002 - 2014 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. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ +#include <sys/times.h> +#include <unistd.h> + +int +grt_get_clk_tck (void) +{ + return sysconf (_SC_CLK_TCK); +} + +void +grt_get_times (int *wall, int *user, int *sys) +{ + clock_t res; + struct tms buf; + + res = times (&buf); + if (res == (clock_t)-1) + { + *wall = 0; + *user = 0; + *sys = 0; + } + else + { + *wall = res; + *user = buf.tms_utime; + *sys = buf.tms_stime; + } +} + diff --git a/src/translate/grt/config/win32.c b/src/translate/grt/config/win32.c new file mode 100644 index 0000000..35322ba --- /dev/null +++ b/src/translate/grt/config/win32.c @@ -0,0 +1,265 @@ +/* GRT stack implementation for Win32 using fibers. + Copyright (C) 2005 - 2014 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. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + +#include <windows.h> +#include <stdio.h> +#include <setjmp.h> +#include <assert.h> +#include <excpt.h> + +static EXCEPTION_DISPOSITION +ghdl_SEH_handler (struct _EXCEPTION_RECORD* ExceptionRecord, + void *EstablisherFrame, + struct _CONTEXT* ContextRecord, + void *DispatcherContext); + +struct exception_registration +{ + struct exception_registration *prev; + void *handler; +}; + +struct stack_type +{ + LPVOID fiber; // Win fiber. + void (*func)(void *); // Function + void *arg; // Function argument. +}; + +static struct stack_type main_stack_context; +static struct stack_type *current; +extern void grt_set_main_stack (struct stack_type *stack); + +void grt_stack_init(void) +{ + main_stack_context.fiber = ConvertThreadToFiber (NULL); + if (main_stack_context.fiber == NULL) + { + fprintf (stderr, "convertThreadToFiber failed (err=%lu)\n", + GetLastError ()); + abort (); + } + grt_set_main_stack (&main_stack_context); + current = &main_stack_context; +} + +static VOID __stdcall +grt_stack_loop (void *v_stack) +{ + struct stack_type *stack = (struct stack_type *)v_stack; + struct exception_registration er; + struct exception_registration *prev; + + /* Get current handler. */ + asm ("mov %%fs:(0),%0" : "=r" (prev)); + + /* Build regisration. */ + er.prev = prev; + er.handler = ghdl_SEH_handler; + + /* Register. */ + asm ("mov %0,%%fs:(0)" : : "r" (&er)); + + while (1) + { + (*stack->func)(stack->arg); + } +} + +struct stack_type * +grt_stack_create (void (*func)(void *), void *arg) +{ + struct stack_type *res; + + res = malloc (sizeof (struct stack_type)); + if (res == NULL) + return NULL; + res->func = func; + res->arg = arg; + res->fiber = CreateFiber (0, &grt_stack_loop, res); + if (res->fiber == NULL) + { + free (res); + return NULL; + } + return res; +} + +static int run_env_en; +static jmp_buf run_env; +static int need_longjmp; + +void +grt_stack_switch (struct stack_type *to, struct stack_type *from) +{ + assert (current == from); + current = to; + SwitchToFiber (to->fiber); + if (from == &main_stack_context && need_longjmp) + { + /* We returned to do the longjump. */ + current = &main_stack_context; + longjmp (run_env, need_longjmp); + } +} + +void +grt_stack_delete (struct stack_type *stack) +{ + DeleteFiber (stack->fiber); + stack->fiber = NULL; +} + +void +__ghdl_maybe_return_via_longjump (int val) +{ + if (!run_env_en) + return; + + if (current != &main_stack_context) + { + /* We are allowed to jump only in the same stack. + First switch back to the main thread. */ + need_longjmp = val; + SwitchToFiber (main_stack_context.fiber); + } + else + longjmp (run_env, val); +} + +extern void grt_stack_error_grow_failed (void); +extern void grt_stack_error_null_access (void); +extern void grt_stack_error_memory_access (void); +extern void grt_overflow_error (void); + +static EXCEPTION_DISPOSITION +ghdl_SEH_handler (struct _EXCEPTION_RECORD* ExceptionRecord, + void *EstablisherFrame, + struct _CONTEXT* ContextRecord, + void *DispatcherContext) +{ + const char *msg = ""; + + switch (ExceptionRecord->ExceptionCode) + { + case EXCEPTION_ACCESS_VIOLATION: + if (ExceptionRecord->ExceptionInformation[1] == 0) + grt_stack_error_null_access (); + else + grt_stack_error_memory_access (); + break; + + case EXCEPTION_FLT_DENORMAL_OPERAND: + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + case EXCEPTION_FLT_INVALID_OPERATION: + case EXCEPTION_FLT_OVERFLOW: + case EXCEPTION_FLT_STACK_CHECK: + case EXCEPTION_FLT_UNDERFLOW: + msg = "floating point error"; + break; + + case EXCEPTION_INT_DIVIDE_BY_ZERO: + msg = "division by 0"; + break; + + case EXCEPTION_INT_OVERFLOW: + grt_overflow_error (); + break; + + case EXCEPTION_STACK_OVERFLOW: + msg = "stack overflow"; + break; + + default: + msg = "unknown reason"; + break; + } + + /* FIXME: is it correct? */ + fprintf (stderr, "exception raised: %s\n", msg); + + __ghdl_maybe_return_via_longjump (1); + return 0; /* This is never reached, avoid compiler warning */ +} + +int +__ghdl_run_through_longjump (int (*func)(void)) +{ + int res; + struct exception_registration er; + struct exception_registration *prev; + + /* Get current handler. */ + asm ("mov %%fs:(0),%0" : "=r" (prev)); + + /* Build regisration. */ + er.prev = prev; + er.handler = ghdl_SEH_handler; + + /* Register. */ + asm ("mov %0,%%fs:(0)" : : "r" (&er)); + + run_env_en = 1; + res = setjmp (run_env); + if (res == 0) + res = (*func)(); + run_env_en = 0; + + /* Restore. */ + asm ("mov %0,%%fs:(0)" : : "r" (prev)); + + return res; +} + +#include <math.h> + +double acosh (double x) +{ + return log (x + sqrt (x*x - 1)); +} + +double asinh (double x) +{ + return log (x + sqrt (x*x + 1)); +} + +double atanh (double x) +{ + return log ((1 + x) / (1 - x)) / 2; +} + +#ifndef WITH_GNAT_RUN_TIME +void __gnat_raise_storage_error(void) +{ + abort (); +} + +void __gnat_raise_program_error(void) +{ + abort (); +} +#endif + diff --git a/src/translate/grt/config/win32thr.c b/src/translate/grt/config/win32thr.c new file mode 100644 index 0000000..bcebc49 --- /dev/null +++ b/src/translate/grt/config/win32thr.c @@ -0,0 +1,167 @@ +/* GRT stack implementation for Win32 + Copyright (C) 2004, 2005 Felix Bertram. + + 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. +*/ +//----------------------------------------------------------------------------- +// Project: GHDL - VHDL Simulator +// Description: Win32 port of stacks package +// Note: Tristan's original i386/Linux used assembly-code +// to manually switch stacks for performance reasons. +// History: 2004feb09, FB, created. +//----------------------------------------------------------------------------- + +#include <windows.h> +//#include <pthread.h> +//#include <stdlib.h> +//#include <stdio.h> + + +//#define INFO printf +#define INFO (void) + +// GHDL names an endless loop calling FUNC with ARG a 'stack' +// at a given time, only one stack may be 'executed' +typedef struct +{ HANDLE thread; // stack's thread + HANDLE mutex; // mutex to suspend/resume thread + void (*Func)(void*); // stack's FUNC + void* Arg; // ARG passed to FUNC +} Stack_Type_t, *Stack_Type; + + +static Stack_Type_t main_stack_context; +extern void grt_set_main_stack (Stack_Type_t *stack); + +//------------------------------------------------------------------------------ +void grt_stack_init(void) +// Initialize the stacks package. +// This may adjust stack sizes. +// Must be called after grt.options.decode. +// => procedure Stack_Init; +{ INFO("grt_stack_init\n"); + INFO(" main_stack_context=0x%08x\n", &main_stack_context); + + // create event. reset event, as we are currently running + main_stack_context.mutex = CreateEvent(NULL, // lpsa + FALSE, // fManualReset + FALSE, // fInitialState + NULL); // lpszEventName + + grt_set_main_stack (&main_stack_context); +} + +//------------------------------------------------------------------------------ +static unsigned long __stdcall grt_stack_loop(void* pv_myStack) +{ + Stack_Type myStack= (Stack_Type)pv_myStack; + + INFO("grt_stack_loop\n"); + + INFO(" myStack=0x%08x\n", myStack); + + // block until event becomes set again. + // this happens when this stack is enabled for the first time + WaitForSingleObject(myStack->mutex, INFINITE); + + // run stack's function in endless loop + while(1) + { INFO(" call 0x%08x with 0x%08x\n", myStack->Func, myStack->Arg); + myStack->Func(myStack->Arg); + } + + // we never get here... + return 0; +} + +//------------------------------------------------------------------------------ +Stack_Type grt_stack_create(void* Func, void* Arg) +// Create a new stack, which on first execution will call FUNC with +// an argument ARG. +// => function Stack_Create (Func : Address; Arg : Address) return Stack_Type; +{ Stack_Type newStack; + DWORD m_IDThread; // Thread's ID (dummy) + + INFO("grt_stack_create\n"); + INFO(" call 0x%08x with 0x%08x\n", Func, Arg); + + newStack= malloc(sizeof(Stack_Type_t)); + + // init function and argument + newStack->Func= Func; + newStack->Arg= Arg; + + // create event. reset event, so that thread will blocked in grt_stack_loop + newStack->mutex= CreateEvent(NULL, // lpsa + FALSE, // fManualReset + FALSE, // fInitialState + NULL); // lpszEventName + + INFO(" newStack=0x%08x\n", newStack); + + // create thread, which executes grt_stack_loop + newStack->thread= CreateThread(NULL, // lpsa + 0, // cbStack + grt_stack_loop, // lpStartAddr + newStack, // lpvThreadParm + 0, // fdwCreate + &m_IDThread); // lpIDThread + + return newStack; +} + +//------------------------------------------------------------------------------ +void grt_stack_switch(Stack_Type To, Stack_Type From) +// Resume stack TO and save the current context to the stack pointed by +// CUR. +// => procedure Stack_Switch (To : Stack_Type; From : Stack_Type); +{ INFO("grt_stack_switch\n"); + INFO(" from 0x%08x to 0x%08x\n", From, To); + + // set 'To' event. this will make the other thread either + // - start for first time in grt_stack_loop + // - resume at WaitForSingleObject below + SetEvent(To->mutex); + + // block until 'From' event becomes set again + // as we are running, our event is reset and we block here + // when stacks are switched, with above SetEvent, we may proceed + WaitForSingleObject(From->mutex, INFINITE); +} + +//------------------------------------------------------------------------------ +void grt_stack_delete(Stack_Type Stack) +// Delete stack STACK, which must not be currently executed. +// => procedure Stack_Delete (Stack : Stack_Type); +{ INFO("grt_stack_delete\n"); +} + +//---------------------------------------------------------------------------- +#ifndef WITH_GNAT_RUN_TIME +void __gnat_raise_storage_error(void) +{ + abort (); +} + +void __gnat_raise_program_error(void) +{ + abort (); +} +#endif + +//---------------------------------------------------------------------------- +// end of file + diff --git a/src/translate/grt/ghdl_main.adb b/src/translate/grt/ghdl_main.adb new file mode 100644 index 0000000..ce5b67d --- /dev/null +++ b/src/translate/grt/ghdl_main.adb @@ -0,0 +1,61 @@ +-- GHDL Run Time (GRT) entry point. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Ada.Unchecked_Conversion; +with Grt.Options; use Grt.Options; +with Grt.Main; +with Grt.Types; use Grt.Types; + +-- Some files are only referenced from compiled code. With it here so that +-- they get compiled during build (and elaborated). +pragma Warnings (Off); +with Grt.Rtis_Binding; +with Grt.Std_Logic_1164; +pragma Warnings (On); + + +function Ghdl_Main (Argc : Integer; Argv : System.Address) + return Integer +is + -- Grt_Init corresponds to the 'adainit' subprogram for grt. + procedure Grt_Init; + pragma Import (C, Grt_Init, "grt_init"); + + function To_Argv_Type is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Grt.Options.Argv_Type); + + Default_Progname : constant String := "ghdl_design" & NUL; +begin + if Argc > 0 then + Grt.Options.Progname := To_Argv_Type (Argv)(0); + else + Grt.Options.Progname := To_Ghdl_C_String (Default_Progname'Address); + end if; + Grt.Options.Argc := Argc; + Grt.Options.Argv := To_Argv_Type (Argv); + + Grt_Init; + Grt.Main.Run; + return 0; +end Ghdl_Main; diff --git a/src/translate/grt/ghdl_main.ads b/src/translate/grt/ghdl_main.ads new file mode 100644 index 0000000..88d181a --- /dev/null +++ b/src/translate/grt/ghdl_main.ads @@ -0,0 +1,33 @@ +-- GHDL Run Time (GRT) entry point. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; + +-- 'main' function for grt. +-- Contrary to the C main function, ARGC can be 0 (in this case a fake argv[0] +-- is used). +function Ghdl_Main (Argc : Integer; Argv : System.Address) + return Integer; +pragma Export (C, Ghdl_Main, "ghdl_main"); + diff --git a/src/translate/grt/ghwdump.c b/src/translate/grt/ghwdump.c new file mode 100644 index 0000000..4affc2b --- /dev/null +++ b/src/translate/grt/ghwdump.c @@ -0,0 +1,195 @@ +/* Display a GHDL Wavefile for debugging. + Copyright (C) 2005 Tristan Gingold + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ + +#include <stdio.h> +#include <stdint.h> +#include <string.h> +#include <stdlib.h> +#include <unistd.h> + +#include "ghwlib.h" + +static const char *progname; +void +usage (void) +{ + printf ("usage: %s [OPTIONS] FILEs...\n", progname); + printf ("Options are:\n" + " -t display types\n" + " -h display hierarchy\n" + " -T display time\n" + " -s display signals (and time)\n" + " -l display list of sections\n" + " -v verbose\n"); +} + +int +main (int argc, char **argv) +{ + int i; + int flag_disp_types; + int flag_disp_hierarchy; + int flag_disp_time; + int flag_disp_signals; + int flag_list; + int flag_verbose; + int eof; + enum ghw_sm_type sm; + + progname = argv[0]; + flag_disp_types = 0; + flag_disp_hierarchy = 0; + flag_disp_time = 0; + flag_disp_signals = 0; + flag_list = 0; + flag_verbose = 0; + + while (1) + { + int c; + + c = getopt (argc, argv, "thTslv"); + if (c == -1) + break; + switch (c) + { + case 't': + flag_disp_types = 1; + break; + case 'h': + flag_disp_hierarchy = 1; + break; + case 'T': + flag_disp_time = 1; + break; + case 's': + flag_disp_signals = 1; + flag_disp_time = 1; + break; + case 'l': + flag_list = 1; + break; + case 'v': + flag_verbose++; + break; + default: + usage (); + exit (2); + } + } + + if (optind >= argc) + { + usage (); + return 1; + } + + for (i = optind; i < argc; i++) + { + struct ghw_handler h; + struct ghw_handler *hp = &h; + + hp->flag_verbose = flag_verbose; + + if (ghw_open (hp, argv[i]) != 0) + { + fprintf (stderr, "cannot open ghw file %s\n", argv[i]); + return 1; + } + if (flag_list) + { + while (1) + { + int section; + + section = ghw_read_section (hp); + if (section == -2) + { + printf ("eof of file\n"); + break; + } + else if (section < 0) + { + printf ("Error in file\n"); + break; + } + else if (section == 0) + { + printf ("Unknown section\n"); + break; + } + printf ("Section %s\n", ghw_sections[section].name); + if ((*ghw_sections[section].handler)(hp) < 0) + break; + } + } + else + { + if (ghw_read_base (hp) < 0) + { + fprintf (stderr, "cannot read ghw file\n"); + return 2; + } + if (0) + { + int i; + printf ("String table:\n"); + + for (i = 1; i < hp->nbr_str; i++) + printf (" %s\n", hp->str_table[i]); + } + if (flag_disp_types) + ghw_disp_types (hp); + if (flag_disp_hierarchy) + ghw_disp_hie (hp, hp->hie); + +#if 1 + sm = ghw_sm_init; + eof = 0; + while (!eof) + { + switch (ghw_read_sm (hp, &sm)) + { + case ghw_res_snapshot: + case ghw_res_cycle: + if (flag_disp_time) + printf ("Time is %lld fs\n", hp->snap_time); + if (flag_disp_signals) + ghw_disp_values (hp); + break; + case ghw_res_eof: + eof = 1; + break; + default: + abort (); + } + } + +#else + if (ghw_read_dump (hp) < 0) + { + fprintf (stderr, "error in ghw dump\n"); + return 3; + } +#endif + } + ghw_close (&h); + } + return 0; +} diff --git a/src/translate/grt/ghwlib.c b/src/translate/grt/ghwlib.c new file mode 100644 index 0000000..2db63d9 --- /dev/null +++ b/src/translate/grt/ghwlib.c @@ -0,0 +1,1746 @@ +/* GHDL Wavefile reader library. + Copyright (C) 2005 Tristan Gingold + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ + +#include <stdio.h> +#include <string.h> +#include <stdlib.h> +#include <unistd.h> + +#include "ghwlib.h" + +int +ghw_open (struct ghw_handler *h, const char *filename) +{ + char hdr[16]; + + h->stream = fopen (filename, "rb"); + if (h->stream == NULL) + return -1; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + /* Check magic. */ + if (memcmp (hdr, "GHDLwave\n", 9) != 0) + return -2; + /* Check version. */ + if (hdr[9] != 16 + || hdr[10] != 0) + return -2; + h->version = hdr[11]; + if (h->version > 1) + return -3; + if (hdr[12] == 1) + h->word_be = 0; + else if (hdr[12] == 2) + h->word_be = 1; + else + return -4; +#if 0 + /* Endianness. */ + { + int endian; + union { unsigned char b[4]; uint32_t i;} v; + v.i = 0x11223344; + if (v.b[0] == 0x11) + endian = 2; + else if (v.b[0] == 0x44) + endian = 1; + else + return -3; + + if (hdr[12] != 1 && hdr[12] != 2) + return -3; + if (hdr[12] != endian) + h->swap_word = 1; + else + h->swap_word = 0; + } +#endif + h->word_len = hdr[13]; + h->off_len = hdr[14]; + + if (hdr[15] != 0) + return -5; + + h->hie = NULL; + return 0; +} + +int32_t +ghw_get_i32 (struct ghw_handler *h, unsigned char *b) +{ + if (h->word_be) + return (b[0] << 24) | (b[1] << 16) | (b[2] << 8) | (b[3] << 0); + else + return (b[3] << 24) | (b[2] << 16) | (b[1] << 8) | (b[0] << 0); +} + +int64_t +ghw_get_i64 (struct ghw_handler *ghw_h, unsigned char *b) +{ + int l, h; + + if (ghw_h->word_be) + { + h = (b[0] << 24) | (b[1] << 16) | (b[2] << 8) | (b[3] << 0); + l = (b[4] << 24) | (b[5] << 16) | (b[6] << 8) | (b[7] << 0); + } + else + { + l = (b[3] << 24) | (b[2] << 16) | (b[1] << 8) | (b[0] << 0); + h = (b[7] << 24) | (b[6] << 16) | (b[5] << 8) | (b[4] << 0); + } + return (((int64_t)h) << 32) | l; +} + +int +ghw_read_byte (struct ghw_handler *h, unsigned char *res) +{ + int v; + + v = fgetc (h->stream); + if (v == EOF) + return -1; + *res = v; + return 0; +} + +int +ghw_read_uleb128 (struct ghw_handler *h, uint32_t *res) +{ + unsigned int r = 0; + unsigned int off = 0; + + while (1) + { + int v = fgetc (h->stream); + if (v == EOF) + return -1; + r |= (v & 0x7f) << off; + if ((v & 0x80) == 0) + break; + off += 7; + } + *res = r; + return 0; +} + +int +ghw_read_sleb128 (struct ghw_handler *h, int32_t *res) +{ + int32_t r = 0; + unsigned int off = 0; + + while (1) + { + int v = fgetc (h->stream); + if (v == EOF) + return -1; + r |= ((int32_t)(v & 0x7f)) << off; + off += 7; + if ((v & 0x80) == 0) + { + if ((v & 0x40) && off < 32) + r |= -1 << off; + break; + } + } + *res = r; + return 0; +} + +int +ghw_read_lsleb128 (struct ghw_handler *h, int64_t *res) +{ + static const int64_t r_mask = -1; + int64_t r = 0; + unsigned int off = 0; + + while (1) + { + int v = fgetc (h->stream); + if (v == EOF) + return -1; + r |= ((int64_t)(v & 0x7f)) << off; + off += 7; + if ((v & 0x80) == 0) + { + if ((v & 0x40) && off < 64) + r |= r_mask << off; + break; + } + } + *res = r; + return 0; +} + +int +ghw_read_f64 (struct ghw_handler *h, double *res) +{ + /* FIXME: handle byte order. */ + if (fread (res, sizeof (*res), 1, h->stream) != 1) + return -1; + return 0; +} + +const char * +ghw_read_strid (struct ghw_handler *h) +{ + unsigned int id; + if (ghw_read_uleb128 (h, &id) != 0) + return NULL; + return h->str_table[id]; +} + +union ghw_type * +ghw_read_typeid (struct ghw_handler *h) +{ + unsigned int id; + if (ghw_read_uleb128 (h, &id) != 0) + return NULL; + return h->types[id - 1]; +} + +union ghw_range * +ghw_read_range (struct ghw_handler *h) +{ + int t = fgetc (h->stream); + if (t == EOF) + return NULL; + switch (t & 0x7f) + { + case ghdl_rtik_type_b2: + { + struct ghw_range_b2 *r; + r = malloc (sizeof (struct ghw_range_b2)); + r->kind = t & 0x7f; + r->dir = (t & 0x80) != 0; + if (ghw_read_byte (h, &r->left) != 0) + return NULL; + if (ghw_read_byte (h, &r->right) != 0) + return NULL; + return (union ghw_range *)r; + } + case ghdl_rtik_type_e8: + { + struct ghw_range_e8 *r; + r = malloc (sizeof (struct ghw_range_e8)); + r->kind = t & 0x7f; + r->dir = (t & 0x80) != 0; + if (ghw_read_byte (h, &r->left) != 0) + return NULL; + if (ghw_read_byte (h, &r->right) != 0) + return NULL; + return (union ghw_range *)r; + } + case ghdl_rtik_type_i32: + case ghdl_rtik_type_p32: + { + struct ghw_range_i32 *r; + r = malloc (sizeof (struct ghw_range_i32)); + r->kind = t & 0x7f; + r->dir = (t & 0x80) != 0; + if (ghw_read_sleb128 (h, &r->left) != 0) + return NULL; + if (ghw_read_sleb128 (h, &r->right) != 0) + return NULL; + return (union ghw_range *)r; + } + case ghdl_rtik_type_i64: + case ghdl_rtik_type_p64: + { + struct ghw_range_i64 *r; + r = malloc (sizeof (struct ghw_range_i64)); + r->kind = t & 0x7f; + r->dir = (t & 0x80) != 0; + if (ghw_read_lsleb128 (h, &r->left) != 0) + return NULL; + if (ghw_read_lsleb128 (h, &r->right) != 0) + return NULL; + return (union ghw_range *)r; + } + case ghdl_rtik_type_f64: + { + struct ghw_range_f64 *r; + r = malloc (sizeof (struct ghw_range_f64)); + r->kind = t & 0x7f; + r->dir = (t & 0x80) != 0; + if (ghw_read_f64 (h, &r->left) != 0) + return NULL; + if (ghw_read_f64 (h, &r->right) != 0) + return NULL; + return (union ghw_range *)r; + } + default: + fprintf (stderr, "ghw_read_range: type %d unhandled\n", t & 0x7f); + return NULL; + } +} + +int +ghw_read_str (struct ghw_handler *h) +{ + unsigned char hdr[12]; + int i; + char *p; + int prev_len; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + h->nbr_str = ghw_get_i32 (h, &hdr[4]); + h->nbr_str++; + h->str_size = ghw_get_i32 (h, &hdr[8]); + h->str_table = (char **)malloc ((h->nbr_str + 1) * sizeof (char *)); + h->str_content = (char *)malloc (h->str_size + h->nbr_str + 1); + + if (h->flag_verbose) + { + printf ("Number of strings: %d\n", h->nbr_str - 1); + printf ("String table size: %d\n", h->str_size); + } + + h->str_table[0] = "<anon>"; + p = h->str_content; + prev_len = 0; + for (i = 1; i < h->nbr_str; i++) + { + int j; + int c; + char *prev; + int sh; + + h->str_table[i] = p; + prev = h->str_table[i - 1]; + for (j = 0; j < prev_len; j++) + *p++ = prev[j]; + + while (1) + { + c = fgetc (h->stream); + if (c == EOF) + return -1; + if ((c >= 0 && c <= 31) + || (c >= 128 && c <= 159)) + break; + *p++ = c; + } + *p++ = 0; + + if (h->flag_verbose > 1) + printf (" string %d (pl=%d): %s\n", i, prev_len, h->str_table[i]); + + prev_len = c & 0x1f; + sh = 5; + while (c >= 128) + { + c = fgetc (h->stream); + if (c == EOF) + return -1; + prev_len |= (c & 0x1f) << sh; + sh += 5; + } + } + if (fread (hdr, 4, 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "EOS", 4) != 0) + return -1; + return 0; +} + +union ghw_type * +ghw_get_base_type (union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + case ghdl_rtik_type_e32: + case ghdl_rtik_type_i32: + case ghdl_rtik_type_i64: + case ghdl_rtik_type_f64: + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + return t; + case ghdl_rtik_subtype_scalar: + return t->ss.base; + case ghdl_rtik_subtype_array: + return (union ghw_type*)(t->sa.base); + default: + fprintf (stderr, "ghw_get_base_type: cannot handle type %d\n", t->kind); + abort (); + } +} + +int +get_nbr_elements (union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + case ghdl_rtik_type_e32: + case ghdl_rtik_type_i32: + case ghdl_rtik_type_i64: + case ghdl_rtik_type_f64: + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + case ghdl_rtik_subtype_scalar: + return 1; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + return t->sa.nbr_el; + case ghdl_rtik_type_record: + return t->rec.nbr_el; + default: + fprintf (stderr, "get_nbr_elements: unhandled type %d\n", t->kind); + abort (); + } +} + +int +get_range_length (union ghw_range *rng) +{ + switch (rng->kind) + { + case ghdl_rtik_type_i32: + if (rng->i32.dir) + return (rng->i32.left - rng->i32.right + 1); + else + return (rng->i32.right - rng->i32.left + 1); + default: + fprintf (stderr, "get_range_length: unhandled kind %d\n", rng->kind); + abort (); + } +} + +int +ghw_read_type (struct ghw_handler *h) +{ + unsigned char hdr[8]; + int i; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + h->nbr_types = ghw_get_i32 (h, &hdr[4]); + h->types = (union ghw_type **) + malloc (h->nbr_types * sizeof (union ghw_type *)); + + for (i = 0; i < h->nbr_types; i++) + { + int t; + + t = fgetc (h->stream); + if (t == EOF) + return -1; + /* printf ("type[%d]= %d\n", i, t); */ + switch (t) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + { + struct ghw_type_enum *e; + int j; + + e = malloc (sizeof (struct ghw_type_enum)); + e->kind = t; + e->wkt = ghw_wkt_unknown; + e->name = ghw_read_strid (h); + if (ghw_read_uleb128 (h, &e->nbr) != 0) + return -1; + e->lits = (const char **) malloc (e->nbr * sizeof (char *)); + if (h->flag_verbose > 1) + printf ("enum %s:", e->name); + for (j = 0; j < e->nbr; j++) + { + e->lits[j] = ghw_read_strid (h); + if (h->flag_verbose > 1) + printf (" %s", e->lits[j]); + } + if (h->flag_verbose > 1) + printf ("\n"); + h->types[i] = (union ghw_type *)e; + } + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_i64: + case ghdl_rtik_type_f64: + { + struct ghw_type_scalar *sc; + + sc = malloc (sizeof (struct ghw_type_scalar)); + sc->kind = t; + sc->name = ghw_read_strid (h); + if (h->flag_verbose > 1) + printf ("scalar: %s\n", sc->name); + h->types[i] = (union ghw_type *)sc; + } + break; + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + { + struct ghw_type_physical *ph; + + ph = malloc (sizeof (struct ghw_type_physical)); + ph->kind = t; + ph->name = ghw_read_strid (h); + if (h->version == 0) + ph->nbr_units = 0; + else + { + int i; + + if (ghw_read_uleb128 (h, &ph->nbr_units) != 0) + return -1; + ph->units = malloc (ph->nbr_units * sizeof (struct ghw_unit)); + for (i = 0; i < ph->nbr_units; i++) + { + ph->units[i].name = ghw_read_strid (h); + if (ghw_read_lsleb128 (h, &ph->units[i].val) < 0) + return -1; + } + } + if (h->flag_verbose > 1) + printf ("physical: %s\n", ph->name); + h->types[i] = (union ghw_type *)ph; + } + break; + case ghdl_rtik_subtype_scalar: + { + struct ghw_subtype_scalar *ss; + + ss = malloc (sizeof (struct ghw_subtype_scalar)); + ss->kind = t; + ss->name = ghw_read_strid (h); + ss->base = ghw_read_typeid (h); + ss->rng = ghw_read_range (h); + if (h->flag_verbose > 1) + printf ("subtype scalar: %s\n", ss->name); + h->types[i] = (union ghw_type *)ss; + } + break; + case ghdl_rtik_type_array: + { + struct ghw_type_array *arr; + int j; + + arr = malloc (sizeof (struct ghw_type_array)); + arr->kind = t; + arr->name = ghw_read_strid (h); + arr->el = ghw_read_typeid (h); + if (ghw_read_uleb128 (h, &arr->nbr_dim) != 0) + return -1; + arr->dims = (union ghw_type **) + malloc (arr->nbr_dim * sizeof (union ghw_type *)); + for (j = 0; j < arr->nbr_dim; j++) + arr->dims[j] = ghw_read_typeid (h); + if (h->flag_verbose > 1) + printf ("array: %s\n", arr->name); + h->types[i] = (union ghw_type *)arr; + } + break; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + { + struct ghw_subtype_array *sa; + int j; + int nbr_el; + + sa = malloc (sizeof (struct ghw_subtype_array)); + sa->kind = t; + sa->name = ghw_read_strid (h); + sa->base = (struct ghw_type_array *)ghw_read_typeid (h); + nbr_el = get_nbr_elements (sa->base->el); + sa->rngs = malloc (sa->base->nbr_dim * sizeof (union ghw_range *)); + for (j = 0; j < sa->base->nbr_dim; j++) + { + sa->rngs[j] = ghw_read_range (h); + nbr_el *= get_range_length (sa->rngs[j]); + } + sa->nbr_el = nbr_el; + if (h->flag_verbose > 1) + printf ("subtype array: %s (nbr_el=%d)\n", sa->name, sa->nbr_el); + h->types[i] = (union ghw_type *)sa; + } + break; + case ghdl_rtik_type_record: + { + struct ghw_type_record *rec; + int j; + int nbr_el; + + rec = malloc (sizeof (struct ghw_type_record)); + rec->kind = t; + rec->name = ghw_read_strid (h); + if (ghw_read_uleb128 (h, &rec->nbr_fields) != 0) + return -1; + rec->el = malloc + (rec->nbr_fields * sizeof (struct ghw_record_element)); + nbr_el = 0; + for (j = 0; j < rec->nbr_fields; j++) + { + rec->el[j].name = ghw_read_strid (h); + rec->el[j].type = ghw_read_typeid (h); + nbr_el += get_nbr_elements (rec->el[j].type); + } + rec->nbr_el = nbr_el; + if (h->flag_verbose > 1) + printf ("record type: %s (nbr_el=%d)\n", rec->name, rec->nbr_el); + h->types[i] = (union ghw_type *)rec; + } + break; + default: + fprintf (stderr, "ghw_read_type: unknown type %d\n", t); + return -1; + } + } + if (fgetc (h->stream) != 0) + return -1; + return 0; +} + +int +ghw_read_wk_types (struct ghw_handler *h) +{ + char hdr[4]; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + + while (1) + { + int t; + union ghw_type *tid; + + t = fgetc (h->stream); + if (t == EOF) + return -1; + else if (t == 0) + break; + + tid = ghw_read_typeid (h); + if (tid->kind == ghdl_rtik_type_b2 + || tid->kind == ghdl_rtik_type_e8) + { + if (h->flag_verbose > 0) + printf ("%s: wkt=%d\n", tid->en.name, t); + tid->en.wkt = t; + } + } + return 0; +} + +void +ghw_disp_typename (struct ghw_handler *h, union ghw_type *t) +{ + printf ("%s", t->common.name); +} + +/* Read a signal composed of severals elements. */ +int +ghw_read_signal (struct ghw_handler *h, unsigned int *sigs, union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + case ghdl_rtik_type_e32: + case ghdl_rtik_subtype_scalar: + { + unsigned int sig_el; + + if (ghw_read_uleb128 (h, &sig_el) < 0) + return -1; + *sigs = sig_el; + if (sig_el >= h->nbr_sigs) + abort (); + if (h->sigs[sig_el].type == NULL) + h->sigs[sig_el].type = ghw_get_base_type (t); + } + return 0; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + { + int i; + int stride; + int len; + + len = t->sa.nbr_el; + stride = get_nbr_elements (t->sa.base->el); + + for (i = 0; i < len; i += stride) + if (ghw_read_signal (h, &sigs[i], t->sa.base->el) < 0) + return -1; + } + return 0; + case ghdl_rtik_type_record: + { + int i; + int off; + + off = 0; + for (i = 0; i < t->rec.nbr_fields; i++) + { + if (ghw_read_signal (h, &sigs[off], t->rec.el[i].type) < 0) + return -1; + off += get_nbr_elements (t->rec.el[i].type); + } + } + return 0; + default: + fprintf (stderr, "ghw_read_signal: type kind %d unhandled\n", t->kind); + abort (); + } +} + + +int +ghw_read_value (struct ghw_handler *h, + union ghw_val *val, union ghw_type *type) +{ + switch (ghw_get_base_type (type)->kind) + { + case ghdl_rtik_type_b2: + { + int v; + v = fgetc (h->stream); + if (v == EOF) + return -1; + val->b2 = v; + } + break; + case ghdl_rtik_type_e8: + { + int v; + v = fgetc (h->stream); + if (v == EOF) + return -1; + val->e8 = v; + } + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_p32: + { + int32_t v; + if (ghw_read_sleb128 (h, &v) < 0) + return -1; + val->i32 = v; + } + break; + case ghdl_rtik_type_f64: + { + double v; + if (ghw_read_f64 (h, &v) < 0) + return -1; + val->f64 = v; + } + break; + case ghdl_rtik_type_p64: + { + int64_t v; + if (ghw_read_lsleb128 (h, &v) < 0) + return -1; + val->i64 = v; + } + break; + default: + fprintf (stderr, "read_value: cannot handle format %d\n", type->kind); + abort (); + } + return 0; +} + +int +ghw_read_hie (struct ghw_handler *h) +{ + unsigned char hdr[16]; + int nbr_scopes; + int nbr_sigs; + int i; + struct ghw_hie *blk; + struct ghw_hie **last; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + nbr_scopes = ghw_get_i32 (h, &hdr[4]); + /* Number of declared signals (which may be composite). */ + nbr_sigs = ghw_get_i32 (h, &hdr[8]); + /* Number of basic signals. */ + h->nbr_sigs = ghw_get_i32 (h, &hdr[12]); + + if (h->flag_verbose) + printf ("%d scopes, %d signals, %d signal elements\n", + nbr_scopes, nbr_sigs, h->nbr_sigs); + + blk = (struct ghw_hie *)malloc (sizeof (struct ghw_hie)); + blk->kind = ghw_hie_design; + blk->name = NULL; + blk->parent = NULL; + blk->brother = NULL; + blk->u.blk.child = NULL; + + last = &blk->u.blk.child; + h->hie = blk; + + h->nbr_sigs++; + h->sigs = (struct ghw_sig *) malloc (h->nbr_sigs * sizeof (struct ghw_sig)); + memset (h->sigs, 0, h->nbr_sigs * sizeof (struct ghw_sig)); + + while (1) + { + int t; + struct ghw_hie *el; + unsigned int str; + + t = fgetc (h->stream); + if (t == EOF) + return -1; + if (t == 0) + break; + + if (t == ghw_hie_eos) + { + blk = blk->parent; + if (blk->u.blk.child == NULL) + last = &blk->u.blk.child; + else + { + struct ghw_hie *l = blk->u.blk.child; + while (l->brother != NULL) + l = l->brother; + last = &l->brother; + } + + continue; + } + + el = (struct ghw_hie *) malloc (sizeof (struct ghw_hie)); + el->kind = t; + el->parent = blk; + el->brother = NULL; + + /* Link. */ + *last = el; + last = &el->brother; + + /* Read name. */ + if (ghw_read_uleb128 (h, &str) != 0) + return -1; + el->name = h->str_table[str]; + + switch (t) + { + case ghw_hie_eoh: + case ghw_hie_design: + case ghw_hie_eos: + /* Should not be here. */ + abort (); + case ghw_hie_process: + break; + case ghw_hie_block: + case ghw_hie_generate_if: + case ghw_hie_generate_for: + case ghw_hie_instance: + case ghw_hie_generic: + case ghw_hie_package: + /* Create a block. */ + el->u.blk.child = NULL; + + if (t == ghw_hie_generate_for) + { + el->u.blk.iter_type = ghw_read_typeid (h); + el->u.blk.iter_value = malloc (sizeof (union ghw_val)); + if (ghw_read_value (h, el->u.blk.iter_value, + el->u.blk.iter_type) < 0) + return -1; + } + blk = el; + last = &el->u.blk.child; + break; + case ghw_hie_signal: + case ghw_hie_port_in: + case ghw_hie_port_out: + case ghw_hie_port_inout: + case ghw_hie_port_buffer: + case ghw_hie_port_linkage: + /* For a signal, read type. */ + { + int nbr_el; + unsigned int *sigs; + + el->u.sig.type = ghw_read_typeid (h); + nbr_el = get_nbr_elements (el->u.sig.type); + sigs = (unsigned int *) malloc + ((nbr_el + 1) * sizeof (unsigned int)); + el->u.sig.sigs = sigs; + /* Last element is NULL. */ + sigs[nbr_el] = 0; + + if (h->flag_verbose > 1) + printf ("signal %s: %d el [", el->name, nbr_el); + if (ghw_read_signal (h, sigs, el->u.sig.type) < 0) + return -1; + if (h->flag_verbose > 1) + { + int i; + for (i = 0; i < nbr_el; i++) + printf (" #%u", sigs[i]); + printf ("]\n"); + } + } + break; + default: + fprintf (stderr, "ghw_read_hie: unhandled kind %d\n", t); + abort (); + } + } + + /* Allocate values. */ + for (i = 0; i < h->nbr_sigs; i++) + if (h->sigs[i].type != NULL) + h->sigs[i].val = (union ghw_val *) malloc (sizeof (union ghw_val)); + return 0; +} + +const char * +ghw_get_hie_name (struct ghw_hie *h) +{ + switch (h->kind) + { + case ghw_hie_eoh: + return "eoh"; + case ghw_hie_design: + return "design"; + case ghw_hie_block: + return "block"; + case ghw_hie_generate_if: + return "generate-if"; + case ghw_hie_generate_for: + return "generate-for"; + case ghw_hie_instance: + return "instance"; + case ghw_hie_package: + return "package"; + case ghw_hie_process: + return "process"; + case ghw_hie_generic: + return "generic"; + case ghw_hie_eos: + return "eos"; + case ghw_hie_signal: + return "signal"; + case ghw_hie_port_in: + return "port-in"; + case ghw_hie_port_out: + return "port-out"; + case ghw_hie_port_inout: + return "port-inout"; + case ghw_hie_port_buffer: + return "port-buffer"; + case ghw_hie_port_linkage: + return "port-linkage"; + default: + return "??"; + } +} + +void +ghw_disp_value (union ghw_val *val, union ghw_type *type); + +void +ghw_disp_hie (struct ghw_handler *h, struct ghw_hie *top) +{ + int i; + int indent; + struct ghw_hie *hie; + struct ghw_hie *n; + + hie = top; + indent = 0; + + while (1) + { + for (i = 0; i < indent; i++) + fputc (' ', stdout); + printf ("%s", ghw_get_hie_name (hie)); + + switch (hie->kind) + { + case ghw_hie_design: + case ghw_hie_block: + case ghw_hie_generate_if: + case ghw_hie_generate_for: + case ghw_hie_instance: + case ghw_hie_process: + case ghw_hie_package: + if (hie->name) + printf (" %s", hie->name); + if (hie->kind == ghw_hie_generate_for) + { + printf ("("); + ghw_disp_value (hie->u.blk.iter_value, hie->u.blk.iter_type); + printf (")"); + } + n = hie->u.blk.child; + if (n == NULL) + n = hie->brother; + else + indent++; + break; + case ghw_hie_generic: + case ghw_hie_eos: + abort (); + case ghw_hie_signal: + case ghw_hie_port_in: + case ghw_hie_port_out: + case ghw_hie_port_inout: + case ghw_hie_port_buffer: + case ghw_hie_port_linkage: + { + unsigned int *sigs; + + printf (" %s: ", hie->name); + ghw_disp_typename (h, hie->u.sig.type); + for (sigs = hie->u.sig.sigs; *sigs != 0; sigs++) + printf (" #%u", *sigs); + n = hie->brother; + } + break; + default: + abort (); + } + printf ("\n"); + + while (n == NULL) + { + if (hie->parent == NULL) + return; + hie = hie->parent; + indent--; + n = hie->brother; + } + hie = n; + } +} + +int +ghw_read_eoh (struct ghw_handler *h) +{ + return 0; +} + + +int +ghw_read_base (struct ghw_handler *h) +{ + unsigned char hdr[4]; + int res; + + while (1) + { + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "STR", 4) == 0) + res = ghw_read_str (h); + else if (memcmp (hdr, "HIE", 4) == 0) + res = ghw_read_hie (h); + else if (memcmp (hdr, "TYP", 4) == 0) + res = ghw_read_type (h); + else if (memcmp (hdr, "WKT", 4) == 0) + res = ghw_read_wk_types (h); + else if (memcmp (hdr, "EOH", 4) == 0) + return 0; + else + { + fprintf (stderr, "ghw_read_base: unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return -1; + } + if (res != 0) + { + fprintf (stderr, "ghw_read_base: error in section %s\n", hdr); + return res; + } + } +} + +int +ghw_read_signal_value (struct ghw_handler *h, struct ghw_sig *s) +{ + return ghw_read_value (h, s->val, s->type); +} + +int +ghw_read_snapshot (struct ghw_handler *h) +{ + unsigned char hdr[12]; + int i; + struct ghw_sig *s; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + h->snap_time = ghw_get_i64 (h, &hdr[4]); + if (h->flag_verbose > 1) + printf ("Time is %lld fs\n", h->snap_time); + + for (i = 0; i < h->nbr_sigs; i++) + { + s = &h->sigs[i]; + if (s->type != NULL) + { + if (h->flag_verbose > 1) + printf ("read type %d for sig %d\n", s->type->kind, i); + if (ghw_read_signal_value (h, s) < 0) + return -1; + } + } + if (fread (hdr, 4, 1, h->stream) != 1) + return -1; + + if (memcmp (hdr, "ESN", 4)) + return -1; + + return 0; +} + +void ghw_disp_values (struct ghw_handler *h); + +int +ghw_read_cycle_start (struct ghw_handler *h) +{ + unsigned char hdr[8]; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + h->snap_time = ghw_get_i64 (h, hdr); + return 0; +} + +int +ghw_read_cycle_cont (struct ghw_handler *h, int *list) +{ + int i; + int *list_p; + + i = 0; + list_p = list; + while (1) + { + uint32_t d; + + /* Read delta to next signal. */ + if (ghw_read_uleb128 (h, &d) < 0) + return -1; + if (d == 0) + { + /* Last signal reached. */ + break; + } + + /* Find next signal. */ + while (d > 0) + { + i++; + if (h->sigs[i].type != NULL) + d--; + } + + if (ghw_read_signal_value (h, &h->sigs[i]) < 0) + return -1; + if (list_p) + *list_p++ = i; + } + + if (list_p) + *list_p = 0; + return 0; +} + +int +ghw_read_cycle_next (struct ghw_handler *h) +{ + int64_t d_time; + + if (ghw_read_lsleb128 (h, &d_time) < 0) + return -1; + if (d_time == -1) + return 0; + h->snap_time += d_time; + return 1; +} + + +int +ghw_read_cycle_end (struct ghw_handler *h) +{ + char hdr[4]; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "ECY", 4)) + return -1; + + return 0; +} + +static const char * +ghw_get_lit (union ghw_type *type, int e) +{ + if (e >= type->en.nbr || e < 0) + return "??"; + else + return type->en.lits[e]; +} + +static void +ghw_disp_lit (union ghw_type *type, int e) +{ + printf ("%s (%d)", ghw_get_lit (type, e), e); +} + +void +ghw_disp_value (union ghw_val *val, union ghw_type *type) +{ + switch (ghw_get_base_type (type)->kind) + { + case ghdl_rtik_type_b2: + ghw_disp_lit (type, val->b2); + break; + case ghdl_rtik_type_e8: + ghw_disp_lit (type, val->e8); + break; + case ghdl_rtik_type_i32: + printf ("%d", val->i32); + break; + case ghdl_rtik_type_p64: + printf ("%lld", val->i64); + break; + case ghdl_rtik_type_f64: + printf ("%g", val->f64); + break; + default: + fprintf (stderr, "ghw_disp_value: cannot handle type %d\n", + type->kind); + abort (); + } +} + +/* Put the ASCII representation of VAL into BUF, whose size if LEN. + A NUL is always written to BUF. +*/ +void +ghw_get_value (char *buf, int len, union ghw_val *val, union ghw_type *type) +{ + switch (ghw_get_base_type (type)->kind) + { + case ghdl_rtik_type_b2: + if (val->b2 <= 1) + { + strncpy (buf, type->en.lits[val->b2], len - 1); + buf[len - 1] = 0; + } + else + { + snprintf (buf, len, "?%d", val->b2); + } + break; + case ghdl_rtik_type_e8: + if (val->b2 <= type->en.nbr) + { + strncpy (buf, type->en.lits[val->e8], len - 1); + buf[len - 1] = 0; + } + else + { + snprintf (buf, len, "?%d", val->e8); + } + break; + case ghdl_rtik_type_i32: + snprintf (buf, len, "%d", val->i32); + break; + case ghdl_rtik_type_p64: + snprintf (buf, len, "%lld", val->i64); + break; + case ghdl_rtik_type_f64: + snprintf (buf, len, "%g", val->f64); + break; + default: + snprintf (buf, len, "?bad type %d?", type->kind); + } +} + +void +ghw_disp_values (struct ghw_handler *h) +{ + int i; + + for (i = 0; i < h->nbr_sigs; i++) + { + struct ghw_sig *s = &h->sigs[i]; + if (s->type != NULL) + { + printf ("#%d: ", i); + ghw_disp_value (s->val, s->type); + printf ("\n"); + } + } +} + +int +ghw_read_directory (struct ghw_handler *h) +{ + unsigned char hdr[8]; + int nbr_entries; + int i; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + nbr_entries = ghw_get_i32 (h, &hdr[4]); + + if (h->flag_verbose) + printf ("Directory (%d entries):\n", nbr_entries); + + for (i = 0; i < nbr_entries; i++) + { + unsigned char ent[8]; + int pos; + + if (fread (ent, sizeof (ent), 1, h->stream) != 1) + return -1; + + pos = ghw_get_i32 (h, &ent[4]); + if (h->flag_verbose) + printf (" %s at %d\n", ent, pos); + } + + if (fread (hdr, 4, 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "EOD", 4)) + return -1; + return 0; +} + +int +ghw_read_tailer (struct ghw_handler *h) +{ + unsigned char hdr[8]; + int pos; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + pos = ghw_get_i32 (h, &hdr[4]); + + if (h->flag_verbose) + printf ("Tailer: directory at %d\n", pos); + return 0; +} + +enum ghw_res +ghw_read_sm_hdr (struct ghw_handler *h, int *list) +{ + unsigned char hdr[4]; + int res; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + { + if (feof (h->stream)) + return ghw_res_eof; + else + return ghw_res_error; + } + if (memcmp (hdr, "SNP", 4) == 0) + { + res = ghw_read_snapshot (h); + if (res < 0) + return res; + return ghw_res_snapshot; + } + else if (memcmp (hdr, "CYC", 4) == 0) + { + res = ghw_read_cycle_start (h); + if (res < 0) + return res; + res = ghw_read_cycle_cont (h, list); + if (res < 0) + return res; + + return ghw_res_cycle; + } + else if (memcmp (hdr, "DIR", 4) == 0) + { + res = ghw_read_directory (h); + } + else if (memcmp (hdr, "TAI", 4) == 0) + { + res = ghw_read_tailer (h); + } + else + { + fprintf (stderr, "unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return -1; + } + if (res != 0) + return res; + return ghw_res_other; +} + +int +ghw_read_sm (struct ghw_handler *h, enum ghw_sm_type *sm) +{ + int res; + + while (1) + { + /* printf ("sm: state = %d\n", *sm); */ + switch (*sm) + { + case ghw_sm_init: + case ghw_sm_sect: + res = ghw_read_sm_hdr (h, NULL); + switch (res) + { + case ghw_res_other: + break; + case ghw_res_snapshot: + *sm = ghw_sm_sect; + return res; + case ghw_res_cycle: + *sm = ghw_sm_cycle; + return res; + default: + return res; + } + break; + case ghw_sm_cycle: + if (0) + printf ("Time is %lld fs\n", h->snap_time); + if (0) + ghw_disp_values (h); + + res = ghw_read_cycle_next (h); + if (res < 0) + return res; + if (res == 1) + { + res = ghw_read_cycle_cont (h, NULL); + if (res < 0) + return res; + return ghw_res_cycle; + } + res = ghw_read_cycle_end (h); + if (res < 0) + return res; + *sm = ghw_sm_sect; + break; + } + } +} + +int +ghw_read_cycle (struct ghw_handler *h) +{ + int res; + + res = ghw_read_cycle_start (h); + if (res < 0) + return res; + while (1) + { + res = ghw_read_cycle_cont (h, NULL); + if (res < 0) + return res; + + if (0) + printf ("Time is %lld fs\n", h->snap_time); + if (0) + ghw_disp_values (h); + + + res = ghw_read_cycle_next (h); + if (res < 0) + return res; + if (res == 0) + break; + } + res = ghw_read_cycle_end (h); + return res; +} + +int +ghw_read_dump (struct ghw_handler *h) +{ + unsigned char hdr[4]; + int res; + + while (1) + { + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + { + if (feof (h->stream)) + return 0; + else + return -1; + } + if (memcmp (hdr, "SNP", 4) == 0) + { + res = ghw_read_snapshot (h); + if (0 && res >= 0) + ghw_disp_values (h); + } + else if (memcmp (hdr, "CYC", 4) == 0) + { + res = ghw_read_cycle (h); + } + else if (memcmp (hdr, "DIR", 4) == 0) + { + res = ghw_read_directory (h); + } + else if (memcmp (hdr, "TAI", 4) == 0) + { + res = ghw_read_tailer (h); + } + else + { + fprintf (stderr, "unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return -1; + } + if (res != 0) + return res; + } +} + +struct ghw_section ghw_sections[] = { + { "\0\0\0", NULL }, + { "STR", ghw_read_str }, + { "HIE", ghw_read_hie }, + { "TYP", ghw_read_type }, + { "WKT", ghw_read_wk_types }, + { "EOH", ghw_read_eoh }, + { "SNP", ghw_read_snapshot }, + { "CYC", ghw_read_cycle }, + { "DIR", ghw_read_directory }, + { "TAI", ghw_read_tailer } +}; + +int +ghw_read_section (struct ghw_handler *h) +{ + unsigned char hdr[4]; + int i; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + { + if (feof (h->stream)) + return -2; + else + return -1; + } + + for (i = 1; i < sizeof (ghw_sections) / sizeof (*ghw_sections); i++) + if (memcmp (hdr, ghw_sections[i].name, 4) == 0) + return i; + + fprintf (stderr, "ghw_read_section: unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return 0; +} + +void +ghw_close (struct ghw_handler *h) +{ + if (h->stream) + { + fclose (h->stream); + h->stream = NULL; + } +} + +const char * +ghw_get_dir (int is_downto) +{ + return is_downto ? "downto" : "to"; +} + +void +ghw_disp_range (union ghw_type *type, union ghw_range *rng) +{ + switch (rng->kind) + { + case ghdl_rtik_type_e8: + printf ("%s %s %s", ghw_get_lit (type, rng->e8.left), + ghw_get_dir (rng->e8.dir), ghw_get_lit (type, rng->e8.right)); + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_p32: + printf ("%d %s %d", + rng->i32.left, ghw_get_dir (rng->i32.dir), rng->i32.right); + break; + case ghdl_rtik_type_i64: + case ghdl_rtik_type_p64: + printf ("%lld %s %lld", + rng->i64.left, ghw_get_dir (rng->i64.dir), rng->i64.right); + break; + case ghdl_rtik_type_f64: + printf ("%g %s %g", + rng->f64.left, ghw_get_dir (rng->f64.dir), rng->f64.right); + break; + default: + printf ("?(%d)", rng->kind); + } +} + +void +ghw_disp_type (struct ghw_handler *h, union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + { + struct ghw_type_enum *e = &t->en; + int i; + + printf ("type %s is (", e->name); + for (i = 0; i < e->nbr; i++) + { + if (i != 0) + printf (", "); + printf ("%s", e->lits[i]); + } + printf (");"); + if (e->wkt != ghw_wkt_unknown) + printf (" -- WKT:%d", e->wkt); + printf ("\n"); + } + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_f64: + { + struct ghw_type_scalar *s = &t->sc; + printf ("type %s is range <>;\n", s->name); + } + break; + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + { + int i; + + struct ghw_type_physical *p = &t->ph; + printf ("type %s is range <> units\n", p->name); + for (i = 0; i < p->nbr_units; i++) + { + struct ghw_unit *u = &p->units[i]; + printf (" %s = %lld %s;\n", u->name, u->val, p->units[0].name); + } + printf ("end units\n"); + } + break; + case ghdl_rtik_subtype_scalar: + { + struct ghw_subtype_scalar *s = &t->ss; + printf ("subtype %s is ", s->name); + ghw_disp_typename (h, s->base); + printf (" range "); + ghw_disp_range (s->base, s->rng); + printf (";\n"); + } + break; + case ghdl_rtik_type_array: + { + struct ghw_type_array *a = &t->ar; + int i; + + printf ("type %s is array (", a->name); + for (i = 0; i < a->nbr_dim; i++) + { + if (i != 0) + printf (", "); + ghw_disp_typename (h, a->dims[i]); + printf (" range <>"); + } + printf (") of "); + ghw_disp_typename (h, a->el); + printf (";\n"); + } + break; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + { + struct ghw_subtype_array *a = &t->sa; + int i; + + printf ("subtype %s is ", a->name); + ghw_disp_typename (h, (union ghw_type *)a->base); + printf (" ("); + for (i = 0; i < a->base->nbr_dim; i++) + { + if (i != 0) + printf (", "); + ghw_disp_range ((union ghw_type *)a->base, a->rngs[i]); + } + printf (");\n"); + } + break; + case ghdl_rtik_type_record: + { + struct ghw_type_record *r = &t->rec; + int i; + + printf ("type %s is record\n", r->name); + for (i = 0; i < r->nbr_fields; i++) + { + printf (" %s: ", r->el[i].name); + ghw_disp_typename (h, r->el[i].type); + printf ("\n"); + } + printf ("end record;\n"); + } + break; + default: + printf ("ghw_disp_type: unhandled type kind %d\n", t->kind); + } +} + +void +ghw_disp_types (struct ghw_handler *h) +{ + int i; + + for (i = 0; i < h->nbr_types; i++) + ghw_disp_type (h, h->types[i]); +} diff --git a/src/translate/grt/ghwlib.h b/src/translate/grt/ghwlib.h new file mode 100644 index 0000000..0138267 --- /dev/null +++ b/src/translate/grt/ghwlib.h @@ -0,0 +1,399 @@ +/* GHDL Wavefile reader library. + Copyright (C) 2005 Tristan Gingold + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ + + +#ifndef _GHWLIB_H_ +#define _GHWLIB_H_ + +#include <stdio.h> +#include <stdlib.h> + +#ifdef __GNUC__ +#include <stdint.h> +#endif + +enum ghdl_rtik { + ghdl_rtik_top, /* 0 */ + ghdl_rtik_library, + ghdl_rtik_package, + ghdl_rtik_package_body, + ghdl_rtik_entity, + ghdl_rtik_architecture, /* 5 */ + ghdl_rtik_process, + ghdl_rtik_block, + ghdl_rtik_if_generate, + ghdl_rtik_for_generate, + ghdl_rtik_instance, + ghdl_rtik_constant, + ghdl_rtik_iterator, + ghdl_rtik_variable, + ghdl_rtik_signal, + ghdl_rtik_file, + ghdl_rtik_port, + ghdl_rtik_generic, + ghdl_rtik_alias, + ghdl_rtik_guard, + ghdl_rtik_component, + ghdl_rtik_attribute, + ghdl_rtik_type_b2, /* 22 */ + ghdl_rtik_type_e8, + ghdl_rtik_type_e32, + ghdl_rtik_type_i32, /* 25 */ + ghdl_rtik_type_i64, + ghdl_rtik_type_f64, + ghdl_rtik_type_p32, + ghdl_rtik_type_p64, + ghdl_rtik_type_access, /* 30 */ + ghdl_rtik_type_array, + ghdl_rtik_type_record, + ghdl_rtik_type_file, + ghdl_rtik_subtype_scalar, + ghdl_rtik_subtype_array, /* 35 */ + ghdl_rtik_subtype_array_ptr, + ghdl_rtik_subtype_unconstrained_array, + ghdl_rtik_subtype_record, + ghdl_rtik_subtype_access, + ghdl_rtik_type_protected, + ghdl_rtik_element, + ghdl_rtik_unit, + ghdl_rtik_attribute_transaction, + ghdl_rtik_attribute_quiet, + ghdl_rtik_attribute_stable, + ghdl_rtik_error +}; + +/* Well-known types. */ +enum ghw_wkt_type { + ghw_wkt_unknown, + ghw_wkt_boolean, + ghw_wkt_bit, + ghw_wkt_std_ulogic +}; + +struct ghw_range_b2 +{ + enum ghdl_rtik kind : 8; + int dir : 8; /* 0: to, !0: downto. */ + unsigned char left; + unsigned char right; +}; + +struct ghw_range_e8 +{ + enum ghdl_rtik kind : 8; + int dir : 8; /* 0: to, !0: downto. */ + unsigned char left; + unsigned char right; +}; + +struct ghw_range_i32 +{ + enum ghdl_rtik kind : 8; + int dir : 8; /* 0: to, !0: downto. */ + int32_t left; + int32_t right; +}; + +struct ghw_range_i64 +{ + enum ghdl_rtik kind : 8; + int dir : 8; + int64_t left; + int64_t right; +}; + +struct ghw_range_f64 +{ + enum ghdl_rtik kind : 8; + int dir : 8; + double left; + double right; +}; + +union ghw_range +{ + enum ghdl_rtik kind : 8; + struct ghw_range_e8 e8; + struct ghw_range_i32 i32; + struct ghw_range_i64 i64; + struct ghw_range_f64 f64; +}; + +/* Note: the first two fields must be kind and name. */ +union ghw_type; + +struct ghw_type_common +{ + enum ghdl_rtik kind; + const char *name; +}; + +struct ghw_type_enum +{ + enum ghdl_rtik kind; + const char *name; + + enum ghw_wkt_type wkt; + unsigned int nbr; + const char **lits; +}; + +struct ghw_type_scalar +{ + enum ghdl_rtik kind; + const char *name; +}; + +struct ghw_unit +{ + const char *name; + int64_t val; +}; + +struct ghw_type_physical +{ + enum ghdl_rtik kind; + const char *name; + uint32_t nbr_units; + struct ghw_unit *units; +}; + +struct ghw_type_array +{ + enum ghdl_rtik kind; + const char *name; + + unsigned int nbr_dim; + union ghw_type *el; + union ghw_type **dims; +}; + +struct ghw_subtype_array +{ + enum ghdl_rtik kind; + const char *name; + + struct ghw_type_array *base; + int nbr_el; + union ghw_range **rngs; +}; + +struct ghw_subtype_scalar +{ + enum ghdl_rtik kind; + const char *name; + + union ghw_type *base; + union ghw_range *rng; +}; + +struct ghw_record_element +{ + const char *name; + union ghw_type *type; +}; + +struct ghw_type_record +{ + enum ghdl_rtik kind; + const char *name; + + unsigned int nbr_fields; + int nbr_el; /* Number of scalar signals. */ + struct ghw_record_element *el; +}; + +union ghw_type +{ + enum ghdl_rtik kind; + struct ghw_type_common common; + struct ghw_type_enum en; + struct ghw_type_scalar sc; + struct ghw_type_physical ph; + struct ghw_subtype_scalar ss; + struct ghw_subtype_array sa; + struct ghw_type_array ar; + struct ghw_type_record rec; +}; + +union ghw_val +{ + unsigned char b2; + unsigned char e8; + int32_t i32; + int64_t i64; + double f64; +}; + +/* A non-composite signal. */ +struct ghw_sig +{ + union ghw_type *type; + union ghw_val *val; +}; + +enum ghw_hie_kind { + ghw_hie_eoh = 0, + ghw_hie_design = 1, + ghw_hie_block = 3, + ghw_hie_generate_if = 4, + ghw_hie_generate_for = 5, + ghw_hie_instance = 6, + ghw_hie_package = 7, + ghw_hie_process = 13, + ghw_hie_generic = 14, + ghw_hie_eos = 15, + ghw_hie_signal = 16, + ghw_hie_port_in = 17, + ghw_hie_port_out = 18, + ghw_hie_port_inout = 19, + ghw_hie_port_buffer = 20, + ghw_hie_port_linkage = 21 +}; + +struct ghw_hie +{ + enum ghw_hie_kind kind; + struct ghw_hie *parent; + const char *name; + struct ghw_hie *brother; + union + { + struct + { + struct ghw_hie *child; + union ghw_type *iter_type; + union ghw_val *iter_value; + } blk; + struct + { + union ghw_type *type; + /* Array of signal elements. + Last element is 0. */ + unsigned int *sigs; + } sig; + } u; +}; + +struct ghw_handler +{ + FILE *stream; + /* True if words are big-endian. */ + int word_be; + int word_len; + int off_len; + /* Minor version. */ + int version; + + /* Set by user. */ + int flag_verbose; + + /* String table. */ + /* Number of strings. */ + int nbr_str; + /* Size of the strings (without nul). */ + int str_size; + /* String table. */ + char **str_table; + /* Array containing strings. */ + char *str_content; + + /* Type table. */ + int nbr_types; + union ghw_type **types; + + /* Non-composite (or basic) signals. */ + int nbr_sigs; + struct ghw_sig *sigs; + + /* Hierarchy. */ + struct ghw_hie *hie; + + /* Time of the next cycle. */ + int64_t snap_time; +}; + +/* Open a GHW file with H. + Return < 0 in case of error. */ +int ghw_open (struct ghw_handler *h, const char *filename); + +union ghw_type *ghw_get_base_type (union ghw_type *t); + +/* Put the ASCII representation of VAL into BUF, whose size if LEN. + A NUL is always written to BUF. */ +void ghw_get_value (char *buf, int len, + union ghw_val *val, union ghw_type *type); + +const char *ghw_get_hie_name (struct ghw_hie *h); + +void ghw_disp_hie (struct ghw_handler *h, struct ghw_hie *top); + +int ghw_read_base (struct ghw_handler *h); + +void ghw_disp_values (struct ghw_handler *h); + +int ghw_read_cycle_start (struct ghw_handler *h); + +int ghw_read_cycle_cont (struct ghw_handler *h, int *list); + +int ghw_read_cycle_next (struct ghw_handler *h); + +int ghw_read_cycle_end (struct ghw_handler *h); + +enum ghw_sm_type { + /* At init; + Read section name. */ + ghw_sm_init = 0, + ghw_sm_sect = 1, + ghw_sm_cycle = 2 +}; + +enum ghw_res { + ghw_res_error = -1, + ghw_res_eof = -2, + ghw_res_ok = 0, + ghw_res_snapshot = 1, + ghw_res_cycle = 2, + ghw_res_other = 3 +}; + +int ghw_read_sm (struct ghw_handler *h, enum ghw_sm_type *sm); + +int ghw_read_dump (struct ghw_handler *h); + +struct ghw_section { + const char name[4]; + int (*handler)(struct ghw_handler *h); +}; + +extern struct ghw_section ghw_sections[]; + +int ghw_read_section (struct ghw_handler *h); + +void ghw_close (struct ghw_handler *h); + +const char *ghw_get_dir (int is_downto); + +/* Note: TYPE must be a base type (used only to display literals). */ +void ghw_disp_range (union ghw_type *type, union ghw_range *rng); + +void ghw_disp_type (struct ghw_handler *h, union ghw_type *t); + +void ghw_disp_types (struct ghw_handler *h); +#endif /* _GHWLIB_H_ */ diff --git a/src/translate/grt/grt-arch.ads b/src/translate/grt/grt-arch.ads new file mode 100644 index 0000000..5f5aa0e --- /dev/null +++ b/src/translate/grt/grt-arch.ads @@ -0,0 +1,2 @@ +With Grt.Arch_None; +Package Grt.Arch renames Grt.Arch_None; diff --git a/src/translate/grt/grt-arch_none.adb b/src/translate/grt/grt-arch_none.adb new file mode 100644 index 0000000..14db1c7 --- /dev/null +++ b/src/translate/grt/grt-arch_none.adb @@ -0,0 +1,7 @@ +package body Grt.Arch_None is + function Get_Time_Stamp return Ghdl_U64 is + begin + return 0; + end Get_Time_Stamp; +end Grt.Arch_None; + diff --git a/src/translate/grt/grt-arch_none.ads b/src/translate/grt/grt-arch_none.ads new file mode 100644 index 0000000..f8ae437 --- /dev/null +++ b/src/translate/grt/grt-arch_none.ads @@ -0,0 +1,6 @@ +with Grt.Types; use Grt.Types; + +package Grt.Arch_None is + function Get_Time_Stamp return Ghdl_U64; + pragma Inline (Get_Time_Stamp); +end Grt.Arch_None; diff --git a/src/translate/grt/grt-astdio.adb b/src/translate/grt/grt-astdio.adb new file mode 100644 index 0000000..456d024 --- /dev/null +++ b/src/translate/grt/grt-astdio.adb @@ -0,0 +1,231 @@ +-- GHDL Run Time (GRT) stdio subprograms for GRT types. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.C; use Grt.C; + +package body Grt.Astdio is + procedure Put (Stream : FILEs; Str : String) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Str'Address, Str'Length, 1, Stream); + end Put; + + procedure Put (Stream : FILEs; C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), Stream); + end Put; + + procedure Put (Stream : FILEs; Str : Ghdl_C_String) + is + Len : Natural; + S : size_t; + pragma Unreferenced (S); + begin + Len := strlen (Str); + S := fwrite (Str (1)'Address, size_t (Len), 1, Stream); + end Put; + + procedure New_Line (Stream : FILEs) is + begin + Put (Stream, Nl); + end New_Line; + + procedure Put (Str : String) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Str'Address, Str'Length, 1, stdout); + end Put; + + procedure Put (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), stdout); + end Put; + + procedure Put (Str : Ghdl_C_String) + is + Len : Natural; + S : size_t; + pragma Unreferenced (S); + begin + Len := strlen (Str); + S := fwrite (Str (1)'Address, size_t (Len), 1, stdout); + end Put; + + procedure New_Line is + begin + Put (Nl); + end New_Line; + + procedure Put_Line (Str : String) + is + begin + Put (Str); + New_Line; + end Put_Line; + + procedure Put_Str_Len (Stream : FILEs; Str : Ghdl_Str_Len_Type) + is + S : String (1 .. 3); + begin + if Str.Str = null then + S (1) := '''; + S (2) := Character'Val (Str.Len); + S (3) := '''; + Put (Stream, S); + else + Put (Stream, Str.Str (1 .. Str.Len)); + end if; + end Put_Str_Len; + + generic + type Ntype is range <>; + Max_Len : Natural; + procedure Put_Ntype (Stream : FILEs; N : Ntype); + + procedure Put_Ntype (Stream : FILEs; N : Ntype) + is + Str : String (1 .. Max_Len); + P : Natural := Str'Last; + V : Ntype; + begin + -- V is negativ. + if N > 0 then + V := -N; + else + V := N; + end if; + loop + Str (P) := Character'Val (48 - (V rem 10)); -- V is <= 0. + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + if N < 0 then + P := P - 1; + Str (P) := '-'; + end if; + Put (Stream, Str (P .. Max_Len)); + end Put_Ntype; + + generic + type Utype is mod <>; + Max_Len : Natural; + procedure Put_Utype (Stream : FILEs; N : Utype); + + procedure Put_Utype (Stream : FILEs; N : Utype) + is + Str : String (1 .. Max_Len); + P : Natural := Str'Last; + V : Utype := N; + begin + loop + Str (P) := Character'Val (48 + (V rem 10)); + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + Put (Stream, Str (P .. Max_Len)); + end Put_Utype; + + procedure Put_I32_1 is new Put_Ntype (Ntype => Ghdl_I32, Max_Len => 11); + procedure Put_I32 (Stream : FILEs; I32 : Ghdl_I32) renames Put_I32_1; + + procedure Put_U32_1 is new Put_Utype (Utype => Ghdl_U32, Max_Len => 11); + procedure Put_U32 (Stream : FILEs; U32 : Ghdl_U32) renames Put_U32_1; + + procedure Put_I64_1 is new Put_Ntype (Ntype => Ghdl_I64, Max_Len => 20); + procedure Put_I64 (Stream : FILEs; I64 : Ghdl_I64) renames Put_I64_1; + + procedure Put_U64_1 is new Put_Utype (Utype => Ghdl_U64, Max_Len => 20); + procedure Put_U64 (Stream : FILEs; U64 : Ghdl_U64) renames Put_U64_1; + + procedure Put_F64 (Stream : FILEs; F64 : Ghdl_F64) + is + procedure Fprintf_G (Stream : FILEs; + Arg : Ghdl_F64); + pragma Import (C, Fprintf_G, "__ghdl_fprintf_g"); + begin + Fprintf_G (Stream, F64); + end Put_F64; + + Hex_Map : constant array (0 .. 15) of Character := "0123456789ABCDEF"; + + procedure Put (Stream : FILEs; Addr : System.Address) + is + Res : String (1 .. System.Word_Size / 4); + Val : Integer_Address := To_Integer (Addr); + begin + for I in reverse Res'Range loop + Res (I) := Hex_Map (Natural (Val and 15)); + Val := Val / 16; + end loop; + Put (Stream, Res); + end Put; + + procedure Put_Dir (Stream : FILEs; Dir : Ghdl_Dir_Type) is + begin + case Dir is + when Dir_To => + Put (Stream, " to "); + when Dir_Downto => + Put (Stream, " downto "); + end case; + end Put_Dir; + + procedure Put_Time (Stream : FILEs; Time : Std_Time) is + begin + if Time = Std_Time'First then + Put (Stream, "-Inf"); + else + -- Do not bother with sec, min, and hr. + if (Time mod 1_000_000_000_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000_000_000)); + Put (Stream, "ms"); + elsif (Time mod 1_000_000_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000_000)); + Put (Stream, "us"); + elsif (Time mod 1_000_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000)); + Put (Stream, "ns"); + elsif (Time mod 1_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000)); + Put (Stream, "ps"); + else + Put_I64 (Stream, Ghdl_I64 (Time)); + Put (Stream, "fs"); + end if; + end if; + end Put_Time; + +end Grt.Astdio; diff --git a/src/translate/grt/grt-astdio.ads b/src/translate/grt/grt-astdio.ads new file mode 100644 index 0000000..8e8b739 --- /dev/null +++ b/src/translate/grt/grt-astdio.ads @@ -0,0 +1,60 @@ +-- GHDL Run Time (GRT) stdio subprograms for GRT types. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; +with Grt.Types; use Grt.Types; +with Grt.Stdio; use Grt.Stdio; + +package Grt.Astdio is + pragma Preelaborate (Grt.Astdio); + + -- Procedures to disp on STREAM. + procedure Put (Stream : FILEs; Str : String); + procedure Put_I32 (Stream : FILEs; I32 : Ghdl_I32); + procedure Put_U32 (Stream : FILEs; U32 : Ghdl_U32); + procedure Put_I64 (Stream : FILEs; I64 : Ghdl_I64); + procedure Put_U64 (Stream : FILEs; U64 : Ghdl_U64); + procedure Put_F64 (Stream : FILEs; F64 : Ghdl_F64); + procedure Put (Stream : FILEs; Addr : System.Address); + procedure Put (Stream : FILEs; Str : Ghdl_C_String); + procedure Put (Stream : FILEs; C : Character); + procedure New_Line (Stream : FILEs); + + -- Display time with unit, without space. + -- Eg: 10ns, 100ms, 97ps... + procedure Put_Time (Stream : FILEs; Time : Std_Time); + + -- And on stdout. + procedure Put (Str : String); + procedure Put (C : Character); + procedure New_Line; + procedure Put_Line (Str : String); + procedure Put (Str : Ghdl_C_String); + + -- Put STR using put procedures. + procedure Put_Str_Len (Stream : FILEs; Str : Ghdl_Str_Len_Type); + + -- Put " to " or " downto ". + procedure Put_Dir (Stream : FILEs; Dir : Ghdl_Dir_Type); +end Grt.Astdio; diff --git a/src/translate/grt/grt-avhpi.adb b/src/translate/grt/grt-avhpi.adb new file mode 100644 index 0000000..b935fd9 --- /dev/null +++ b/src/translate/grt/grt-avhpi.adb @@ -0,0 +1,1142 @@ +-- GHDL Run Time (GRT) - VHPI implementation for Ada. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; + +package body Grt.Avhpi is + procedure Get_Root_Inst (Res : out VhpiHandleT) + is + begin + Res := (Kind => VhpiRootInstK, + Ctxt => Get_Top_Context); + end Get_Root_Inst; + + procedure Get_Package_Inst (Res : out VhpiHandleT) is + begin + Res := (Kind => VhpiIteratorK, + Ctxt => (Base => Null_Address, + Block => To_Ghdl_Rti_Access (Ghdl_Rti_Top'Address)), + Rel => VhpiPackInsts, + It_Cur => 0, + It2 => 0, + Max2 => 0); + end Get_Package_Inst; + + -- Number of elements in an array. + function Ranges_To_Length (Rngs : Ghdl_Range_Array; + Indexes : Ghdl_Rti_Arr_Acc) + return Ghdl_Index_Type + is + Res : Ghdl_Index_Type; + begin + Res := 1; + for I in Rngs'Range loop + Res := Res * Range_To_Length + (Rngs (I), Get_Base_Type (Indexes (I - Rngs'First))); + end loop; + return Res; + end Ranges_To_Length; + + procedure Vhpi_Iterator (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default value in case of success. + Res := (Kind => VhpiIteratorK, + Ctxt => Ref.Ctxt, + Rel => Rel, + It_Cur => 0, + It2 => 0, + Max2 => 0); + Error := AvhpiErrorOk; + + case Rel is + when VhpiInternalRegions => + case Ref.Kind is + when VhpiRootInstK + | VhpiArchBodyK + | VhpiBlockStmtK + | VhpiIfGenerateK => + return; + when VhpiForGenerateK => + Res.It2 := 1; + return; + when VhpiCompInstStmtK => + Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt); + return; + when others => + null; + end case; + when VhpiDecls => + case Ref.Kind is + when VhpiArchBodyK + | VhpiBlockStmtK + | VhpiIfGenerateK + | VhpiForGenerateK => + return; + when VhpiRootInstK + | VhpiPackInstK => + Res.It2 := 1; + return; + when VhpiCompInstStmtK => + Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt); + Res.It2 := 1; + return; + when others => + null; + end case; + when VhpiIndexedNames => + case Ref.Kind is + when VhpiGenericDeclK => + Res := (Kind => AvhpiNameIteratorK, + Ctxt => Ref.Ctxt, + N_Addr => Avhpi_Get_Address (Ref), + N_Type => Ref.Obj.Obj_Type, + N_Idx => 0, + N_Obj => Ref.Obj); + when VhpiIndexedNameK => + Res := (Kind => AvhpiNameIteratorK, + Ctxt => Ref.Ctxt, + N_Addr => Ref.N_Addr, + N_Type => Ref.N_Type, + N_Idx => 0, + N_Obj => Ref.N_Obj); + when others => + Error := AvhpiErrorNotImplemented; + return; + end case; + case Res.N_Type.Kind is + when Ghdl_Rtik_Subtype_Array => + declare + St : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Res.N_Type); + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Res.Ctxt), + Bt, Rngs); + Res.N_Idx := Ranges_To_Length (Rngs, Bt.Indexes); + end; + when others => + Error := AvhpiErrorBadRel; + end case; + return; + when others => + null; + end case; + -- Failure. + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end Vhpi_Iterator; + + -- OBJ_RTI is the RTI for the base name. + function Add_Index (Ctxt : Rti_Context; + Obj_Base : Address; + Obj_Rti : Ghdl_Rtin_Object_Acc; + El_Type : Ghdl_Rti_Access; + Off : Ghdl_Index_Type) return Address + is + pragma Unreferenced (Ctxt); + Is_Sig : Boolean; + El_Size : Ghdl_Index_Type; + El_Type1 : Ghdl_Rti_Access; + begin + case Obj_Rti.Common.Kind is + when Ghdl_Rtik_Generic => + Is_Sig := False; + when others => + Internal_Error ("add_index"); + end case; + + if El_Type.Kind = Ghdl_Rtik_Subtype_Scalar then + El_Type1 := Get_Base_Type (El_Type); + else + El_Type1 := El_Type; + end if; + + case El_Type1.Kind is + when Ghdl_Rtik_Type_P64 => + if Is_Sig then + El_Size := Address'Size / Storage_Unit; + else + El_Size := Ghdl_I64'Size / Storage_Unit; + end if; + when Ghdl_Rtik_Subtype_Array => + if Is_Sig then + El_Size := Ghdl_Index_Type + (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Sigsize); + else + El_Size := Ghdl_Index_Type + (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Valsize); + end if; + when others => + Internal_Error ("add_index"); + end case; + return Obj_Base + Off * El_Size; + end Add_Index; + + procedure Vhpi_Scan_Indexed_Name (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + El_Type : Ghdl_Rti_Access; + begin + if Iterator.N_Idx = 0 then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + El_Type := To_Ghdl_Rtin_Type_Array_Acc + (Get_Base_Type (Iterator.N_Type)).Element; + + Res := (Kind => VhpiIndexedNameK, + Ctxt => Iterator.Ctxt, + N_Addr => Iterator.N_Addr, + N_Type => El_Type, + N_Idx => 0, + N_Obj => Iterator.N_Obj); + + -- Increment Address. + Iterator.N_Addr := Add_Index + (Iterator.Ctxt, Iterator.N_Addr, Iterator.N_Obj, El_Type, 1); + + Iterator.N_Idx := Iterator.N_Idx - 1; + Error := AvhpiErrorOk; + end Vhpi_Scan_Indexed_Name; + + procedure Vhpi_Scan_Internal_Regions (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + Blk : Ghdl_Rtin_Block_Acc; + Ch : Ghdl_Rti_Access; + Nblk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + if Blk = null then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + loop + << Again >> null; + if Iterator.It_Cur >= Blk.Nbr_Child then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + Ch := Blk.Children (Iterator.It_Cur); + Nblk := To_Ghdl_Rtin_Block_Acc (Ch); + + if Iterator.Max2 /= 0 then + -- A for generate. + Iterator.It2 := Iterator.It2 + 1; + if Iterator.It2 >= Iterator.Max2 then + -- End of loop. + Iterator.Max2 := 0; + Iterator.It_Cur := Iterator.It_Cur + 1; + goto Again; + else + declare + Base : Address; + begin + Base := To_Addr_Acc (Iterator.Ctxt.Base + Nblk.Loc).all; + Base := Base + Iterator.It2 * Nblk.Size; + Res := (Kind => VhpiForGenerateK, + Ctxt => (Base => Base, + Block => Ch)); + + Error := AvhpiErrorOk; + return; + end; + end if; + end if; + + + Iterator.It_Cur := Iterator.It_Cur + 1; + + case Ch.Kind is + when Ghdl_Rtik_Process => + Res := (Kind => VhpiProcessStmtK, + Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc, + Block => Ch)); + Error := AvhpiErrorOk; + return; + when Ghdl_Rtik_Block => + Res := (Kind => VhpiBlockStmtK, + Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc, + Block => Ch)); + Error := AvhpiErrorOk; + return; + when Ghdl_Rtik_If_Generate => + Res := (Kind => VhpiIfGenerateK, + Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base + + Nblk.Loc).all, + Block => Ch)); + -- Return only if the condition is true. + if Res.Ctxt.Base /= Null_Address then + Error := AvhpiErrorOk; + return; + end if; + when Ghdl_Rtik_For_Generate => + Res := (Kind => VhpiForGenerateK, + Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base + + Nblk.Loc).all, + Block => Ch)); + Iterator.Max2 := Get_For_Generate_Length (Nblk, Iterator.Ctxt); + Iterator.It2 := 0; + if Iterator.Max2 > 0 then + Iterator.It_Cur := Iterator.It_Cur - 1; + Error := AvhpiErrorOk; + return; + end if; + -- If the iterator range is nul, then continue to scan. + when Ghdl_Rtik_Instance => + Res := (Kind => VhpiCompInstStmtK, + Ctxt => Iterator.Ctxt, + Inst => To_Ghdl_Rtin_Instance_Acc (Ch)); + Error := AvhpiErrorOk; + return; + when others => + -- Next one. + null; + end case; + end loop; + end Vhpi_Scan_Internal_Regions; + + procedure Rti_To_Handle (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Res : out VhpiHandleT) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Signal => + Res := (Kind => VhpiSigDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Port => + Res := (Kind => VhpiPortDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Generic => + Res := (Kind => VhpiGenericDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Subtype_Array => + declare + Atype : Ghdl_Rtin_Subtype_Array_Acc; + Bt : Ghdl_Rtin_Type_Array_Acc; + begin + Atype := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt := Atype.Basetype; + if Atype.Name = Bt.Name then + Res := (Kind => VhpiArrayTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + else + Res := (Kind => VhpiSubtypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + end if; + end; + when Ghdl_Rtik_Type_Array => + Res := (Kind => VhpiArrayTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Res := (Kind => VhpiEnumTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 => + Res := (Kind => VhpiPhysTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Subtype_Scalar => + Res := (Kind => VhpiSubtypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when others => + Res := (Kind => VhpiUndefined, + Ctxt => Ctxt); + end case; + end Rti_To_Handle; + + procedure Vhpi_Scan_Decls (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + Blk : Ghdl_Rtin_Block_Acc; + Ch : Ghdl_Rti_Access; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + + -- If there is no context, returns now. + -- This may happen for a unbound compinststmt. + if Blk = null then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + if Iterator.It2 = 1 then + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + -- Iterate on the entity. + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + when Ghdl_Rtik_Package_Body => + -- Iterate on the package. + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + when Ghdl_Rtik_Package => + -- Only for std.standard. + Iterator.It2 := 0; + when others => + Internal_Error ("vhpi_scan_decls"); + end case; + end if; + loop + loop + exit when Iterator.It_Cur >= Blk.Nbr_Child; + + Ch := Blk.Children (Iterator.It_Cur); + + Iterator.It_Cur := Iterator.It_Cur + 1; + + case Ch.Kind is + when Ghdl_Rtik_Port + | Ghdl_Rtik_Generic + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Type_Array + | Ghdl_Rtik_Subtype_Array + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Subtype_Scalar => + Rti_To_Handle (Ch, Iterator.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + return; + else + Internal_Error ("vhpi_scan_decls"); + end if; + when others => + null; + end case; + end loop; + case Iterator.It2 is + when 1 => + -- Iterate on the architecture/package decl. + Iterator.It2 := 0; + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + Iterator.It_Cur := 0; + when others => + exit; + end case; + end loop; + Error := AvhpiErrorIteratorEnd; + end Vhpi_Scan_Decls; + + procedure Vhpi_Scan (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + if Iterator.Kind = AvhpiNameIteratorK then + case Iterator.N_Type.Kind is + when Ghdl_Rtik_Subtype_Array => + Vhpi_Scan_Indexed_Name (Iterator, Res, Error); + when others => + Error := AvhpiErrorHandle; + Res := Null_Handle; + end case; + return; + elsif Iterator.Kind /= VhpiIteratorK then + Error := AvhpiErrorHandle; + Res := Null_Handle; + return; + end if; + + case Iterator.Rel is + when VhpiPackInsts => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + if Iterator.It_Cur >= Blk.Nbr_Child then + Error := AvhpiErrorIteratorEnd; + return; + end if; + Res := (Kind => VhpiPackInstK, + Ctxt => (Base => Null_Address, + Block => Blk.Children (Iterator.It_Cur))); + Iterator.It_Cur := Iterator.It_Cur + 1; + Error := AvhpiErrorOk; + end; + when VhpiInternalRegions => + Vhpi_Scan_Internal_Regions (Iterator, Res, Error); + when VhpiDecls => + Vhpi_Scan_Decls (Iterator, Res, Error); + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Scan; + + function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String + is + begin + case Obj.Kind is + when VhpiEnumTypeDeclK => + return To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name; + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK + | VhpiProcessStmtK + | VhpiBlockStmtK + | VhpiIfGenerateK + | VhpiForGenerateK => + return To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name; + when VhpiRootInstK => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + return Blk.Name; + end; + when VhpiCompInstStmtK => + return Obj.Inst.Name; + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK => + return Obj.Obj.Name; + when VhpiSubtypeDeclK => + return To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name; + when others => + return null; + end case; + end Avhpi_Get_Base_Name; + + procedure Vhpi_Get_Str (Property : VhpiStrPropertyT; + Obj : VhpiHandleT; + Res : out String; + Len : out Natural) + is + subtype R_Type is String (1 .. Res'Length); + R : R_Type renames Res; + + procedure Add (C : Character) is + begin + Len := Len + 1; + if Len <= R_Type'Last then + R (Len) := C; + end if; + end Add; + + procedure Add (Str : String) is + begin + for I in Str'Range loop + Add (Str (I)); + end loop; + end Add; + + procedure Add (Str : Ghdl_C_String) is + begin + for I in Str'Range loop + exit when Str (I) = NUL; + Add (Str (I)); + end loop; + end Add; + begin + Len := 0; + + case Property is + when VhpiNameP => + case Obj.Kind is + when VhpiEnumTypeDeclK => + Add (To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name); + when VhpiSubtypeDeclK => + Add (To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name); + when VhpiArrayTypeDeclK => + Add (To_Ghdl_Rtin_Type_Array_Acc (Obj.Atype).Name); + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK + | VhpiProcessStmtK + | VhpiBlockStmtK + | VhpiIfGenerateK => + Add (To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name); + when VhpiRootInstK => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + Add (Blk.Name); + end; + when VhpiCompInstStmtK => + Add (Obj.Inst.Name); + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK => + Add (Obj.Obj.Name); + when VhpiForGenerateK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Iter : Ghdl_Rtin_Object_Acc; + Iter_Type : Ghdl_Rti_Access; + Vptr : Ghdl_Value_Ptr; + Buf : String (1 .. 12); + Buf_Len : Natural; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Vptr := To_Ghdl_Value_Ptr + (Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Obj.Ctxt)); + Add (Blk.Name); + Add ('('); + Iter_Type := Iter.Obj_Type; + if Iter_Type.Kind = Ghdl_Rtik_Subtype_Scalar then + Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc + (Iter_Type).Basetype; + end if; + case Iter_Type.Kind is + when Ghdl_Rtik_Type_I32 => + To_String (Buf, Buf_Len, Vptr.I32); + Add (Buf (Buf_Len .. Buf'Last)); +-- when Ghdl_Rtik_Type_E8 => +-- Disp_Enum_Value +-- (Stream, Rti, Ghdl_Index_Type (Vptr.E8)); +-- when Ghdl_Rtik_Type_E32 => +-- Disp_Enum_Value +-- (Stream, Rti, Ghdl_Index_Type (Vptr.E32)); +-- when Ghdl_Rtik_Type_B1 => +-- Disp_Enum_Value +-- (Stream, Rti, +-- Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1))); + when others => + Add ('?'); + end case; + --Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False); + Add (')'); + end; + when others => + null; + end case; + when VhpiCompNameP => + case Obj.Kind is + when VhpiCompInstStmtK => + declare + Comp : Ghdl_Rtin_Component_Acc; + begin + Comp := To_Ghdl_Rtin_Component_Acc (Obj.Inst.Instance); + if Comp.Common.Kind = Ghdl_Rtik_Component then + Add (Comp.Name); + end if; + end; + when others => + null; + end case; + when VhpiLibLogicalNameP => + case Obj.Kind is + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Lib : Ghdl_Rtin_Type_Scalar_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + if Blk.Common.Kind = Ghdl_Rtik_Package_Body then + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + end if; + Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent); + if Lib.Common.Kind /= Ghdl_Rtik_Library then + Internal_Error ("VhpiLibLogicalNameP"); + end if; + Add (Lib.Name); + end; + when others => + null; + end case; + when VhpiFullNameP => + declare + Rstr : Rstring; + Nctxt : Rti_Context; + begin + if Obj.Kind = VhpiCompInstStmtK then + Get_Instance_Context (Obj.Inst, Obj.Ctxt, Nctxt); + Get_Path_Name (Rstr, Nctxt, ':', False); + else + Get_Path_Name (Rstr, Obj.Ctxt, ':', False); + end if; + Copy (Rstr, R, Len); + Free (Rstr); + case Obj.Kind is + when VhpiCompInstStmtK => + null; + when VhpiPortDeclK + | VhpiSigDeclK => + Add (':'); + Add (Obj.Obj.Name); + when others => + null; + end case; + end; + when others => + null; + end case; + end Vhpi_Get_Str; + + procedure Vhpi_Handle (Rel : VhpiOneToOneT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default error. + Error := AvhpiErrorNotImplemented; + + case Rel is + when VhpiDesignUnit => + case Ref.Kind is + when VhpiRootInstK => + case Ref.Ctxt.Block.Kind is + when Ghdl_Rtik_Architecture => + Res := (Kind => VhpiArchBodyK, + Ctxt => Ref.Ctxt); + Error := AvhpiErrorOk; + return; + when others => + return; + end case; + when others => + return; + end case; + when VhpiPrimaryUnit => + case Ref.Kind is + when VhpiArchBodyK => + declare + Rti : Ghdl_Rti_Access; + Ent : Ghdl_Rtin_Block_Acc; + begin + Rti := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block).Parent; + Ent := To_Ghdl_Rtin_Block_Acc (Rti); + Res := (Kind => VhpiEntityDeclK, + Ctxt => (Base => Ref.Ctxt.Base + Ent.Loc, + Block => Rti)); + Error := AvhpiErrorOk; + end; + when others => + return; + end case; + when VhpiIterScheme => + case Ref.Kind is + when VhpiForGenerateK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Iter : Ghdl_Rtin_Object_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Res := (Kind => VhpiConstDeclK, + Ctxt => Ref.Ctxt, + Obj => Iter); + Error := AvhpiErrorOk; + end; + when others => + return; + end case; + when VhpiSubtype => + case Ref.Kind is + when VhpiPortDeclK + | VhpiSigDeclK + | VhpiGenericDeclK + | VhpiConstDeclK => + Res := (Kind => VhpiSubtypeIndicK, + Ctxt => Ref.Ctxt, + Atype => Ref.Obj.Obj_Type); + Error := AvhpiErrorOk; + when others => + return; + end case; + when VhpiTypeMark => + case Ref.Kind is + when VhpiSubtypeIndicK => + -- FIXME: if the subtype is anonymous, return the base type. + Rti_To_Handle (Ref.Atype, Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + return; + when others => + return; + end case; + when VhpiBaseType => + declare + Atype : Ghdl_Rti_Access; + begin + case Ref.Kind is + when VhpiSubtypeIndicK + | VhpiSubtypeDeclK + | VhpiArrayTypeDeclK => + Atype := Ref.Atype; + when VhpiGenericDeclK => + Atype := Ref.Obj.Obj_Type; + when VhpiIndexedNameK => + Atype := Ref.N_Type; + when others => + return; + end case; + case Atype.Kind is + when Ghdl_Rtik_Subtype_Array => + Rti_To_Handle + (To_Ghdl_Rti_Access (To_Ghdl_Rtin_Subtype_Array_Acc + (Atype).Basetype), + Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + when Ghdl_Rtik_Subtype_Scalar => + Rti_To_Handle + (To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype, + Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + when Ghdl_Rtik_Type_Array => + Res := Ref; + Error := AvhpiErrorOk; + when others => + return; + end case; + end; + when VhpiElemSubtype => + declare + Base_Type : Ghdl_Rtin_Type_Array_Acc; + begin + case Ref.Atype.Kind is + when Ghdl_Rtik_Subtype_Array => + Base_Type := + To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype).Basetype; + when Ghdl_Rtik_Type_Array => + Base_Type := To_Ghdl_Rtin_Type_Array_Acc (Ref.Atype); + when others => + return; + end case; + Rti_To_Handle (Base_Type.Element, Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + end; + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Handle; + + procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Index : Natural; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default error. + Error := AvhpiErrorNotImplemented; + + case Rel is + when VhpiConstraints => + case Ref.Kind is + when VhpiSubtypeIndicK => + if Ref.Atype.Kind = Ghdl_Rtik_Subtype_Array then + declare + Arr_Subtype : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype); + Basetype : constant Ghdl_Rtin_Type_Array_Acc := + Arr_Subtype.Basetype; + Idx : constant Ghdl_Index_Type := + Ghdl_Index_Type (Index); + Bounds : Ghdl_Range_Array (0 .. Basetype.Nbr_Dim - 1); + Range_Basetype : Ghdl_Rti_Access; + begin + if Idx not in 1 .. Basetype.Nbr_Dim then + Res := Null_Handle; + Error := AvhpiErrorBadIndex; + return; + end if; + -- constraint type is basetype.indexes (idx - 1) + Bound_To_Range + (Loc_To_Addr (Arr_Subtype.Common.Depth, + Arr_Subtype.Bounds, Ref.Ctxt), + Basetype, Bounds); + Res := (Kind => VhpiIntRangeK, + Ctxt => Ref.Ctxt, + Rng_Type => Basetype.Indexes (Idx - 1), + Rng_Addr => Bounds (Idx - 1)); + Range_Basetype := Get_Base_Type (Res.Rng_Type); + case Range_Basetype.Kind is + when Ghdl_Rtik_Type_I32 => + null; + when Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Res := (Kind => VhpiEnumRangeK, + Ctxt => Ref.Ctxt, + Rng_Type => Res.Rng_Type, + Rng_Addr => Res.Rng_Addr); + when others => + Internal_Error + ("vhpi_handle_by_index/constraint"); + end case; + Error := AvhpiErrorOk; + end; + end if; + when others => + return; + end case; + when VhpiIndexedNames => + declare + Base_Type, El_Type : VhpiHandleT; + begin + Vhpi_Handle (VhpiBaseType, Ref, Base_Type, Error); + if Error /= AvhpiErrorOk then + return; + end if; + if Vhpi_Get_Kind (Base_Type) /= VhpiArrayTypeDeclK then + Error := AvhpiErrorBadRel; + return; + end if; + Vhpi_Handle (VhpiElemSubtype, Base_Type, El_Type, Error); + if Error /= AvhpiErrorOk then + return; + end if; + Res := (Kind => VhpiIndexedNameK, + Ctxt => Ref.Ctxt, + N_Addr => Avhpi_Get_Address (Ref), + N_Type => El_Type.Atype, + N_Idx => Ghdl_Index_Type (Index), + N_Obj => Ref.Obj); + if Res.N_Addr = Null_Address then + Error := AvhpiErrorBadRel; + return; + end if; + Res.N_Addr := Add_Index + (Res.Ctxt, Res.N_Addr, Res.N_Obj, Res.N_Type, + Ghdl_Index_Type (Index)); + end; + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Handle_By_Index; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out VhpiIntT; + Error : out AvhpiErrorT) + is + begin + case Property is + when VhpiLeftBoundP => + if Obj.Kind /= VhpiIntRangeK then + Res := 0; + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Left; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when VhpiRightBoundP => + if Obj.Kind /= VhpiIntRangeK then + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Right; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when others => + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Get; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out Boolean; + Error : out AvhpiErrorT) + is + begin + case Property is + when VhpiIsUpP => + if Obj.Kind /= VhpiIntRangeK then + Res := False; + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Dir = Dir_To; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when others => + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Get; + + function Vhpi_Get_EntityClass (Obj : VhpiHandleT) + return VhpiEntityClassT + is + begin + case Obj.Kind is + when VhpiArchBodyK => + return VhpiArchitectureEC; + when others => + return VhpiErrorEC; + end case; + end Vhpi_Get_EntityClass; + + function Vhpi_Get_Kind (Obj : VhpiHandleT) return VhpiClassKindT is + begin + return Obj.Kind; + end Vhpi_Get_Kind; + + function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT is + begin + case Obj.Kind is + when VhpiPortDeclK => + case Obj.Obj.Common.Mode and Ghdl_Rti_Signal_Mode_Mask is + when Ghdl_Rti_Signal_Mode_In => + return VhpiInMode; + when Ghdl_Rti_Signal_Mode_Out => + return VhpiOutMode; + when Ghdl_Rti_Signal_Mode_Inout => + return VhpiInoutMode; + when Ghdl_Rti_Signal_Mode_Buffer => + return VhpiBufferMode; + when Ghdl_Rti_Signal_Mode_Linkage => + return VhpiLinkageMode; + when others => + return VhpiErrorMode; + end case; + when others => + return VhpiErrorMode; + end case; + end Vhpi_Get_Mode; + + function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access is + begin + case Obj.Kind is + when VhpiSubtypeIndicK + | VhpiEnumTypeDeclK => + return Obj.Atype; + when VhpiSigDeclK + | VhpiPortDeclK => + return To_Ghdl_Rti_Access (Obj.Obj); + when others => + return null; + end case; + end Avhpi_Get_Rti; + + function Avhpi_Get_Address (Obj : VhpiHandleT) return Address is + begin + case Obj.Kind is + when VhpiPortDeclK + | VhpiSigDeclK + | VhpiGenericDeclK + | VhpiConstDeclK => + return Loc_To_Addr (Obj.Ctxt.Block.Depth, + Obj.Obj.Loc, + Obj.Ctxt); + when others => + return Null_Address; + end case; + end Avhpi_Get_Address; + + function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context is + begin + return Obj.Ctxt; + end Avhpi_Get_Context; + + function Vhpi_Compare_Handles (Hdl1, Hdl2 : VhpiHandleT) + return Boolean + is + begin + if Hdl1.Kind /= Hdl2.Kind then + return False; + end if; + case Hdl1.Kind is + when VhpiSubtypeIndicK + | VhpiSubtypeDeclK + | VhpiArrayTypeDeclK + | VhpiPhysTypeDeclK => + return Hdl1.Atype = Hdl2.Atype; + when others => + -- FIXME: todo + Internal_Error ("vhpi_compare_handles"); + end case; + end Vhpi_Compare_Handles; + + function Vhpi_Put_Value (Obj : VhpiHandleT; Val : Ghdl_I64) + return AvhpiErrorT + is + Vptr : Ghdl_Value_Ptr; + Atype : Ghdl_Rti_Access; + begin + case Obj.Kind is + when VhpiIndexedNameK => + Vptr := To_Ghdl_Value_Ptr (Obj.N_Addr); + Atype := Obj.N_Type; + when others => + return AvhpiErrorNotImplemented; + end case; + case Get_Base_Type (Atype).Kind is + when Ghdl_Rtik_Type_P64 => + null; + when others => + return AvhpiErrorHandle; + end case; + Vptr.I64 := Val; + return AvhpiErrorOk; + end Vhpi_Put_Value; +end Grt.Avhpi; + + diff --git a/src/translate/grt/grt-avhpi.ads b/src/translate/grt/grt-avhpi.ads new file mode 100644 index 0000000..1eff5a8 --- /dev/null +++ b/src/translate/grt/grt-avhpi.ads @@ -0,0 +1,561 @@ +-- GHDL Run Time (GRT) - VHPI implementation for Ada. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +-- Ada oriented implementation of VHPI. +-- This doesn't follow exactly what VHPI defined, but: +-- * it should be easy to write a VHPI interface from this implementation. +-- * this implementation is thread-safe (no global storage). +-- * this implementation never allocates memory. +with System; use System; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; + +package Grt.Avhpi is + -- Object Kinds. + type VhpiClassKindT is + ( + VhpiUndefined, + VhpiAccessTypeDeclK, + VhpiAggregateK, + VhpiAliasDeclK, + VhpiAllLiteralK, + VhpiAllocatorK, + VhpiAnyCollectionK, + VhpiArchBodyK, + VhpiArgvK, + VhpiArrayTypeDeclK, + VhpiAssertStmtK, + VhpiAssocElemK, + VhpiAttrDeclK, + VhpiAttrSpecK, + VhpiBinaryExprK, + VhpiBitStringLiteralK, + VhpiBlockConfigK, + VhpiBlockStmtK, + VhpiBranchK, + VhpiCallbackK, + VhpiCaseStmtK, + VhpiCharLiteralK, + VhpiCompConfigK, + VhpiCompDeclK, + VhpiCompInstStmtK, + VhpiCondSigAssignStmtK, + VhpiCondWaveformK, + VhpiConfigDeclK, + VhpiConstDeclK, + VhpiConstParamDeclK, + VhpiConvFuncK, + VhpiDeRefObjK, + VhpiDisconnectSpecK, + VhpiDriverK, + VhpiDriverCollectionK, + VhpiElemAssocK, + VhpiElemDeclK, + VhpiEntityClassEntryK, + VhpiEntityDeclK, + VhpiEnumLiteralK, + VhpiEnumRangeK, + VhpiEnumTypeDeclK, + VhpiExitStmtK, + VhpiFileDeclK, + VhpiFileParamDeclK, + VhpiFileTypeDeclK, + VhpiFloatRangeK, + VhpiFloatTypeDeclK, + VhpiForGenerateK, + VhpiForLoopK, + VhpiForeignfK, + VhpiFuncCallK, + VhpiFuncDeclK, + VhpiGenericDeclK, + VhpiGroupDeclK, + VhpiGroupTempDeclK, + VhpiIfGenerateK, + VhpiIfStmtK, + VhpiInPortK, + VhpiIndexedNameK, + VhpiIntLiteralK, + VhpiIntRangeK, + VhpiIntTypeDeclK, + VhpiIteratorK, + VhpiLibraryDeclK, + VhpiLoopStmtK, + VhpiNextStmtK, + VhpiNullLiteralK, + VhpiNullStmtK, + VhpiOperatorK, + VhpiOthersLiteralK, + VhpiOutPortK, + VhpiPackBodyK, + VhpiPackDeclK, + VhpiPackInstK, + VhpiParamAttrNameK, + VhpiPhysLiteralK, + VhpiPhysRangeK, + VhpiPhysTypeDeclK, + VhpiPortDeclK, + VhpiProcCallStmtK, + VhpiProcDeclK, + VhpiProcessStmtK, + VhpiProtectedTypeK, + VhpiProtectedTypeBodyK, + VhpiProtectedTypeDeclK, + VhpiRealLiteralK, + VhpiRecordTypeDeclK, + VhpiReportStmtK, + VhpiReturnStmtK, + VhpiRootInstK, + VhpiSelectSigAssignStmtK, + VhpiSelectWaveformK, + VhpiSelectedNameK, + VhpiSigDeclK, + VhpiSigParamDeclK, + VhpiSimpAttrNameK, + VhpiSimpleSigAssignStmtK, + VhpiSliceNameK, + VhpiStringLiteralK, + VhpiSubpBodyK, + VhpiSubtypeDeclK, + VhpiSubtypeIndicK, + VhpiToolK, + VhpiTransactionK, + VhpiTypeConvK, + VhpiUnaryExprK, + VhpiUnitDeclK, + VhpiUserAttrNameK, + VhpiVarAssignStmtK, + VhpiVarDeclK, + VhpiVarParamDeclK, + VhpiWaitStmtK, + VhpiWaveformElemK, + VhpiWhileLoopK, + + -- Iterator, but on a name. + AvhpiNameIteratorK + ); + + type VhpiOneToOneT is + ( + VhpiAbstractLiteral, + VhpiActual, + VhpiAllLiteral, + VhpiAttrDecl, + VhpiAttrSpec, + VhpiBaseType, + VhpiBaseUnit, + VhpiBasicSignal, + VhpiBlockConfig, + VhpiCaseExpr, + VhpiCondExpr, + VhpiConfigDecl, + VhpiConfigSpec, + VhpiConstraint, + VhpiContributor, + VhpiCurCallback, + VhpiCurEqProcess, + VhpiCurStackFrame, + VhpiDeRefObj, + VhpiDecl, + VhpiDesignUnit, + VhpiDownStack, + VhpiElemSubtype, + VhpiEntityAspect, + VhpiEntityDecl, + VhpiEqProcessStmt, + VhpiExpr, + VhpiFormal, + VhpiFuncDecl, + VhpiGroupTempDecl, + VhpiGuardExpr, + VhpiGuardSig, + VhpiImmRegion, + VhpiInPort, + VhpiInitExpr, + VhpiIterScheme, + VhpiLeftExpr, + VhpiLexicalScope, + VhpiLhsExpr, + VhpiLocal, + VhpiLogicalExpr, + VhpiName, + VhpiOperator, + VhpiOthersLiteral, + VhpiOutPort, + VhpiParamDecl, + VhpiParamExpr, + VhpiParent, + VhpiPhysLiteral, + VhpiPrefix, + VhpiPrimaryUnit, + VhpiProtectedTypeBody, + VhpiProtectedTypeDecl, + VhpiRejectTime, + VhpiReportExpr, + VhpiResolFunc, + VhpiReturnExpr, + VhpiReturnTypeMark, + VhpiRhsExpr, + VhpiRightExpr, + VhpiRootInst, + VhpiSelectExpr, + VhpiSeverityExpr, + VhpiSimpleName, + VhpiSubpBody, + VhpiSubpDecl, + VhpiSubtype, + VhpiSuffix, + VhpiTimeExpr, + VhpiTimeOutExpr, + VhpiTool, + VhpiTypeMark, + VhpiUnitDecl, + VhpiUpStack, + VhpiUpperRegion, + VhpiValExpr, + VhpiValSubtype + ); + + -- Methods used to traverse 1 to many relationships. + type VhpiOneToManyT is + ( + VhpiAliasDecls, + VhpiArgvs, + VhpiAttrDecls, + VhpiAttrSpecs, + VhpiBasicSignals, + VhpiBlockStmts, + VhpiBranchs, + VhpiCallbacks, + VhpiChoices, + VhpiCompInstStmts, + VhpiCondExprs, + VhpiCondWaveforms, + VhpiConfigItems, + VhpiConfigSpecs, + VhpiConstDecls, + VhpiConstraints, + VhpiContributors, + VhpiCurRegions, + VhpiDecls, + VhpiDepUnits, + VhpiDesignUnits, + VhpiDrivenSigs, + VhpiDrivers, + VhpiElemAssocs, + VhpiEntityClassEntrys, + VhpiEntityDesignators, + VhpiEnumLiterals, + VhpiForeignfs, + VhpiGenericAssocs, + VhpiGenericDecls, + VhpiIndexExprs, + VhpiIndexedNames, + VhpiInternalRegions, + VhpiMembers, + VhpiPackInsts, + VhpiParamAssocs, + VhpiParamDecls, + VhpiPortAssocs, + VhpiPortDecls, + VhpiRecordElems, + VhpiSelectWaveforms, + VhpiSelectedNames, + VhpiSensitivitys, + VhpiSeqStmts, + VhpiSigAttrs, + VhpiSigDecls, + VhpiSigNames, + VhpiSignals, + VhpiSpecNames, + VhpiSpecs, + VhpiStmts, + VhpiTransactions, + VhpiTypeMarks, + VhpiUnitDecls, + VhpiUses, + VhpiVarDecls, + VhpiWaveformElems, + VhpiLibraryDecls + ); + + type VhpiIntPropertyT is + ( + VhpiAccessP, + VhpiArgcP, + VhpiAttrKindP, + VhpiBaseIndexP, + VhpiBeginLineNoP, + VhpiEndLineNoP, + VhpiEntityClassP, + VhpiForeignKindP, + VhpiFrameLevelP, + VhpiGenerateIndexP, + VhpiIntValP, + VhpiIsAnonymousP, + VhpiIsBasicP, + VhpiIsCompositeP, + VhpiIsDefaultP, + VhpiIsDeferredP, + VhpiIsDiscreteP, + VhpiIsForcedP, + VhpiIsForeignP, + VhpiIsGuardedP, + VhpiIsImplicitDeclP, + VhpiIsInvalidP_DEPRECATED, + VhpiIsLocalP, + VhpiIsNamedP, + VhpiIsNullP, + VhpiIsOpenP, + VhpiIsPLIP, + VhpiIsPassiveP, + VhpiIsPostponedP, + VhpiIsProtectedTypeP, + VhpiIsPureP, + VhpiIsResolvedP, + VhpiIsScalarP, + VhpiIsSeqStmtP, + VhpiIsSharedP, + VhpiIsTransportP, + VhpiIsUnaffectedP, + VhpiIsUnconstrainedP, + VhpiIsUninstantiatedP, + VhpiIsUpP, + VhpiIsVitalP, + VhpiIteratorTypeP, + VhpiKindP, + VhpiLeftBoundP, + VhpiLevelP_DEPRECATED, + VhpiLineNoP, + VhpiLineOffsetP, + VhpiLoopIndexP, + VhpiModeP, + VhpiNumDimensionsP, + VhpiNumFieldsP_DEPRECATED, + VhpiNumGensP, + VhpiNumLiteralsP, + VhpiNumMembersP, + VhpiNumParamsP, + VhpiNumPortsP, + VhpiOpenModeP, + VhpiPhaseP, + VhpiPositionP, + VhpiPredefAttrP, + VhpiReasonP, + VhpiRightBoundP, + VhpiSigKindP, + VhpiSizeP, + VhpiStartLineNoP, + VhpiStateP, + VhpiStaticnessP, + VhpiVHDLversionP, + VhpiIdP, + VhpiCapabilitiesP + ); + + -- String properties. + type VhpiStrPropertyT is + ( + VhpiCaseNameP, + VhpiCompNameP, + VhpiDefNameP, + VhpiFileNameP, + VhpiFullCaseNameP, + VhpiFullNameP, + VhpiKindStrP, + VhpiLabelNameP, + VhpiLibLogicalNameP, + VhpiLibPhysicalNameP, + VhpiLogicalNameP, + VhpiLoopLabelNameP, + VhpiNameP, + VhpiOpNameP, + VhpiStrValP, + VhpiToolVersionP, + VhpiUnitNameP + ); + + -- Possible Errors. + type AvhpiErrorT is + ( + AvhpiErrorOk, + AvhpiErrorBadRel, + AvhpiErrorHandle, + AvhpiErrorNotImplemented, + AvhpiErrorIteratorEnd, + AvhpiErrorBadIndex + ); + + type VhpiHandleT is private; + + -- A null handle. + Null_Handle : constant VhpiHandleT; + + -- Get the root instance. + procedure Get_Root_Inst (Res : out VhpiHandleT); + + -- Get the instanciated packages. + procedure Get_Package_Inst (Res : out VhpiHandleT); + + procedure Vhpi_Handle (Rel : VhpiOneToOneT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + + procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Index : Natural; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + + procedure Vhpi_Iterator (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + procedure Vhpi_Scan (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + + procedure Vhpi_Get_Str (Property : VhpiStrPropertyT; + Obj : VhpiHandleT; + Res : out String; + Len : out Natural); + + subtype VhpiIntT is Ghdl_I32; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out VhpiIntT; + Error : out AvhpiErrorT); + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out Boolean; + Error : out AvhpiErrorT); + + -- Almost the same as Vhpi_Get_Str (VhpiName, OBJ), but there is not + -- indexes for generate stmt. + function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String; + + -- Return TRUE iff HDL1 and HDL2 are equivalent. + function Vhpi_Compare_Handles (Hdl1, Hdl2 : VhpiHandleT) + return Boolean; + +-- procedure Vhpi_Handle_By_Simple_Name (Ref : VhpiHandleT; +-- Res : out VhpiHandleT; +-- Error : out AvhpiErrorT); + + type VhpiEntityClassT is + ( + VhpiErrorEC, + VhpiEntityEC, + VhpiArchitectureEC, + VhpiConfigurationEC, + VhpiProcedureEC, + VhpiFunctionEC, + VhpiPackageEC, + VhpiTypeEC, + VhpiSubtypeEC, + VhpiConstantEC, + VhpiSignalEC, + VhpiVariableEC, + VhpiComponentEC, + VhpiLabelEC, + VhpiLiteralEC, + VhpiUnitsEC, + VhpiFileEC, + VhpiGroupEC + ); + + function Vhpi_Get_EntityClass (Obj : VhpiHandleT) + return VhpiEntityClassT; + + type VhpiModeT is + ( + VhpiErrorMode, + VhpiInMode, + VhpiOutMode, + VhpiInoutMode, + VhpiBufferMode, + VhpiLinkageMode + ); + function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT; + + function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access; + + function Avhpi_Get_Address (Obj : VhpiHandleT) return Address; + + function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context; + + function Vhpi_Get_Kind (Obj : VhpiHandleT) return VhpiClassKindT; + + function Vhpi_Put_Value (Obj : VhpiHandleT; Val : Ghdl_I64) + return AvhpiErrorT; +private + type VhpiHandleT (Kind : VhpiClassKindT := VhpiUndefined) is record + -- Context. + Ctxt : Rti_Context; + + case Kind is + when VhpiIteratorK => + Rel : VhpiOneToManyT; + It_Cur : Ghdl_Index_Type; + It2 : Ghdl_Index_Type; + Max2 : Ghdl_Index_Type; + when AvhpiNameIteratorK + | VhpiIndexedNameK => + N_Addr : Address; + N_Type : Ghdl_Rti_Access; + N_Idx : Ghdl_Index_Type; + N_Obj : Ghdl_Rtin_Object_Acc; + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK + | VhpiConstDeclK => + Obj : Ghdl_Rtin_Object_Acc; + when VhpiSubtypeIndicK + | VhpiSubtypeDeclK + | VhpiArrayTypeDeclK + | VhpiEnumTypeDeclK + | VhpiPhysTypeDeclK => + Atype : Ghdl_Rti_Access; + when VhpiCompInstStmtK => + Inst : Ghdl_Rtin_Instance_Acc; + when VhpiIntRangeK + | VhpiEnumRangeK + | VhpiFloatRangeK + | VhpiPhysRangeK => + Rng_Type : Ghdl_Rti_Access; + Rng_Addr : Ghdl_Range_Ptr; + when others => + null; + end case; + -- Current Object. + --Obj : Ghdl_Rti_Access; + end record; + + Null_Handle : constant VhpiHandleT := (Kind => VhpiUndefined, + Ctxt => (Base => Null_Address, + Block => null)); +end Grt.Avhpi; diff --git a/src/translate/grt/grt-avls.adb b/src/translate/grt/grt-avls.adb new file mode 100644 index 0000000..7f13ed3 --- /dev/null +++ b/src/translate/grt/grt-avls.adb @@ -0,0 +1,249 @@ +-- GHDL Run Time (GRT) - binary balanced tree. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; + +package body Grt.Avls is + function Get_Height (Tree: AVL_Tree; N : AVL_Nid) return Ghdl_I32 is + begin + if N = AVL_Nil then + return 0; + else + return Tree (N).Height; + end if; + end Get_Height; + + procedure Check_AVL (Tree : AVL_Tree; N : AVL_Nid) + is + L, R : AVL_Nid; + Lh, Rh : Ghdl_I32; + H : Ghdl_I32; + begin + if N = AVL_Nil then + return; + end if; + L := Tree (N).Left; + R := Tree (N).Right; + H := Get_Height (Tree, N); + if L = AVL_Nil and R = AVL_Nil then + if Get_Height (Tree, N) /= 1 then + Internal_Error ("check_AVL(1)"); + end if; + return; + elsif L = AVL_Nil then + Check_AVL (Tree, R); + if H /= Get_Height (Tree, R) + 1 or H > 2 then + Internal_Error ("check_AVL(2)"); + end if; + elsif R = AVL_Nil then + Check_AVL (Tree, L); + if H /= Get_Height (Tree, L) + 1 or H > 2 then + Internal_Error ("check_AVL(3)"); + end if; + else + Check_AVL (Tree, L); + Check_AVL (Tree, R); + Lh := Get_Height (Tree, L); + Rh := Get_Height (Tree, R); + if Ghdl_I32'Max (Lh, Rh) + 1 /= H then + Internal_Error ("check_AVL(4)"); + end if; + if Rh - Lh > 1 or Rh - Lh < -1 then + Internal_Error ("check_AVL(5)"); + end if; + end if; + end Check_AVL; + + procedure Compute_Height (Tree : in out AVL_Tree; N : AVL_Nid) + is + begin + Tree (N).Height := + Ghdl_I32'Max (Get_Height (Tree, Tree (N).Left), + Get_Height (Tree, Tree (N).Right)) + 1; + end Compute_Height; + + procedure Simple_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid) + is + R : AVL_Nid; + V : AVL_Value; + begin + -- Rotate nodes. + R := Tree (N).Right; + Tree (N).Right := Tree (R).Right; + Tree (R).Right := Tree (R).Left; + Tree (R).Left := Tree (N).Left; + Tree (N).Left := R; + -- Swap vals. + V := Tree (N).Val; + Tree (N).Val := Tree (R).Val; + Tree (R).Val := V; + -- Adjust bal. + Compute_Height (Tree, R); + Compute_Height (Tree, N); + end Simple_Rotate_Right; + + procedure Simple_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid) + is + L : AVL_Nid; + V : AVL_Value; + begin + L := Tree (N).Left; + Tree (N).Left := Tree (L).Left; + Tree (L).Left := Tree (L).Right; + Tree (L).Right := Tree (N).Right; + Tree (N).Right := L; + V := Tree (N).Val; + Tree (N).Val := Tree (L).Val; + Tree (L).Val := V; + Compute_Height (Tree, L); + Compute_Height (Tree, N); + end Simple_Rotate_Left; + + procedure Double_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid) + is + R : AVL_Nid; + begin + R := Tree (N).Right; + Simple_Rotate_Left (Tree, R); + Simple_Rotate_Right (Tree, N); + end Double_Rotate_Right; + + procedure Double_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid) + is + L : AVL_Nid; + begin + L := Tree (N).Left; + Simple_Rotate_Right (Tree, L); + Simple_Rotate_Left (Tree, N); + end Double_Rotate_Left; + + procedure Insert (Tree : in out AVL_Tree; + Cmp : AVL_Compare_Func; + Val : AVL_Nid; + N : AVL_Nid; + Res : out AVL_Nid) + is + Diff : Integer; + Op_Ch, Ch : AVL_Nid; + begin + Diff := Cmp.all (Tree (Val).Val, Tree (N).Val); + if Diff = 0 then + Res := N; + return; + end if; + if Diff < 0 then + if Tree (N).Left = AVL_Nil then + Tree (N).Left := Val; + Compute_Height (Tree, N); + -- N is balanced. + Res := Val; + else + Ch := Tree (N).Left; + Op_Ch := Tree (N).Right; + Insert (Tree, Cmp, Val, Ch, Res); + if Res /= Val then + return; + end if; + if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then + -- Rotate + if Get_Height (Tree, Tree (Ch).Left) + > Get_Height (Tree, Tree (Ch).Right) + then + Simple_Rotate_Left (Tree, N); + else + Double_Rotate_Left (Tree, N); + end if; + else + Compute_Height (Tree, N); + end if; + end if; + else + if Tree (N).Right = AVL_Nil then + Tree (N).Right := Val; + Compute_Height (Tree, N); + -- N is balanced. + Res := Val; + else + Ch := Tree (N).Right; + Op_Ch := Tree (N).Left; + Insert (Tree, Cmp, Val, Ch, Res); + if Res /= Val then + return; + end if; + if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then + -- Rotate + if Get_Height (Tree, Tree (Ch).Right) + > Get_Height (Tree, Tree (Ch).Left) + then + Simple_Rotate_Right (Tree, N); + else + Double_Rotate_Right (Tree, N); + end if; + else + Compute_Height (Tree, N); + end if; + end if; + end if; + end Insert; + + procedure Get_Node (Tree : in out AVL_Tree; + Cmp : AVL_Compare_Func; + N : AVL_Nid; + Res : out AVL_Nid) + is + begin + if Tree'First /= AVL_Root or N /= Tree'Last then + Internal_Error ("avls.get_node"); + end if; + Insert (Tree, Cmp, N, AVL_Root, Res); + Check_AVL (Tree, AVL_Root); + end Get_Node; + + function Find_Node (Tree : AVL_Tree; + Cmp : AVL_Compare_Func; + Val : AVL_Value) return AVL_Nid + is + N : AVL_Nid; + Diff : Integer; + begin + N := AVL_Root; + if Tree'Last < AVL_Root then + return AVL_Nil; + end if; + loop + Diff := Cmp.all (Val, Tree (N).Val); + if Diff = 0 then + return N; + end if; + if Diff < 0 then + N := Tree (N).Left; + else + N := Tree (N).Right; + end if; + if N = AVL_Nil then + return AVL_Nil; + end if; + end loop; + end Find_Node; +end Grt.Avls; diff --git a/src/translate/grt/grt-avls.ads b/src/translate/grt/grt-avls.ads new file mode 100644 index 0000000..790053c --- /dev/null +++ b/src/translate/grt/grt-avls.ads @@ -0,0 +1,84 @@ +-- GHDL Run Time (GRT) - binary balanced tree. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; + +package Grt.Avls is + -- Implementation of a binary balanced tree. + -- This package is very generic, and provides only the algorithm. + -- The user must provide the storage of the tree. + -- The basic types of this implementation ares: + -- * AVL_Value: the value stored in the tree. This is an integer on 32 + -- bits. However, they may either really represent integers or an index + -- into another table. To compare two values, a user function is always + -- provided. + -- * AVL_Nid: a node id or an index into the tree. + -- * AVL_Node: a node, indexed by AVL_Nid. + -- * AVL_Tree: an array of AVL_Node, indexed by AVL_Nid. This represents + -- the tree. The root of the tree is always AVL_Root, which is the + -- first element of the array. + -- + -- As a choice, this package never allocate nodes. So, to insert a value + -- in the tree, the user must allocate an (empty) node, set the value of + -- the node and try to insert this node into the tree. If the value is + -- already in the tree, Get_Node will returns the node id which contains + -- the value. Otherwise, Get_Node returns the node just created by the + -- user. + + -- The value in an AVL tree. + -- This is fixed. + type AVL_Value is new Ghdl_I32; + + -- An AVL node id. + type AVL_Nid is new Ghdl_I32; + AVL_Nil : constant AVL_Nid := 0; + AVL_Root : constant AVL_Nid := 1; + + type AVL_Node is record + Val : AVL_Value; + Left : AVL_Nid; + Right : AVL_Nid; + Height : Ghdl_I32; + end record; + + type AVL_Tree is array (AVL_Nid range <>) of AVL_Node; + + -- Compare two values. + -- Returns < 0 if L < R, 0 if L = R, > 0 if L > R. + type AVL_Compare_Func is access function (L, R : AVL_Value) return Integer; + + -- Try to insert node N into TREE. + -- Returns either N or the node id of a node containing already the value. + procedure Get_Node (Tree : in out AVL_Tree; + Cmp : AVL_Compare_Func; + N : AVL_Nid; + Res : out AVL_Nid); + + function Find_Node (Tree : AVL_Tree; + Cmp : AVL_Compare_Func; + Val : AVL_Value) return AVL_Nid; + +end Grt.Avls; + + diff --git a/src/translate/grt/grt-c.ads b/src/translate/grt/grt-c.ads new file mode 100644 index 0000000..24003cf --- /dev/null +++ b/src/translate/grt/grt-c.ads @@ -0,0 +1,54 @@ +-- GHDL Run Time (GRT) - C interface. +-- Copyright (C) 2005 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +-- This package declares C types. +-- It is a really stripped down version of interfaces.C! +with System; + +package Grt.C is + pragma Preelaborate (Grt.C); + + -- Type void * and char *. + subtype voids is System.Address; + subtype chars is System.Address; + subtype long is Long_Integer; + + -- Type size_t. + type size_t is mod 2 ** Standard'Address_Size; + + -- Type int. It is an alias on Integer for simplicity. + subtype int is Integer; + + -- Low level memory management. + procedure Free (Addr : System.Address); + function Malloc (Size : size_t) return System.Address; + function Realloc (Ptr : System.Address; Size : size_t) + return System.Address; + +private + pragma Import (C, Free); + pragma Import (C, Malloc); + pragma Import (C, Realloc); +end Grt.C; diff --git a/src/translate/grt/grt-cbinding.c b/src/translate/grt/grt-cbinding.c new file mode 100644 index 0000000..b95c0f0 --- /dev/null +++ b/src/translate/grt/grt-cbinding.c @@ -0,0 +1,99 @@ +/* GRT C bindings. + Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ +#include <stdio.h> +#include <stdlib.h> +#include <string.h> + +FILE * +__ghdl_get_stdout (void) +{ + return stdout; +} + +FILE * +__ghdl_get_stdin (void) +{ + return stdin; +} + +FILE * +__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_snprintf_nf (char *buf, unsigned int len, int ndigits, double val) +{ + snprintf (buf, len, "%.*f", ndigits, val); +} + +void +__ghdl_snprintf_fmtf (char *buf, unsigned int len, + const char *format, double v) +{ + snprintf (buf, len, format, v); +} + +void +__ghdl_fprintf_g (FILE *stream, double val) +{ + fprintf (stream, "%g", val); +} + +void +__ghdl_fprintf_clock (FILE *stream, int a, int b) +{ + fprintf (stream, "%3d.%03d", a, b); +} + +#ifndef WITH_GNAT_RUN_TIME +void +__gnat_last_chance_handler (void) +{ + abort (); +} + +void * +__gnat_malloc (size_t size) +{ + void *res; + res = malloc (size); + return res; +} + +void +__gnat_free (void *ptr) +{ + free (ptr); +} + +void * +__gnat_realloc (void *ptr, size_t size) +{ + return realloc (ptr, size); +} +#endif diff --git a/src/translate/grt/grt-cvpi.c b/src/translate/grt/grt-cvpi.c new file mode 100644 index 0000000..51edd67 --- /dev/null +++ b/src/translate/grt/grt-cvpi.c @@ -0,0 +1,277 @@ +/* GRT VPI C helpers. + Copyright (C) 2003, 2004, 2005 Tristan Gingold & Felix Bertram + + 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. +*/ +//----------------------------------------------------------------------------- +// Description: VPI interface for GRT runtime, "C" helpers +// the main purpose of this code is to interface with the +// Icarus Verilog Interactive (IVI) simulator GUI +//----------------------------------------------------------------------------- + +#include <stdio.h> +#include <stdlib.h> + +//----------------------------------------------------------------------------- +// VPI callback functions +typedef void *vpiHandle, *p_vpi_time, *p_vpi_value; +typedef struct t_cb_data { + int reason; + int (*cb_rtn)(struct t_cb_data*cb); + vpiHandle obj; + p_vpi_time time; + p_vpi_value value; + int index; + char*user_data; +} s_cb_data, *p_cb_data; + +//----------------------------------------------------------------------------- +// vpi thunking a la Icarus Verilog +#include <stdarg.h> +typedef void *s_vpi_time, *p_vpi_vlog_info, *p_vpi_error_info; +#define VPI_THUNK_MAGIC (0x87836BA5) +struct t_vpi_systf_data; +void vpi_register_systf (const struct t_vpi_systf_data*ss); +void vpi_vprintf (const char*fmt, va_list ap); +unsigned int vpi_mcd_close (unsigned int mcd); +char * vpi_mcd_name (unsigned int mcd); +unsigned int vpi_mcd_open (char *name); +unsigned int vpi_mcd_open_x (char *name, char *mode); +int vpi_mcd_vprintf (unsigned int mcd, const char*fmt, va_list ap); +int vpi_mcd_fputc (unsigned int mcd, unsigned char x); +int vpi_mcd_fgetc (unsigned int mcd); +vpiHandle vpi_register_cb (p_cb_data data); +int vpi_remove_cb (vpiHandle ref); +void vpi_sim_vcontrol (int operation, va_list ap); +vpiHandle vpi_handle (int type, vpiHandle ref); +vpiHandle vpi_iterate (int type, vpiHandle ref); +vpiHandle vpi_scan (vpiHandle iter); +vpiHandle vpi_handle_by_index (vpiHandle ref, int index); +void vpi_get_time (vpiHandle obj, s_vpi_time*t); +int vpi_get (int property, vpiHandle ref); +char* vpi_get_str (int property, vpiHandle ref); +void vpi_get_value (vpiHandle expr, p_vpi_value value); +vpiHandle vpi_put_value (vpiHandle obj, p_vpi_value value, + p_vpi_time when, int flags); +int vpi_free_object (vpiHandle ref); +int vpi_get_vlog_info (p_vpi_vlog_info vlog_info_p); +int vpi_chk_error (p_vpi_error_info info); +vpiHandle vpi_handle_by_name (char *name, vpiHandle scope); + +typedef struct { + int magic; + void (*vpi_register_systf) (const struct t_vpi_systf_data*ss); + void (*vpi_vprintf) (const char*fmt, va_list ap); + unsigned int (*vpi_mcd_close) (unsigned int mcd); + char* (*vpi_mcd_name) (unsigned int mcd); + unsigned int (*vpi_mcd_open) (char *name); + unsigned int (*vpi_mcd_open_x) (char *name, char *mode); + int (*vpi_mcd_vprintf) (unsigned int mcd, const char*fmt, va_list ap); + int (*vpi_mcd_fputc) (unsigned int mcd, unsigned char x); + int (*vpi_mcd_fgetc) (unsigned int mcd); + vpiHandle (*vpi_register_cb) (p_cb_data data); + int (*vpi_remove_cb) (vpiHandle ref); + void (*vpi_sim_vcontrol) (int operation, va_list ap); + vpiHandle (*vpi_handle) (int type, vpiHandle ref); + vpiHandle (*vpi_iterate) (int type, vpiHandle ref); + vpiHandle (*vpi_scan) (vpiHandle iter); + vpiHandle (*vpi_handle_by_index)(vpiHandle ref, int index); + void (*vpi_get_time) (vpiHandle obj, s_vpi_time*t); + int (*vpi_get) (int property, vpiHandle ref); + char* (*vpi_get_str) (int property, vpiHandle ref); + void (*vpi_get_value) (vpiHandle expr, p_vpi_value value); + vpiHandle (*vpi_put_value) (vpiHandle obj, p_vpi_value value, + p_vpi_time when, int flags); + int (*vpi_free_object) (vpiHandle ref); + int (*vpi_get_vlog_info) (p_vpi_vlog_info vlog_info_p); + int (*vpi_chk_error) (p_vpi_error_info info); + vpiHandle (*vpi_handle_by_name) (char *name, vpiHandle scope); +} vpi_thunk, *p_vpi_thunk; + +int vpi_register_sim(p_vpi_thunk tp); + +static vpi_thunk thunkTable = +{ VPI_THUNK_MAGIC, + vpi_register_systf, + vpi_vprintf, + vpi_mcd_close, + vpi_mcd_name, + vpi_mcd_open, + 0, //vpi_mcd_open_x, + 0, //vpi_mcd_vprintf, + 0, //vpi_mcd_fputc, + 0, //vpi_mcd_fgetc, + vpi_register_cb, + vpi_remove_cb, + 0, //vpi_sim_vcontrol, + vpi_handle, + vpi_iterate, + vpi_scan, + vpi_handle_by_index, + vpi_get_time, + vpi_get, + vpi_get_str, + vpi_get_value, + vpi_put_value, + vpi_free_object, + vpi_get_vlog_info, + 0, //vpi_chk_error, + 0 //vpi_handle_by_name +}; + +//----------------------------------------------------------------------------- +// VPI module load & startup +static void * module_open (const char *path); +static void * module_symbol (void *handle, const char *symbol); +static const char *module_error (void); + +#if defined(__WIN32__) +#include <windows.h> +static void * +module_open (const char *path) +{ + return (void *)LoadLibrary (path); +} + +static void * +module_symbol (void *handle, const char *symbol) +{ + return (void *)GetProcAddress ((HMODULE)handle, symbol); +} + +static const char * +module_error (void) +{ + static char msg[256]; + + FormatMessage + (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, + GetLastError (), + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), + (LPTSTR) &msg, + sizeof (msg) - 1, + NULL); + return msg; +} +#else +#include <dlfcn.h> +static void * +module_open (const char *path) +{ + return dlopen (path, RTLD_LAZY); +} + +static void * +module_symbol (void *handle, const char *symbol) +{ + return dlsym (handle, symbol); +} + +static const char * +module_error (void) +{ + return dlerror (); +} +#endif + +int +loadVpiModule (const char* modulename) +{ + static const char * const vpitablenames[] = + { + "_vlog_startup_routines", // with leading underscore: MacOSX + "vlog_startup_routines" // w/o leading underscore: Linux + }; + static const char * const vpithunknames[] = + { + "_vpi_register_sim", // with leading underscore: MacOSX + "vpi_register_sim" // w/o leading underscore: Linux + }; + + int i; + void* vpimod; + + fprintf (stderr, "loading VPI module '%s'\n", modulename); + + vpimod = module_open (modulename); + + if (vpimod == NULL) + { + const char *msg; + + msg = module_error (); + + fprintf (stderr, "%s\n", msg == NULL ? "unknown dlopen error" : msg); + return -1; + } + + for (i = 0; i < 2; i++) // try with and w/o leading underscores + { + void* vpithunk; + void* vpitable; + + vpitable = module_symbol (vpimod, vpitablenames[i]); + vpithunk = module_symbol (vpimod, vpithunknames[i]); + + if (vpithunk) + { + typedef int (*funT)(p_vpi_thunk tp); + funT regsim; + + regsim = (funT)vpithunk; + regsim (&thunkTable); + } + else + { + // this is not an error, as the register-mechanism + // is not standardized + } + + if (vpitable) + { + unsigned int tmp; + //extern void (*vlog_startup_routines[])(); + typedef void (*vlog_startup_routines_t)(void); + vlog_startup_routines_t *vpifuns; + + vpifuns = (vlog_startup_routines_t*)vpitable; + for (tmp = 0; vpifuns[tmp]; tmp++) + { + vpifuns[tmp](); + } + + fprintf (stderr, "VPI module loaded!\n"); + return 0; // successfully registered VPI module + } + } + fprintf (stderr, "vlog_startup_routines not found\n"); + return -1; // failed to register VPI module +} + +void +vpi_printf (const char *fmt, ...) +{ + va_list params; + + va_start (params, fmt); + vprintf (fmt, params); + va_end (params); +} + +//----------------------------------------------------------------------------- +// end of file + diff --git a/src/translate/grt/grt-disp.adb b/src/translate/grt/grt-disp.adb new file mode 100644 index 0000000..e68b116 --- /dev/null +++ b/src/translate/grt/grt-disp.adb @@ -0,0 +1,227 @@ +-- GHDL Run Time (GRT) - Common display subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Astdio; use Grt.Astdio; +with Grt.Stdio; use Grt.Stdio; +--with Grt.Errors; use Grt.Errors; + +package body Grt.Disp is + +-- procedure Put_Trim (Stream : FILEs; Str : String) +-- is +-- Start : Natural; +-- begin +-- Start := Str'First; +-- while Start <= Str'Last and then Str (Start) = ' ' loop +-- Start := Start + 1; +-- end loop; +-- Put (Stream, Str (Start .. Str'Last)); +-- end Put_Trim; + +-- procedure Put_E8 (Stream : FILEs; E8 : Ghdl_E8; Type_Desc : Ghdl_Desc_Ptr) +-- is +-- begin +-- Put_Str_Len (Stream, Type_Desc.E8.Values (Natural (E8))); +-- end Put_E8; + + --procedure Put_E32 + -- (Stream : FILEs; E32 : Ghdl_E32; Type_Desc : Ghdl_Desc_Ptr) + --is + --begin + -- Put_Str_Len (Stream, Type_Desc.E32.Values (Natural (E32))); + --end Put_E32; + + procedure Put_Sig_Index (Sig : Sig_Table_Index) + is + begin + Put_I32 (stdout, Ghdl_I32 (Sig)); + end Put_Sig_Index; + + procedure Put_Sig_Range (Sig : Sig_Table_Range) + is + begin + Put_Sig_Index (Sig.First); + if Sig.Last /= Sig.First then + Put ("-"); + Put_Sig_Index (Sig.Last); + end if; + end Put_Sig_Range; + + procedure Disp_Now + is + begin + Put ("Now is "); + Put_Time (stdout, Current_Time); + Put (" +"); + Put_I32 (stdout, Ghdl_I32 (Current_Delta)); + New_Line; + end Disp_Now; + + procedure Disp_Propagation_Kind (Kind : Propagation_Kind_Type) + is + begin + case Kind is + when Drv_One_Driver => + Put ("Drv (1 drv) "); + when Eff_One_Driver => + Put ("Eff (1 drv) "); + when Drv_One_Port => + Put ("Drv (1 prt) "); + when Eff_One_Port => + Put ("Eff (1 prt) "); + when Imp_Forward => + Put ("Forward "); + when Imp_Forward_Build => + Put ("Forward_Build "); + when Imp_Guard => + Put ("Guard "); + when Imp_Stable => + Put ("Stable "); + when Imp_Quiet => + Put ("Quiet "); + when Imp_Transaction => + Put ("Transaction "); + when Imp_Delayed => + Put ("Delayed "); + when Eff_Actual => + Put ("Eff Actual "); + when Eff_Multiple => + Put ("Eff multiple "); + when Drv_One_Resolved => + Put ("Drv 1 resolved "); + when Eff_One_Resolved => + Put ("Eff 1 resolved "); + when In_Conversion => + Put ("In conv "); + when Out_Conversion => + Put ("Out conv "); + when Drv_Error => + Put ("Drv error "); + when Drv_Multiple => + Put ("Drv multiple "); + when Prop_End => + Put ("end "); + end case; + end Disp_Propagation_Kind; + + procedure Disp_Signals_Order is + begin + for I in Propagation.First .. Propagation.Last loop + Put_I32 (stdout, Ghdl_I32 (I)); + Put (": "); + Disp_Propagation_Kind (Propagation.Table (I).Kind); + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Eff_One_Driver + | Drv_One_Port + | Eff_One_Port + | Drv_One_Resolved + | Eff_One_Resolved + | Imp_Guard + | Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Delayed + | Eff_Actual => + Put_Sig_Index (Signal_Ptr_To_Index (Propagation.Table (I).Sig)); + New_Line; + when Imp_Forward => + Put_I32 (stdout, Ghdl_I32 (Propagation.Table (I).Sig.Net)); + New_Line; + when Imp_Forward_Build => + declare + Forward : Forward_Build_Acc; + begin + Forward := Propagation.Table (I).Forward; + Put_Sig_Index (Signal_Ptr_To_Index (Forward.Src)); + Put (" -> "); + Put_Sig_Index (Signal_Ptr_To_Index (Forward.Targ)); + New_Line; + end; + when Eff_Multiple + | Drv_Multiple => + Put_Sig_Range (Propagation.Table (I).Resolv.Sig_Range); + New_Line; + when In_Conversion + | Out_Conversion => + declare + Conv : Sig_Conversion_Acc; + begin + Conv := Propagation.Table (I).Conv; + Put_Sig_Range (Conv.Src); + Put (" -> "); + Put_Sig_Range (Conv.Dest); + New_Line; + end; + when Prop_End => + New_Line; + when Drv_Error => + null; + end case; + end loop; + end Disp_Signals_Order; + + procedure Disp_Mode (Mode : Mode_Type) + is + begin + case Mode is + when Mode_B1 => + Put (" b1"); + when Mode_E8 => + Put (" e8"); + when Mode_E32 => + Put ("e32"); + when Mode_I32 => + Put ("i32"); + when Mode_I64 => + Put ("i64"); + when Mode_F64 => + Put ("f64"); + end case; + end Disp_Mode; + + procedure Disp_Value (Value : Value_Union; Mode : Mode_Type) is + begin + case Mode is + when Mode_B1 => + if Value.B1 then + Put ("T"); + else + Put ("F"); + end if; + when Mode_E8 => + Put_I32 (stdout, Ghdl_I32 (Value.E8)); + when Mode_E32 => + Put_I32 (stdout, Ghdl_I32 (Value.E32)); + when Mode_I32 => + Put_I32 (stdout, Value.I32); + when Mode_I64 => + Put_I64 (stdout, Value.I64); + when Mode_F64 => + Put_F64 (stdout, Value.F64); + end case; + end Disp_Value; +end Grt.Disp; diff --git a/src/translate/grt/grt-disp.ads b/src/translate/grt/grt-disp.ads new file mode 100644 index 0000000..6c15b37 --- /dev/null +++ b/src/translate/grt/grt-disp.ads @@ -0,0 +1,46 @@ +-- GHDL Run Time (GRT) - Common display subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Signals; use Grt.Signals; +with Grt.Types; use Grt.Types; + +package Grt.Disp is + -- Display SIG number. + procedure Put_Sig_Index (Sig : Sig_Table_Index); + + -- Disp current time and current delta. + procedure Disp_Now; + + procedure Disp_Propagation_Kind (Kind : Propagation_Kind_Type); + + -- Disp signals propagation order. + procedure Disp_Signals_Order; + + -- Disp mode. + procedure Disp_Mode (Mode : Mode_Type); + + -- Disp value (numeric). + procedure Disp_Value (Value : Value_Union; Mode : Mode_Type); + +end Grt.Disp; diff --git a/src/translate/grt/grt-disp_rti.adb b/src/translate/grt/grt-disp_rti.adb new file mode 100644 index 0000000..08d27da --- /dev/null +++ b/src/translate/grt/grt-disp_rti.adb @@ -0,0 +1,1080 @@ +-- GHDL Run Time (GRT) - RTI dumper. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Astdio; use Grt.Astdio; +with Grt.Errors; use Grt.Errors; +with Grt.Hooks; use Grt.Hooks; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; + +package body Grt.Disp_Rti is + procedure Disp_Kind (Kind : Ghdl_Rtik); + + procedure Disp_Name (Name : Ghdl_C_String) is + begin + if Name = null then + Put (stdout, "<anonymous>"); + else + Put (stdout, Name); + end if; + end Disp_Name; + + -- Disp value stored at ADDR and whose type is described by RTI. + procedure Disp_Enum_Value + (Stream : FILEs; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Put (Stream, Enum_Rti.Names (Val)); + end Disp_Enum_Value; + + procedure Disp_Scalar_Value + (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Addr : in out Address; + Is_Sig : Boolean) + is + procedure Update (S : Ghdl_Index_Type) is + begin + Addr := Addr + (S / Storage_Unit); + end Update; + + Vptr : Ghdl_Value_Ptr; + begin + if Is_Sig then + Vptr := To_Ghdl_Value_Ptr (To_Addr_Acc (Addr).all); + Update (Address'Size); + else + Vptr := To_Ghdl_Value_Ptr (Addr); + end if; + + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + Put_I32 (Stream, Vptr.I32); + if not Is_Sig then + Update (32); + end if; + when Ghdl_Rtik_Type_E8 => + Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E8)); + if not Is_Sig then + Update (8); + end if; + when Ghdl_Rtik_Type_E32 => + Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E32)); + if not Is_Sig then + Update (32); + end if; + when Ghdl_Rtik_Type_B1 => + Disp_Enum_Value (Stream, Rti, + Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1))); + if not Is_Sig then + Update (8); + end if; + when Ghdl_Rtik_Type_F64 => + Put_F64 (Stream, Vptr.F64); + if not Is_Sig then + Update (64); + end if; + when Ghdl_Rtik_Type_P64 => + Put_I64 (Stream, Vptr.I64); + Put (Stream, " "); + Put (Stream, + Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); + if not Is_Sig then + Update (64); + end if; + when Ghdl_Rtik_Type_P32 => + Put_I32 (Stream, Vptr.I32); + Put (Stream, " "); + Put (Stream, + Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); + if not Is_Sig then + Update (32); + end if; + when others => + Internal_Error ("disp_rti.disp_scalar_value"); + end case; + end Disp_Scalar_Value; + +-- function Get_Scalar_Type_Kind (Rti : Ghdl_Rti_Access) return Ghdl_Rtik +-- is +-- Ndef : Ghdl_Rti_Access; +-- begin +-- if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then +-- Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype; +-- else +-- Ndef := Rti; +-- end if; +-- case Ndef.Kind is +-- when Ghdl_Rtik_Type_I32 => +-- return Ndef.Kind; +-- when others => +-- return Ghdl_Rtik_Error; +-- end case; +-- end Get_Scalar_Type_Kind; + + procedure Disp_Array_Value_1 (Stream : FILEs; + El_Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Rngs : Ghdl_Range_Array; + Rtis : Ghdl_Rti_Arr_Acc; + Index : Ghdl_Index_Type; + Obj : in out Address; + Is_Sig : Boolean) + is + Length : Ghdl_Index_Type; + begin + Length := Range_To_Length (Rngs (Index), Get_Base_Type (Rtis (Index))); + Put (Stream, "("); + for I in 1 .. Length loop + if I /= 1 then + Put (Stream, ", "); + end if; + if Index = Rngs'Last then + Disp_Value (Stream, El_Rti, Ctxt, Obj, Is_Sig); + else + Disp_Array_Value_1 + (Stream, El_Rti, Ctxt, Rngs, Rtis, Index + 1, Obj, Is_Sig); + end if; + end loop; + Put (Stream, ")"); + end Disp_Array_Value_1; + + procedure Disp_Array_Value (Stream : FILEs; + Rti : Ghdl_Rtin_Type_Array_Acc; + Ctxt : Rti_Context; + Vals : Ghdl_Uc_Array_Acc; + Is_Sig : Boolean) + is + Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; + Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); + Obj : Address; + begin + Bound_To_Range (Vals.Bounds, Rti, Rngs); + Obj := Vals.Base; + Disp_Array_Value_1 + (Stream, Rti.Element, Ctxt, Rngs, Rti.Indexes, 0, Obj, Is_Sig); + end Disp_Array_Value; + + procedure Disp_Record_Value (Stream : FILEs; + Rti : Ghdl_Rtin_Type_Record_Acc; + Ctxt : Rti_Context; + Obj : Address; + Is_Sig : Boolean) + is + El : Ghdl_Rtin_Element_Acc; + El_Addr : Address; + begin + Put (Stream, "("); + for I in 1 .. Rti.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); + if I /= 1 then + Put (", "); + end if; + Put (Stream, El.Name); + Put (" => "); + if Is_Sig then + El_Addr := Obj + El.Sig_Off; + else + El_Addr := Obj + El.Val_Off; + end if; + if Rti_Complex_Type (El.Eltype) then + El_Addr := Obj + To_Ghdl_Index_Acc (El_Addr).all; + end if; + Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Is_Sig); + end loop; + Put (")"); + -- FIXME: update ADDR. + end Disp_Record_Value; + + procedure Disp_Value + (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Obj : in out Address; + Is_Sig : Boolean) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Subtype_Scalar => + Disp_Scalar_Value + (Stream, To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype, + Obj, Is_Sig); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + Disp_Scalar_Value (Stream, Rti, Obj, Is_Sig); + when Ghdl_Rtik_Type_Array => + Disp_Array_Value (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, + To_Ghdl_Uc_Array_Acc (Obj), Is_Sig); + when Ghdl_Rtik_Subtype_Array => + declare + St : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + B : Address; + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); + B := Obj; + Disp_Array_Value_1 + (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig); + end; + when Ghdl_Rtik_Type_File => + declare + Vptr : Ghdl_Value_Ptr; + begin + Vptr := To_Ghdl_Value_Ptr (Obj); + Put (Stream, "File#"); + Put_I32 (Stream, Vptr.I32); + -- FIXME: update OBJ (not very useful since never in a + -- composite type). + end; + when Ghdl_Rtik_Type_Record => + Disp_Record_Value + (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Is_Sig); + when Ghdl_Rtik_Type_Protected => + Put (Stream, "Unhandled protected type"); + when others => + Put (Stream, "Unknown Rti Kind : "); + Disp_Kind(Rti.Kind); + end case; + -- Put_Line(":"); + end Disp_Value; + + procedure Disp_Kind (Kind : Ghdl_Rtik) is + begin + case Kind is + when Ghdl_Rtik_Top => + Put ("ghdl_rtik_top"); + when Ghdl_Rtik_Package => + Put ("ghdl_rtik_package"); + when Ghdl_Rtik_Package_Body => + Put ("ghdl_rtik_package_body"); + when Ghdl_Rtik_Entity => + Put ("ghdl_rtik_entity"); + when Ghdl_Rtik_Architecture => + Put ("ghdl_rtik_architecture"); + + when Ghdl_Rtik_Port => + Put ("ghdl_rtik_port"); + when Ghdl_Rtik_Generic => + Put ("ghdl_rtik_generic"); + when Ghdl_Rtik_Process => + Put ("ghdl_rtik_process"); + when Ghdl_Rtik_Component => + Put ("ghdl_rtik_component"); + when Ghdl_Rtik_Attribute => + Put ("ghdl_rtik_attribute"); + + when Ghdl_Rtik_Attribute_Quiet => + Put ("ghdl_rtik_attribute_quiet"); + when Ghdl_Rtik_Attribute_Stable => + Put ("ghdl_rtik_attribute_stable"); + when Ghdl_Rtik_Attribute_Transaction => + Put ("ghdl_rtik_attribute_transaction"); + + when Ghdl_Rtik_Constant => + Put ("ghdl_rtik_constant"); + when Ghdl_Rtik_Iterator => + Put ("ghdl_rtik_iterator"); + when Ghdl_Rtik_Signal => + Put ("ghdl_rtik_signal"); + when Ghdl_Rtik_Variable => + Put ("ghdl_rtik_variable"); + when Ghdl_Rtik_Guard => + Put ("ghdl_rtik_guard"); + when Ghdl_Rtik_File => + Put ("ghdl_rtik_file"); + + when Ghdl_Rtik_Instance => + Put ("ghdl_rtik_instance"); + when Ghdl_Rtik_Block => + Put ("ghdl_rtik_block"); + when Ghdl_Rtik_If_Generate => + Put ("ghdl_rtik_if_generate"); + when Ghdl_Rtik_For_Generate => + Put ("ghdl_rtik_for_generate"); + + when Ghdl_Rtik_Type_B1 => + Put ("ghdl_rtik_type_b1"); + when Ghdl_Rtik_Type_E8 => + Put ("ghdl_rtik_type_e8"); + when Ghdl_Rtik_Type_E32 => + Put ("ghdl_rtik_type_e32"); + when Ghdl_Rtik_Type_P64 => + Put ("ghdl_rtik_type_p64"); + when Ghdl_Rtik_Type_I32 => + Put ("ghdl_rtik_type_i32"); + + when Ghdl_Rtik_Type_Array => + Put ("ghdl_rtik_type_array"); + when Ghdl_Rtik_Subtype_Array => + Put ("ghdl_rtik_subtype_array"); + when Ghdl_Rtik_Type_Record => + Put ("ghdl_rtik_type_record"); + + when Ghdl_Rtik_Type_Access => + Put ("ghdl_rtik_type_access"); + when Ghdl_Rtik_Type_File => + Put ("ghdl_rtik_type_file"); + when Ghdl_Rtik_Type_Protected => + Put ("ghdl_rtik_type_protected"); + + when Ghdl_Rtik_Subtype_Scalar => + Put ("ghdl_rtik_subtype_scalar"); + + when Ghdl_Rtik_Element => + Put ("ghdl_rtik_element"); + when Ghdl_Rtik_Unit64 => + Put ("ghdl_rtik_unit64"); + when Ghdl_Rtik_Unitptr => + Put ("ghdl_rtik_unitptr"); + + when others => + Put ("ghdl_rtik_#"); + Put_I32 (stdout, Ghdl_Rtik'Pos (Kind)); + end case; + end Disp_Kind; + + procedure Disp_Depth (Depth : Ghdl_Rti_Depth) is + begin + Put (", D="); + Put_I32 (stdout, Ghdl_I32 (Depth)); + end Disp_Depth; + + procedure Disp_Indent (Indent : Natural) is + begin + for I in 1 .. Indent loop + Put (' '); + end loop; + end Disp_Indent; + + -- Disp a subtype_indication. + -- OBJ may be necessary when the subtype is an unconstrained array type, + -- whose bounds are stored with the object. + procedure Disp_Subtype_Indication + (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address); + + procedure Disp_Range + (Stream : FILEs; Kind : Ghdl_Rtik; Rng : Ghdl_Range_Ptr) + is + begin + case Kind is + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_P32 => + Put_I32 (Stream, Rng.I32.Left); + Put_Dir (Stream, Rng.I32.Dir); + Put_I32 (Stream, Rng.I32.Right); + when Ghdl_Rtik_Type_F64 => + Put_F64 (Stream, Rng.F64.Left); + Put_Dir (Stream, Rng.F64.Dir); + Put_F64 (Stream, Rng.F64.Right); + when Ghdl_Rtik_Type_P64 => + Put_I64 (Stream, Rng.P64.Left); + Put_Dir (Stream, Rng.P64.Dir); + Put_I64 (Stream, Rng.P64.Right); + when others => + Put ("?Scal"); + end case; + end Disp_Range; + + procedure Disp_Scalar_Type_Name (Def : Ghdl_Rti_Access) is + begin + case Def.Kind is + when Ghdl_Rtik_Subtype_Scalar => + declare + Rti : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); + if Rti.Name /= null then + Disp_Name (Rti.Name); + else + Disp_Scalar_Type_Name (Rti.Basetype); + end if; + end; + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when others => + Put ("#disp_scalar_type_name#"); + end case; + end Disp_Scalar_Type_Name; + + procedure Disp_Type_Array_Name (Def : Ghdl_Rtin_Type_Array_Acc; + Bounds_Ptr : Address) + is + Bounds : Address; + + procedure Align (A : Ghdl_Index_Type) is + begin + Bounds := Align (Bounds, Ghdl_Rti_Loc (A)); + end Align; + + procedure Update (S : Ghdl_Index_Type) is + begin + Bounds := Bounds + (S / Storage_Unit); + end Update; + + procedure Disp_Bounds (Def : Ghdl_Rti_Access) + is + Ndef : Ghdl_Rti_Access; + begin + if Bounds = Null_Address then + Put ("?"); + else + if Def.Kind = Ghdl_Rtik_Subtype_Scalar then + Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def).Basetype; + else + Ndef := Def; + end if; + case Ndef.Kind is + when Ghdl_Rtik_Type_I32 => + Align (Ghdl_Range_I32'Alignment); + Disp_Range (stdout, Ndef.Kind, To_Ghdl_Range_Ptr (Bounds)); + Update (Ghdl_Range_I32'Size); + when others => + Disp_Kind (Ndef.Kind); + -- Bounds are not known anymore. + Bounds := Null_Address; + end case; + end if; + end Disp_Bounds; + begin + Disp_Name (Def.Name); + if Bounds_Ptr = Null_Address then + return; + end if; + Put (" ("); + Bounds := Bounds_Ptr; + for I in 0 .. Def.Nbr_Dim - 1 loop + if I /= 0 then + Put (", "); + end if; + Disp_Scalar_Type_Name (Def.Indexes (I)); + Put (" range "); + Disp_Bounds (Def.Indexes (I)); + end loop; + Put (")"); + end Disp_Type_Array_Name; + + procedure Disp_Subtype_Scalar_Range + (Stream : FILEs; Def : Ghdl_Rtin_Subtype_Scalar_Acc; Ctxt : Rti_Context) + is + Range_Addr : Address; + Rng : Ghdl_Range_Ptr; + begin + Range_Addr := Loc_To_Addr (Def.Common.Depth, + Def.Range_Loc, Ctxt); + Rng := To_Ghdl_Range_Ptr (Range_Addr); + Disp_Range (Stream, Def.Basetype.Kind, Rng); + end Disp_Subtype_Scalar_Range; + + procedure Disp_Subtype_Indication + (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address) + is + begin + case Def.Kind is + when Ghdl_Rtik_Subtype_Scalar => + declare + Rti : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); + if Rti.Name /= null then + Disp_Name (Rti.Name); + else + Disp_Subtype_Indication + (Rti.Basetype, Null_Context, Null_Address); + Put (" range "); + Disp_Subtype_Scalar_Range (stdout, Rti, Ctxt); + end if; + end; + --Disp_Scalar_Subtype_Name (To_Ghdl_Rtin_Scalsubtype_Acc (Def), + -- Base); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when Ghdl_Rtik_Type_File + | Ghdl_Rtik_Type_Access => + Disp_Name (To_Ghdl_Rtin_Type_Fileacc_Acc (Def).Name); + when Ghdl_Rtik_Type_Record => + Disp_Name (To_Ghdl_Rtin_Type_Record_Acc (Def).Name); + when Ghdl_Rtik_Type_Array => + declare + Bounds : Address; + begin + if Obj = Null_Address then + Bounds := Null_Address; + else + Bounds := To_Ghdl_Uc_Array_Acc (Obj).Bounds; + end if; + Disp_Type_Array_Name (To_Ghdl_Rtin_Type_Array_Acc (Def), + Bounds); + end; + when Ghdl_Rtik_Subtype_Array => + declare + Sdef : Ghdl_Rtin_Subtype_Array_Acc; + begin + Sdef := To_Ghdl_Rtin_Subtype_Array_Acc (Def); + if Sdef.Name /= null then + Disp_Name (Sdef.Name); + else + Disp_Type_Array_Name + (Sdef.Basetype, + Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt)); + end if; + end; + when Ghdl_Rtik_Type_Protected => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when others => + Disp_Kind (Def.Kind); + Put (' '); + end case; + end Disp_Subtype_Indication; + + + procedure Disp_Rti (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Indent : Natural); + + procedure Disp_Rti_Arr (Nbr : Ghdl_Index_Type; + Arr : Ghdl_Rti_Arr_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + for I in 1 .. Nbr loop + Disp_Rti (Arr (I - 1), Ctxt, Indent); + end loop; + end Disp_Rti_Arr; + + procedure Disp_Block (Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Nctxt : Rti_Context; + begin + Disp_Indent (Indent); + Disp_Kind (Blk.Common.Kind); + Disp_Depth (Blk.Common.Depth); + Put (": "); + Disp_Name (Blk.Name); + New_Line; + if Blk.Parent /= null then + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + -- Disp entity. + Disp_Rti (Blk.Parent, Ctxt, Indent + 1); + when others => + null; + end case; + end if; + case Blk.Common.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Package_Body + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_Process => + Nctxt := (Base => Ctxt.Base + Blk.Loc, + Block => To_Ghdl_Rti_Access (Blk)); + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + when Ghdl_Rtik_For_Generate => + declare + Length : Ghdl_Index_Type; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all, + Block => To_Ghdl_Rti_Access (Blk)); + Length := Get_For_Generate_Length (Blk, Ctxt); + for I in 1 .. Length loop + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + Nctxt.Base := Nctxt.Base + Blk.Size; + end loop; + end; + when Ghdl_Rtik_If_Generate => + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all, + Block => To_Ghdl_Rti_Access (Blk)); + if Nctxt.Base /= Null_Address then + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + end if; + when others => + Internal_Error ("disp_block"); + end case; + end Disp_Block; + + procedure Disp_Object (Obj : Ghdl_Rtin_Object_Acc; + Is_Sig : Boolean; + Ctxt : Rti_Context; + Indent : Natural) + is + Addr : Address; + Obj_Type : Ghdl_Rti_Access; + begin + Disp_Indent (Indent); + Disp_Kind (Obj.Common.Kind); + Disp_Depth (Obj.Common.Depth); + Put ("; "); + Disp_Name (Obj.Name); + Put (": "); + Addr := Loc_To_Addr (Obj.Common.Depth, Obj.Loc, Ctxt); + Obj_Type := Obj.Obj_Type; + Disp_Subtype_Indication (Obj_Type, Ctxt, Addr); + Put (" := "); + + -- FIXME: put this into a function. + if (Obj_Type.Kind = Ghdl_Rtik_Subtype_Array + or Obj_Type.Kind = Ghdl_Rtik_Type_Record) + and then Rti_Complex_Type (Obj_Type) + then + Addr := To_Addr_Acc (Addr).all; + end if; + Disp_Value (stdout, Obj_Type, Ctxt, Addr, Is_Sig); + New_Line; + end Disp_Object; + + procedure Disp_Attribute (Obj : Ghdl_Rtin_Object_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Obj.Common.Kind); + Disp_Depth (Obj.Common.Depth); + Put ("; "); + Disp_Name (Obj.Name); + Put (": "); + Disp_Subtype_Indication (Obj.Obj_Type, Ctxt, Null_Address); + New_Line; + end Disp_Attribute; + + procedure Disp_Component (Comp : Ghdl_Rtin_Component_Acc; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Comp.Common.Kind); + Disp_Depth (Comp.Common.Depth); + Put (": "); + Disp_Name (Comp.Name); + New_Line; + --Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Base, Ident + 1); + end Disp_Component; + + procedure Disp_Instance (Inst : Ghdl_Rtin_Instance_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Inst_Addr : Address; + Inst_Base : Address; + Inst_Rti : Ghdl_Rti_Access; + Nindent : Natural; + Nctxt : Rti_Context; + begin + Disp_Indent (Indent); + Disp_Kind (Inst.Common.Kind); + Put (": "); + Disp_Name (Inst.Name); + New_Line; + + Inst_Addr := Ctxt.Base + Inst.Loc; + -- Read sub instance. + Inst_Base := To_Addr_Acc (Inst_Addr).all; + + Nindent := Indent + 1; + + case Inst.Instance.Kind is + when Ghdl_Rtik_Component => + declare + Comp : Ghdl_Rtin_Component_Acc; + begin + Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); + Disp_Indent (Nindent); + Disp_Kind (Comp.Common.Kind); + Put (": "); + Disp_Name (Comp.Name); + New_Line; + -- Disp components generics and ports. + -- FIXME: the data to disp are at COMP_BASE. + Nctxt := (Base => Inst_Addr, + Block => Inst.Instance); + Nindent := Nindent + 1; + Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Nctxt, Nindent); + Nindent := Nindent + 1; + end; + when Ghdl_Rtik_Entity => + null; + when others => + null; + end case; + + -- Read instance RTI. + if Inst_Base /= Null_Address then + Inst_Rti := To_Ghdl_Rti_Acc_Acc (Inst_Base).all; + Nctxt := (Base => Inst_Base, + Block => Inst_Rti); + Disp_Block (To_Ghdl_Rtin_Block_Acc (Inst_Rti), + Nctxt, Nindent); + end if; + end Disp_Instance; + + procedure Disp_Type_Enum_Decl (Enum : Ghdl_Rtin_Type_Enum_Acc; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Enum.Common.Kind); + Put (": "); + Disp_Name (Enum.Name); + Put (" is ("); + Disp_Name (Enum.Names (0)); + for I in 1 .. Enum.Nbr - 1 loop + Put (", "); + Disp_Name (Enum.Names (I)); + end loop; + Put (")"); + New_Line; + end Disp_Type_Enum_Decl; + + procedure Disp_Subtype_Scalar_Decl (Def : Ghdl_Rtin_Subtype_Scalar_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Bt : Ghdl_Rti_Access; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Disp_Depth (Def.Common.Depth); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + Bt := Def.Basetype; + case Bt.Kind is + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_F64 => + declare + Bdef : Ghdl_Rtin_Type_Scalar_Acc; + begin + Bdef := To_Ghdl_Rtin_Type_Scalar_Acc (Bt); + if Bdef.Name /= Def.Name then + Disp_Name (Bdef.Name); + Put (" range "); + end if; + -- This is the type definition. + Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); + end; + when Ghdl_Rtik_Type_P64 + | Ghdl_Rtik_Type_P32 => + declare + Bdef : Ghdl_Rtin_Type_Physical_Acc; + Unit : Ghdl_Rti_Access; + begin + Bdef := To_Ghdl_Rtin_Type_Physical_Acc (Bt); + if Bdef.Name /= Def.Name then + Disp_Name (Bdef.Name); + Put (" range "); + end if; + -- This is the type definition. + Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); + if Bdef.Name = Def.Name then + for I in 0 .. Bdef.Nbr - 1 loop + Unit := Bdef.Units (I); + New_Line; + Disp_Indent (Indent + 1); + Disp_Kind (Unit.Kind); + Put (": "); + Disp_Name (Get_Physical_Unit_Name (Unit)); + Put (" = "); + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + Put_I64 (stdout, + To_Ghdl_Rtin_Unit64_Acc (Unit).Value); + when Ghdl_Rtik_Unitptr => + case Bt.Kind is + when Ghdl_Rtik_Type_P64 => + Put_I64 + (stdout, + To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64); + when Ghdl_Rtik_Type_P32 => + Put_I32 + (stdout, + To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32); + when others => + Internal_Error + ("disp_rti.subtype.scalar_decl(P32/P64)"); + end case; + when others => + Internal_Error + ("disp_rti.subtype.scalar_decl(P32/P64)"); + end case; + end loop; + end if; + end; + when others => + Disp_Subtype_Indication + (To_Ghdl_Rti_Access (Def), Ctxt, Null_Address); + end case; + New_Line; + end Disp_Subtype_Scalar_Decl; + + procedure Disp_Type_Array_Decl (Def : Ghdl_Rtin_Type_Array_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is array ("); + for I in 0 .. Def.Nbr_Dim - 1 loop + if I /= 0 then + Put (", "); + end if; + Disp_Subtype_Indication (Def.Indexes (I), Ctxt, Null_Address); + Put (" range <>"); + end loop; + Put (") of "); + Disp_Subtype_Indication (Def.Element, Ctxt, Null_Address); + New_Line; + end Disp_Type_Array_Decl; + + procedure Disp_Subtype_Array_Decl (Def : Ghdl_Rtin_Subtype_Array_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Basetype : constant Ghdl_Rtin_Type_Array_Acc := Def.Basetype; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + Disp_Type_Array_Name + (Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt)); + if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then + Put (" of "); + Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address); + end if; + New_Line; + end Disp_Subtype_Array_Decl; + + procedure Disp_Type_File_Or_Access (Def : Ghdl_Rtin_Type_Fileacc_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + case Def.Common.Kind is + when Ghdl_Rtik_Type_Access => + Put ("access "); + when Ghdl_Rtik_Type_File => + Put ("file "); + when others => + Put ("?? "); + end case; + Disp_Subtype_Indication (Def.Base, Ctxt, Null_Address); + New_Line; + end Disp_Type_File_Or_Access; + + procedure Disp_Type_Record (Def : Ghdl_Rtin_Type_Record_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + El : Ghdl_Rtin_Element_Acc; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is record"); + New_Line; + for I in 1 .. Def.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1)); + Disp_Indent (Indent + 1); + Disp_Kind (El.Common.Kind); + Put (": "); + Disp_Name (El.Name); + Put (": "); + Disp_Subtype_Indication (El.Eltype, Ctxt, Null_Address); + New_Line; + end loop; + end Disp_Type_Record; + + procedure Disp_Type_Protected (Def : Ghdl_Rtin_Type_Scalar_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + pragma Unreferenced (Ctxt); + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is protected"); + New_Line; + end Disp_Type_Protected; + + procedure Disp_Rti (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + if Rti = null then + return; + end if; + + case Rti.Kind is + when Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Package + | Ghdl_Rtik_Process + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate + | Ghdl_Rtik_For_Generate => + Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Package_Body => + Disp_Rti (To_Ghdl_Rtin_Block_Acc (Rti).Parent, Ctxt, Indent); + Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), True, Ctxt, Indent); + when Ghdl_Rtik_Generic + | Ghdl_Rtik_Constant + | Ghdl_Rtik_Variable + | Ghdl_Rtik_Iterator + | Ghdl_Rtik_File => + Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), False, Ctxt, Indent); + when Ghdl_Rtik_Component => + Disp_Component (To_Ghdl_Rtin_Component_Acc (Rti), Indent); + when Ghdl_Rtik_Attribute => + Disp_Attribute (To_Ghdl_Rtin_Object_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Instance => + Disp_Instance (To_Ghdl_Rtin_Instance_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Type_Enum_Decl (To_Ghdl_Rtin_Type_Enum_Acc (Rti), Indent); + when Ghdl_Rtik_Subtype_Scalar => + Disp_Subtype_Scalar_Decl (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti), + Ctxt, Indent); + when Ghdl_Rtik_Type_Array => + Disp_Type_Array_Decl + (To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Subtype_Array => + Disp_Subtype_Array_Decl + (To_Ghdl_Rtin_Subtype_Array_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Access + | Ghdl_Rtik_Type_File => + Disp_Type_File_Or_Access + (To_Ghdl_Rtin_Type_Fileacc_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Record => + Disp_Type_Record + (To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Protected => + Disp_Type_Protected + (To_Ghdl_Rtin_Type_Scalar_Acc (Rti), Ctxt, Indent); + when others => + Disp_Indent (Indent); + Disp_Kind (Rti.Kind); + Put_Line (" ? "); + end case; + end Disp_Rti; + + Disp_Rti_Flag : Boolean := False; + + procedure Disp_All + is + Ctxt : Rti_Context; + begin + if not Disp_Rti_Flag then + return; + end if; + + Put ("DISP_RTI.Disp_All: "); + Disp_Kind (Ghdl_Rti_Top.Common.Kind); + New_Line; + Ctxt := (Base => Ghdl_Rti_Top_Instance, + Block => Ghdl_Rti_Top.Parent); + Disp_Rti_Arr (Ghdl_Rti_Top.Nbr_Child, + Ghdl_Rti_Top.Children, + Ctxt, 0); + Disp_Rti (Ghdl_Rti_Top.Parent, Ctxt, 0); + + --Disp_Hierarchy; + end Disp_All; + + function Disp_Rti_Option (Opt : String) return Boolean + is + begin + if Opt = "--dump-rti" then + Disp_Rti_Flag := True; + return True; + else + return False; + end if; + end Disp_Rti_Option; + + procedure Disp_Rti_Help + is + procedure P (Str : String) renames Put_Line; + begin + P (" --dump-rti dump Run Time Information"); + end Disp_Rti_Help; + + Disp_Rti_Hooks : aliased constant Hooks_Type := + (Option => Disp_Rti_Option'Access, + Help => Disp_Rti_Help'Access, + Init => null, + Start => Disp_All'Access, + Finish => null); + + procedure Register is + begin + Register_Hooks (Disp_Rti_Hooks'Access); + end Register; + +end Grt.Disp_Rti; diff --git a/src/translate/grt/grt-disp_rti.ads b/src/translate/grt/grt-disp_rti.ads new file mode 100644 index 0000000..6033d20 --- /dev/null +++ b/src/translate/grt/grt-disp_rti.ads @@ -0,0 +1,43 @@ +-- GHDL Run Time (GRT) - RTI dumper. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Types; use Grt.Types; +with Grt.Stdio; use Grt.Stdio; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; + +package Grt.Disp_Rti is + -- Disp NAME. If NAME is null, then disp <anonymous>. + procedure Disp_Name (Name : Ghdl_C_String); + + -- Disp a value. + procedure Disp_Value (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Obj : in out Address; + Is_Sig : Boolean); + + procedure Register; +end Grt.Disp_Rti; diff --git a/src/translate/grt/grt-disp_signals.adb b/src/translate/grt/grt-disp_signals.adb new file mode 100644 index 0000000..424d20d --- /dev/null +++ b/src/translate/grt/grt-disp_signals.adb @@ -0,0 +1,524 @@ +-- GHDL Run Time (GRT) - Display subprograms for signals. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Ada.Unchecked_Conversion; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; +with Grt.Astdio; use Grt.Astdio; +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; + Nctxt : Rti_Context; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Blk.Common.Kind is + when Ghdl_Rtik_Block + | Ghdl_Rtik_Process => + Nctxt := Get_Parent_Context (Ctxt); + Disp_Context (Nctxt); + Put ('.'); + Put (Blk.Name); + when Ghdl_Rtik_Entity => + Put (Blk.Name); + when Ghdl_Rtik_Architecture => + Nctxt := Get_Parent_Context (Ctxt); + Disp_Context (Nctxt); + Put ('('); + Put (Blk.Name); + Put (')'); + when others => + Internal_Error ("disp_context"); + end case; + end Disp_Context; + + -- This is a debugging procedure. + pragma Unreferenced (Disp_Context); + + -- Option --trace-signals. + + -- Disp transaction TRANS from signal SIG. + procedure Disp_Transaction (Trans : Transaction_Acc; + Sig_Type : Ghdl_Rti_Access; + Mode : Mode_Type) + is + T : Transaction_Acc; + begin + T := Trans; + loop + case T.Kind is + when Trans_Value => + if Sig_Type /= null then + Disp_Value (stdout, T.Val, Sig_Type); + else + Disp_Value (T.Val, Mode); + end if; + when Trans_Direct => + if Sig_Type /= null then + Disp_Value (stdout, T.Val_Ptr.all, Sig_Type); + else + Disp_Value (T.Val_Ptr.all, Mode); + end if; + when Trans_Null => + Put ("NULL"); + when Trans_Error => + Put ("ERROR"); + end case; + if T.Kind = Trans_Direct then + -- The Time field is not updated for direct transaction. + Put ("[DIRECT]"); + else + Put ("@"); + Put_Time (stdout, T.Time); + end if; + T := T.Next; + exit when T = null; + Put (", "); + end loop; + end Disp_Transaction; + + procedure Disp_Simple_Signal + (Sig : Ghdl_Signal_Ptr; Sig_Type : Ghdl_Rti_Access; Sources : Boolean) + is + function To_Address is new Ada.Unchecked_Conversion + (Source => Resolved_Signal_Acc, Target => Address); + begin + Put (' '); + Put (stdout, Sig.all'Address); + Put (' '); + Disp_Mode (Sig.Mode); + Put (' '); + if Sig.Active then + Put ('A'); + else + Put ('-'); + end if; + if Sig.Event then + Put ('E'); + else + Put ('-'); + end if; + if Sig.Has_Active then + Put ('a'); + else + Put ('-'); + end if; + if Sig.S.Effective /= null then + Put ('e'); + else + Put ('-'); + end if; + if Boolean'(True) then + Put (" last_event="); + Put_Time (stdout, Sig.Last_Event); + Put (" last_active="); + Put_Time (stdout, Sig.Last_Active); + end if; + Put (" val="); + if Sig_Type /= null then + Disp_Value (stdout, Sig.Value, Sig_Type); + else + Disp_Value (Sig.Value, Sig.Mode); + end if; + Put ("; drv="); + if Sig_Type /= null then + Disp_Value (stdout, Sig.Driving_Value, Sig_Type); + else + Disp_Value (Sig.Driving_Value, Sig.Mode); + end if; + if Sources then + if Sig.Nbr_Ports > 0 then + Put (';'); + Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports)); + Put (" ports"); + end if; + if Sig.S.Mode_Sig in Mode_Signal_User then + if Sig.S.Resolv /= null then + Put (stdout, " res func "); + Put (stdout, To_Address(Sig.S.Resolv)); + end if; + if Sig.S.Nbr_Drivers = 0 then + Put ("; no driver"); + elsif Sig.S.Nbr_Drivers = 1 then + Put ("; trans="); + Disp_Transaction + (Sig.S.Drivers (0).First_Trans, Sig_Type, Sig.Mode); + else + for I in 0 .. Sig.S.Nbr_Drivers - 1 loop + New_Line; + Put (" "); + Disp_Transaction + (Sig.S.Drivers (I).First_Trans, Sig_Type, Sig.Mode); + end loop; + end if; + end if; + end if; + New_Line; + end Disp_Simple_Signal; + + 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, " 'transaction"); + when others => + null; + end case; + end Disp_Signal_Name; + + procedure Disp_Scalar_Signal (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) + is + begin + 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; + + + procedure Disp_All_Signals is + begin + Foreach_Scalar_Signal (Disp_Scalar_Signal'access); + end Disp_All_Signals; + + -- Option disp-sensitivity + + procedure Disp_Scalar_Sensitivity (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) + is + pragma Unreferenced (Val_Type); + Sig : Ghdl_Signal_Ptr; + + Action : Action_List_Acc; + begin + Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); + if Sig.Flags.Seen then + return; + else + Sig.Flags.Seen := True; + end if; + 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; + + procedure Disp_All_Sensitivity is + begin + Foreach_Scalar_Signal (Disp_Scalar_Sensitivity'access); + end Disp_All_Sensitivity; + + + -- Option disp-signals-map + + procedure Disp_Signals_Map_Scalar (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) + is + pragma Unreferenced (Val_Type); + + function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Signal_Ptr); + + S : Ghdl_Signal_Ptr; + begin + 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); + Put (stdout, S.all'Address); + Put (" net: "); + Put_I32 (stdout, Ghdl_I32 (S.Net)); + if S.Has_Active then + Put (" +A"); + end if; + New_Line; + end Disp_Signals_Map_Scalar; + + procedure Disp_Signals_Map is + begin + Foreach_Scalar_Signal (Disp_Signals_Map_Scalar'access); + end Disp_Signals_Map; + + -- Option --disp-signals-table + procedure Disp_Mode_Signal (Mode : Mode_Signal_Type) + is + begin + case Mode is + when Mode_Signal => + Put ("signal"); + when Mode_Linkage => + Put ("linkage"); + when Mode_Buffer => + Put ("buffer"); + when Mode_Out => + Put ("out"); + when Mode_Inout => + Put ("inout"); + when Mode_In => + Put ("in"); + when Mode_Stable => + Put ("stable"); + when Mode_Quiet => + Put ("quiet"); + when Mode_Transaction => + Put ("transaction"); + when Mode_Delayed => + Put ("delayed"); + when Mode_Guard => + Put ("guard"); + when Mode_Conv_In => + Put ("conv_in"); + when Mode_Conv_Out => + Put ("conv_out"); + when Mode_End => + Put ("end"); + end case; + end Disp_Mode_Signal; + + procedure Disp_Signals_Table + is + Sig : Ghdl_Signal_Ptr; + begin + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + Put_Sig_Index (I); + Put (": "); + Put (stdout, Sig.all'Address); + if Sig.Has_Active then + Put (" +A"); + end if; + Put (" net: "); + Put_I32 (stdout, Ghdl_I32 (Sig.Net)); + Put (" smode: "); + Disp_Mode_Signal (Sig.S.Mode_Sig); + Put (" #prt: "); + Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports)); + if Sig.S.Mode_Sig in Mode_Signal_User then + Put (" #drv: "); + Put_I32 (stdout, Ghdl_I32 (Sig.S.Nbr_Drivers)); + if Sig.S.Effective /= null then + Put (" eff: "); + Put (stdout, Sig.S.Effective.all'Address); + end if; + if Sig.S.Resolv /= null then + Put (" resolved"); + end if; + end if; + if Boolean'(False) then + Put (" link: "); + Put (stdout, Sig.Link.all'Address); + end if; + New_Line; + if Sig.Nbr_Ports /= 0 then + for J in 1 .. Sig.Nbr_Ports loop + Put (" "); + Put (stdout, Sig.Ports (J - 1).all'Address); + end loop; + New_Line; + end if; + end loop; + Grt.Stdio.fflush (stdout); + end Disp_Signals_Table; + + procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr) + is + begin + Disp_Simple_Signal (Sig, null, True); + end Disp_A_Signal; + + procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr) + is + Found : Boolean := False; + Cur_Ctxt : Rti_Context; + Cur_Sig : Ghdl_Rtin_Object_Acc; + + procedure Process_Scalar (Val_Addr : Address; + Val_Name : Vstring; + 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 + 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 + (Param_Type => Boolean, Process => Process_Scalar); + + function Process_Block (Ctxt : Rti_Context; + Obj : Ghdl_Rti_Access) + return Traverse_Result + is + 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_Ctxt := Ctxt; + 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, True); + if Found then + return Traverse_Stop; + end if; + when others => + null; + end case; + return Traverse_Ok; + end Process_Block; + + function Foreach_Block is new Grt.Rtis_Utils.Traverse_Blocks + (Process_Block); + + Res_Status : Traverse_Result; + pragma Unreferenced (Res_Status); + begin + Res_Status := Foreach_Block (Get_Top_Context); + if not Found then + Put (Stream, "(unknown signal)"); + end if; + end Put_Signal_Name; + +end Grt.Disp_Signals; diff --git a/src/translate/grt/grt-disp_signals.ads b/src/translate/grt/grt-disp_signals.ads new file mode 100644 index 0000000..73bd60d --- /dev/null +++ b/src/translate/grt/grt-disp_signals.ads @@ -0,0 +1,48 @@ +-- GHDL Run Time (GRT) - Display subprograms for signals. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Signals; use Grt.Signals; +with Grt.Stdio; use Grt.Stdio; + +package Grt.Disp_Signals is + procedure Disp_All_Signals; + + procedure Disp_Signals_Map; + + procedure Disp_Signals_Table; + + procedure Disp_All_Sensitivity; + + procedure Disp_Mode_Signal (Mode : Mode_Signal_Type); + + -- Disp informations on signal SIG. + -- To be used inside the debugger. + procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr); + + -- Put the full name of signal SIG. + -- This operation is really expensive, since the whole hierarchy is + -- traversed. + procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr); +end Grt.Disp_Signals; diff --git a/src/translate/grt/grt-disp_tree.adb b/src/translate/grt/grt-disp_tree.adb new file mode 100644 index 0000000..7d58119 --- /dev/null +++ b/src/translate/grt/grt-disp_tree.adb @@ -0,0 +1,461 @@ +-- GHDL Run Time (GRT) - Tree displayer. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Disp_Rti; use Grt.Disp_Rti; +with Grt.Rtis; use Grt.Rtis; +with Grt.Stdio; use Grt.Stdio; +with Grt.Astdio; use Grt.Astdio; +with Grt.Types; use Grt.Types; +with Grt.Errors; use Grt.Errors; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Hooks; use Grt.Hooks; + +package body Grt.Disp_Tree is + -- Set by --disp-tree, to display the design hierarchy. + type Disp_Tree_Kind is + ( + Disp_Tree_None, -- Do not disp tree. + Disp_Tree_Inst, -- Disp entities, arch, package, blocks, components. + Disp_Tree_Proc, -- As above plus processes + Disp_Tree_Port -- As above plus ports and signals. + ); + Disp_Tree_Flag : Disp_Tree_Kind := Disp_Tree_None; + + + -- Get next interesting child. + procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc; + Index : in out Ghdl_Index_Type; + Child : out Ghdl_Rti_Access) + is + begin + -- Exit if no more children. + while Index < Parent.Nbr_Child loop + Child := Parent.Children (Index); + Index := Index + 1; + case Child.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate + | Ghdl_Rtik_Instance => + return; + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard => + if Disp_Tree_Flag >= Disp_Tree_Port then + return; + end if; + when Ghdl_Rtik_Process => + if Disp_Tree_Flag >= Disp_Tree_Proc then + return; + end if; + when others => + null; + end case; + end loop; + Child := null; + end Get_Tree_Child; + + procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Entity + | Ghdl_Rtik_Process + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate => + declare + Blk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Rti); + begin + Disp_Name (Blk.Name); + end; + when Ghdl_Rtik_Package_Body + | Ghdl_Rtik_Package => + declare + Blk : Ghdl_Rtin_Block_Acc; + Lib : Ghdl_Rtin_Type_Scalar_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Rti); + if Rti.Kind = Ghdl_Rtik_Package_Body then + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + end if; + Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent); + Disp_Name (Lib.Name); + Put ('.'); + Disp_Name (Blk.Name); + end; + when Ghdl_Rtik_For_Generate => + declare + Blk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Rti); + Iter : Ghdl_Rtin_Object_Acc; + Addr : Address; + begin + Disp_Name (Blk.Name); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); + Put ('('); + Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False); + Put (')'); + end; + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Iterator => + Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name); + when Ghdl_Rtik_Instance => + Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name); + when others => + null; + end case; + + case Rti.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Package_Body => + Put (" [package]"); + when Ghdl_Rtik_Entity => + Put (" [entity]"); + when Ghdl_Rtik_Architecture => + Put (" [arch]"); + when Ghdl_Rtik_Process => + Put (" [process]"); + when Ghdl_Rtik_Block => + Put (" [block]"); + when Ghdl_Rtik_For_Generate => + Put (" [for-generate]"); + when Ghdl_Rtik_If_Generate => + Put (" [if-generate "); + if Ctxt.Base = Null_Address then + Put ("false]"); + else + Put ("true]"); + end if; + when Ghdl_Rtik_Signal => + Put (" [signal]"); + when Ghdl_Rtik_Port => + Put (" [port "); + case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is + when Ghdl_Rti_Signal_Mode_In => + Put ("in"); + when Ghdl_Rti_Signal_Mode_Out => + Put ("out"); + when Ghdl_Rti_Signal_Mode_Inout => + Put ("inout"); + when Ghdl_Rti_Signal_Mode_Buffer => + Put ("buffer"); + when Ghdl_Rti_Signal_Mode_Linkage => + Put ("linkage"); + when others => + Put ("?"); + end case; + Put ("]"); + when Ghdl_Rtik_Guard => + Put (" [guard]"); + when Ghdl_Rtik_Iterator => + Put (" [iterator]"); + when Ghdl_Rtik_Instance => + Put (" [instance]"); + when others => + null; + end case; + end Disp_Tree_Child; + + procedure Disp_Tree_Block + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String); + + procedure Disp_Tree_Block1 + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) + is + Child : Ghdl_Rti_Access; + Child2 : Ghdl_Rti_Access; + Index : Ghdl_Index_Type; + + procedure Disp_Header (Nctxt : Rti_Context; + Force_Cont : Boolean := False) + is + begin + Put (Pfx); + + if Blk.Common.Kind /= Ghdl_Rtik_Entity + and Child2 = null + and Force_Cont = False + then + Put ("`-"); + else + Put ("+-"); + end if; + + Disp_Tree_Child (Child, Nctxt); + New_Line; + end Disp_Header; + + procedure Disp_Sub_Block + (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context) + is + Npfx : String (1 .. Pfx'Length + 2); + begin + Npfx (1 .. Pfx'Length) := Pfx; + Npfx (Pfx'Length + 2) := ' '; + if Child2 = null then + Npfx (Pfx'Length + 1) := ' '; + else + Npfx (Pfx'Length + 1) := '|'; + end if; + Disp_Tree_Block (Sub_Blk, Nctxt, Npfx); + end Disp_Sub_Block; + + begin + Index := 0; + Get_Tree_Child (Blk, Index, Child); + while Child /= null loop + Get_Tree_Child (Blk, Index, Child2); + + case Child.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + declare + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + begin + Nctxt := (Base => Ctxt.Base + Nblk.Loc, + Block => Child); + Disp_Header (Nctxt, False); + Disp_Sub_Block (Nblk, Nctxt); + end; + when Ghdl_Rtik_For_Generate => + declare + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + Length : Ghdl_Index_Type; + Old_Child2 : Ghdl_Rti_Access; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + Length := Get_For_Generate_Length (Nblk, Ctxt); + Disp_Header (Nctxt, Length > 1); + Old_Child2 := Child2; + if Length > 1 then + Child2 := Child; + end if; + for I in 1 .. Length loop + Disp_Sub_Block (Nblk, Nctxt); + if I /= Length then + Nctxt.Base := Nctxt.Base + Nblk.Size; + if I = Length - 1 then + Child2 := Old_Child2; + end if; + Disp_Header (Nctxt); + end if; + end loop; + Child2 := Old_Child2; + end; + when Ghdl_Rtik_If_Generate => + declare + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + Disp_Header (Nctxt); + if Nctxt.Base /= Null_Address then + Disp_Sub_Block (Nblk, Nctxt); + end if; + end; + when Ghdl_Rtik_Instance => + declare + Inst : Ghdl_Rtin_Instance_Acc; + Sub_Ctxt : Rti_Context; + Sub_Blk : Ghdl_Rtin_Block_Acc; + Npfx : String (1 .. Pfx'Length + 4); + Comp : Ghdl_Rtin_Component_Acc; + Ch : Ghdl_Rti_Access; + begin + Disp_Header (Ctxt); + Inst := To_Ghdl_Rtin_Instance_Acc (Child); + Get_Instance_Context (Inst, Ctxt, Sub_Ctxt); + Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block); + if Inst.Instance.Kind = Ghdl_Rtik_Component + and then Disp_Tree_Flag >= Disp_Tree_Port + then + -- Disp generics and ports of the component. + Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); + for I in 1 .. Comp.Nbr_Child loop + Ch := Comp.Children (I - 1); + if Ch.Kind = Ghdl_Rtik_Port then + -- Disp only port (and not generics). + Put (Pfx); + if Child2 = null then + Put (" "); + else + Put ("| "); + end if; + if I = Comp.Nbr_Child and then Sub_Blk = null then + Put ("`-"); + else + Put ("+-"); + end if; + Disp_Tree_Child (Ch, Sub_Ctxt); + New_Line; + end if; + end loop; + end if; + if Sub_Blk /= null then + Npfx (1 .. Pfx'Length) := Pfx; + if Child2 = null then + Npfx (Pfx'Length + 1) := ' '; + else + Npfx (Pfx'Length + 1) := '|'; + end if; + Npfx (Pfx'Length + 2) := ' '; + Npfx (Pfx'Length + 3) := '`'; + Npfx (Pfx'Length + 4) := '-'; + Put (Npfx); + Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt); + New_Line; + Npfx (Pfx'Length + 3) := ' '; + Npfx (Pfx'Length + 4) := ' '; + Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx); + end if; + end; + when others => + Disp_Header (Ctxt); + end case; + + Child := Child2; + end loop; + end Disp_Tree_Block1; + + procedure Disp_Tree_Block + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) + is + begin + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + declare + Npfx : String (1 .. Pfx'Length + 2); + Nctxt : Rti_Context; + begin + -- The entity. + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + Disp_Tree_Block1 + (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx); + -- Then the architecture. + Put (Pfx); + Put ("`-"); + Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt); + New_Line; + Npfx (1 .. Pfx'Length) := Pfx; + Npfx (Pfx'Length + 1) := ' '; + Npfx (Pfx'Length + 2) := ' '; + Disp_Tree_Block1 (Blk, Ctxt, Npfx); + end; + when Ghdl_Rtik_Package_Body => + Disp_Tree_Block1 + (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx); + when others => + Disp_Tree_Block1 (Blk, Ctxt, Pfx); + end case; + end Disp_Tree_Block; + + procedure Disp_Hierarchy + is + Ctxt : Rti_Context; + Parent : Ghdl_Rtin_Block_Acc; + Child : Ghdl_Rti_Access; + begin + if Disp_Tree_Flag = Disp_Tree_None then + return; + end if; + + Ctxt := Get_Top_Context; + Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + + Disp_Tree_Child (Parent.Parent, Ctxt); + New_Line; + Disp_Tree_Block (Parent, Ctxt, ""); + + for I in 1 .. Ghdl_Rti_Top.Nbr_Child loop + Child := Ghdl_Rti_Top.Children (I - 1); + Ctxt := (Base => Null_Address, + Block => Child); + Disp_Tree_Child (Child, Ctxt); + New_Line; + Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, ""); + end loop; + end Disp_Hierarchy; + + function Disp_Tree_Option (Option : String) return Boolean + is + Opt : constant String (1 .. Option'Length) := Option; + begin + if Opt'Length >= 11 and then Opt (1 .. 11) = "--disp-tree" then + if Opt'Length = 11 then + Disp_Tree_Flag := Disp_Tree_Port; + elsif Opt (12 .. Opt'Last) = "=port" then + Disp_Tree_Flag := Disp_Tree_Port; + elsif Opt (12 .. Opt'Last) = "=proc" then + Disp_Tree_Flag := Disp_Tree_Proc; + elsif Opt (12 .. Opt'Last) = "=inst" then + Disp_Tree_Flag := Disp_Tree_Inst; + elsif Opt (12 .. Opt'Last) = "=none" then + Disp_Tree_Flag := Disp_Tree_None; + else + Error ("bad argument for --disp-tree option, try --help"); + end if; + return True; + else + return False; + end if; + end Disp_Tree_Option; + + procedure Disp_Tree_Help + is + procedure P (Str : String) renames Put_Line; + begin + P (" --disp-tree[=KIND] disp the design hierarchy after elaboration"); + P (" KIND is inst, proc, port (default)"); + end Disp_Tree_Help; + + Disp_Tree_Hooks : aliased constant Hooks_Type := + (Option => Disp_Tree_Option'Access, + Help => Disp_Tree_Help'Access, + Init => null, + Start => Disp_Hierarchy'Access, + Finish => null); + + procedure Register is + begin + Register_Hooks (Disp_Tree_Hooks'Access); + end Register; + +end Grt.Disp_Tree; diff --git a/src/translate/grt/grt-disp_tree.ads b/src/translate/grt/grt-disp_tree.ads new file mode 100644 index 0000000..e3bc983 --- /dev/null +++ b/src/translate/grt/grt-disp_tree.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - RTI dumper. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +package Grt.Disp_Tree is + procedure Register; +end Grt.Disp_Tree; diff --git a/src/translate/grt/grt-errors.adb b/src/translate/grt/grt-errors.adb new file mode 100644 index 0000000..eddea38 --- /dev/null +++ b/src/translate/grt/grt-errors.adb @@ -0,0 +1,253 @@ +-- GHDL Run Time (GRT) - Error handling. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Stdio; use Grt.Stdio; +with Grt.Astdio; use Grt.Astdio; +with Grt.Options; use Grt.Options; +with Grt.Hooks; use Grt.Hooks; + +package body Grt.Errors is + -- Called in case of premature exit. + -- CODE is 0 for success, 1 for failure. + procedure Ghdl_Exit (Code : Integer); + pragma No_Return (Ghdl_Exit); + + procedure Ghdl_Exit (Code : Integer) + is + procedure C_Exit (Status : Integer); + pragma Import (C, C_Exit, "exit"); + pragma No_Return (C_Exit); + begin + C_Exit (Code); + end Ghdl_Exit; + + procedure Maybe_Return_Via_Longjump (Val : Integer); + pragma Import (C, Maybe_Return_Via_Longjump, + "__ghdl_maybe_return_via_longjump"); + + procedure Exit_Simulation is + begin + Maybe_Return_Via_Longjump (-2); + Internal_Error ("exit_simulation"); + end Exit_Simulation; + + procedure Fatal_Error is + begin + if Error_Hook /= null then + -- Call the hook, but avoid infinite loop by reseting it. + declare + Current_Hook : constant Proc_Hook_Type := Error_Hook; + begin + Error_Hook := null; + Current_Hook.all; + end; + end if; + Maybe_Return_Via_Longjump (-1); + if Expect_Failure then + Ghdl_Exit (0); + else + Ghdl_Exit (1); + end if; + end Fatal_Error; + + procedure Put_Err (Str : String) is + begin + Put (stderr, Str); + end Put_Err; + + procedure Put_Err (Str : Ghdl_C_String) is + begin + Put (stderr, Str); + end Put_Err; + + procedure Put_Err (N : Integer) is + begin + Put_I32 (stderr, Ghdl_I32 (N)); + end Put_Err; + + procedure Newline_Err is + begin + New_Line (stderr); + end Newline_Err; + +-- procedure Put_Err (Str : Ghdl_Str_Len_Type) +-- is +-- S : String (1 .. 3); +-- begin +-- if Str.Str = null then +-- S (1) := '''; +-- S (2) := Character'Val (Str.Len); +-- S (3) := '''; +-- Put_Err (S); +-- else +-- Put_Err (Str.Str (1 .. Str.Len)); +-- end if; +-- end Put_Err; + + procedure Report_H (Str : String := "") is + begin + Put_Err (Str); + end Report_H; + + procedure Report_C (Str : String) is + begin + Put_Err (Str); + end Report_C; + + procedure Report_C (Str : Ghdl_C_String) + is + Len : constant Natural := strlen (Str); + begin + Put_Err (Str (1 .. Len)); + end Report_C; + + procedure Report_C (N : Integer) + renames Put_Err; + + procedure Report_Now_C is + begin + Put_Time (stderr, Grt.Types.Current_Time); + end Report_Now_C; + + procedure Report_E (Str : String) is + begin + Put_Err (Str); + Newline_Err; + end Report_E; + + procedure Report_E (Str : Std_String_Ptr) + is + subtype Ada_Str is String (1 .. Natural (Str.Bounds.Dim_1.Length)); + begin + if Ada_Str'Length > 0 then + Put_Err (Ada_Str (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1))); + end if; + Newline_Err; + end Report_E; + + procedure Error_H is + begin + Put_Err (Progname); + Put_Err (":error: "); + end Error_H; + + Cont : Boolean := False; + + procedure Error_C (Str : String) is + begin + if not Cont then + Error_H; + Cont := True; + end if; + Put_Err (Str); + end Error_C; + + procedure Error_C (Str : Ghdl_C_String) + is + Len : constant Natural := strlen (Str); + begin + if not Cont then + Error_H; + Cont := True; + end if; + Put_Err (Str (1 .. Len)); + end Error_C; + + procedure Error_C (N : Integer) is + begin + if not Cont then + Error_H; + Cont := True; + end if; + Put_Err (N); + end Error_C; + +-- procedure Error_C (Inst : Ghdl_Instance_Name_Acc) +-- is +-- begin +-- if not Cont then +-- Error_H; +-- Cont := True; +-- end if; +-- if Inst.Parent /= null then +-- Error_C (Inst.Parent); +-- Put_Err ("."); +-- end if; +-- case Inst.Kind is +-- when Ghdl_Name_Architecture => +-- Put_Err ("("); +-- Put_Err (Inst.Name.all); +-- Put_Err (")"); +-- when others => +-- if Inst.Name /= null then +-- Put_Err (Inst.Name.all); +-- end if; +-- end case; +-- end Error_C; + + procedure Error_E (Str : String := "") is + begin + Put_Err (Str); + Newline_Err; + Cont := False; + Fatal_Error; + end Error_E; + + procedure Error_C_Std (Str : Std_String_Uncons) + is + subtype Str_Subtype is String (1 .. Str'Length); + begin + Error_C (Str_Subtype (Str)); + end Error_C_Std; + + procedure Error (Str : String) is + begin + Error_H; + Put_Err (Str); + Newline_Err; + Fatal_Error; + end Error; + + procedure Info (Str : String) is + begin + Put_Err (Progname); + Put_Err (":info: "); + Put_Err (Str); + Newline_Err; + end Info; + + procedure Internal_Error (Msg : String) is + begin + Put_Err (Progname); + Put_Err (":internal error: "); + Put_Err (Msg); + Newline_Err; + Fatal_Error; + end Internal_Error; + + procedure Grt_Overflow_Error is + begin + Error ("overflow detected"); + end Grt_Overflow_Error; +end Grt.Errors; diff --git a/src/translate/grt/grt-errors.ads b/src/translate/grt/grt-errors.ads new file mode 100644 index 0000000..c797a71 --- /dev/null +++ b/src/translate/grt/grt-errors.ads @@ -0,0 +1,84 @@ +-- GHDL Run Time (GRT) - Error handling. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Hooks; + +package Grt.Errors is + pragma Preelaborate (Grt.Errors); + + -- Multi-call error procedure. + -- Start and continue with Error_C, finish by an Error_E. + procedure Error_C (Str : String); + procedure Error_C (N : Integer); + procedure Error_C (Str : Ghdl_C_String); + procedure Error_C_Std (Str : Std_String_Uncons); + --procedure Error_C (Inst : Ghdl_Instance_Name_Acc); + procedure Error_E (Str : String := ""); + -- procedure Error_E_Std (Str : Std_String_Uncons); + pragma No_Return (Error_E); + + -- Multi-call report procedure. Do not exit at end. + procedure Report_H (Str : String := ""); + procedure Report_C (Str : Ghdl_C_String); + procedure Report_C (Str : String); + procedure Report_C (N : Integer); + procedure Report_Now_C; + procedure Report_E (Str : String); + procedure Report_E (Str : Std_String_Ptr); + + -- Complete error message. + procedure Error (Str : String); + + -- Internal error. The message must contain the subprogram name which + -- has called this procedure. + procedure Internal_Error (Msg : String); + pragma No_Return (Internal_Error); + + -- Display a message which is not an error. + procedure Info (Str : String); + + -- Display an error message for an overflow. + procedure Grt_Overflow_Error; + + -- Called at end of error message. Central point for failures. + procedure Fatal_Error; + pragma No_Return (Fatal_Error); + pragma Export (C, Fatal_Error, "__ghdl_fatal"); + + Exit_Status : Integer := 0; + procedure Exit_Simulation; + + -- Hook called in case of error. + Error_Hook : Grt.Hooks.Proc_Hook_Type := null; + + -- If true, an error is expected and the exit status is inverted. + Expect_Failure : Boolean := False; + +private + pragma Export (C, Grt_Overflow_Error, "grt_overflow_error"); + + pragma No_Return (Error); +end Grt.Errors; + diff --git a/src/translate/grt/grt-files.adb b/src/translate/grt/grt-files.adb new file mode 100644 index 0000000..30d51cf --- /dev/null +++ b/src/translate/grt/grt-files.adb @@ -0,0 +1,452 @@ +-- GHDL Run Time (GRT) - VHDL files subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Table; +with System; use System; +pragma Elaborate_All (Grt.Table); + +package body Grt.Files is + subtype C_Files is Grt.Stdio.FILEs; + + Auto_Flush : constant Boolean := False; + + type File_Entry_Type is record + Stream : C_Files; + Signature : Ghdl_C_String; + Is_Text : Boolean; + Is_Alive : Boolean; + end record; + + package Files_Table is new Grt.Table + (Table_Component_Type => File_Entry_Type, + Table_Index_Type => Ghdl_File_Index, + Table_Low_Bound => 1, + Table_Initial => 2); + + function Get_File (Index : Ghdl_File_Index) return C_Files + is + begin + if Index not in Files_Table.First .. Files_Table.Last then + Internal_Error ("get_file: bad file index"); + end if; + return Files_Table.Table (Index).Stream; + end Get_File; + + procedure Check_File_Mode (Index : Ghdl_File_Index; Is_Text : Boolean) + is + begin + if Files_Table.Table (Index).Is_Text /= Is_Text then + Internal_Error ("check_file_mode: bad file mode"); + end if; + end Check_File_Mode; + + function Create_File (Is_Text : Boolean; Sig : Ghdl_C_String) + return Ghdl_File_Index is + begin + Files_Table.Append ((Stream => NULL_Stream, + Signature => Sig, + Is_Text => Is_Text, + Is_Alive => True)); + return Files_Table.Last; + end Create_File; + + procedure Destroy_File (Is_Text : Boolean; Index : Ghdl_File_Index) is + begin + if Get_File (Index) /= NULL_Stream then + Internal_Error ("destroy_file"); + end if; + Check_File_Mode (Index, Is_Text); + Files_Table.Table (Index).Is_Alive := False; + if Index = Files_Table.Last then + while Files_Table.Last >= Files_Table.First + and then Files_Table.Table (Files_Table.Last).Is_Alive = False + loop + Files_Table.Decrement_Last; + end loop; + end if; + end Destroy_File; + + procedure File_Error (File : Ghdl_File_Index) + is + pragma Unreferenced (File); + begin + Internal_Error ("file: IO error"); + end File_Error; + + function Ghdl_Text_File_Elaborate return Ghdl_File_Index is + begin + return Create_File (True, null); + end Ghdl_Text_File_Elaborate; + + function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index + is + begin + return Create_File (False, Sig); + end Ghdl_File_Elaborate; + + procedure Ghdl_Text_File_Finalize (File : Ghdl_File_Index) is + begin + Destroy_File (True, File); + end Ghdl_Text_File_Finalize; + + procedure Ghdl_File_Finalize (File : Ghdl_File_Index) is + begin + Destroy_File (False, File); + end Ghdl_File_Finalize; + + function Ghdl_File_Endfile (File : Ghdl_File_Index) return Boolean + is + Stream : C_Files; + C : int; + begin + Stream := Get_File (File); + if feof (Stream) /= 0 then + return True; + end if; + C := fgetc (Stream); + if C < 0 then + return True; + end if; + if ungetc (C, Stream) /= C then + Error ("internal error: ungetc"); + end if; + return False; + end Ghdl_File_Endfile; + + Sig_Header : constant String := "#GHDL-BINARY-FILE-0.0" & Nl; + + function File_Open (File : Ghdl_File_Index; + Mode : Ghdl_I32; + Str : Std_String_Ptr) + return Ghdl_I32 + is + Name : String (1 .. Integer (Str.Bounds.Dim_1.Length) + 1); + Str_Mode : String (1 .. 3); + F : C_Files; + Sig : Ghdl_C_String; + Sig_Len : Natural; + begin + F := Get_File (File); + + if F /= NULL_Stream then + -- File was already open. + return Status_Error; + end if; + + -- Copy file name and convert it to a C string (NUL terminated). + for I in 1 .. Str.Bounds.Dim_1.Length loop + Name (Natural (I)) := Str.Base (I - 1); + end loop; + Name (Name'Last) := NUL; + + if Name = "STD_INPUT" & NUL then + if Mode /= Read_Mode then + return Mode_Error; + end if; + F := stdin; + elsif Name = "STD_OUTPUT" & NUL then + if Mode /= Write_Mode then + return Mode_Error; + end if; + F := stdout; + else + case Mode is + when Read_Mode => + Str_Mode (1) := 'r'; + when Write_Mode => + Str_Mode (1) := 'w'; + when Append_Mode => + Str_Mode (1) := 'a'; + when others => + -- Bad mode, cannot happen. + Internal_Error ("file_open: bad open mode"); + end case; + if Files_Table.Table (File).Is_Text then + Str_Mode (2) := NUL; + else + Str_Mode (2) := 'b'; + Str_Mode (3) := NUL; + end if; + F := fopen (Name'Address, Str_Mode'Address); + if F = NULL_Stream then + return Name_Error; + end if; + end if; + Sig := Files_Table.Table (File).Signature; + if Sig /= null then + Sig_Len := strlen (Sig); + case Mode is + when Write_Mode => + if fwrite (Sig_Header'Address, 1, Sig_Header'Length, F) + /= Sig_Header'Length + then + File_Error (File); + end if; + if fwrite (Sig (1)'Address, 1, size_t (Sig_Len), F) + /= size_t (Sig_Len) + then + File_Error (File); + end if; + when Read_Mode => + declare + Hdr : String (1 .. Sig_Header'Length); + Sig_Buf : String (1 .. Sig_Len); + begin + if fread (Hdr'Address, 1, Hdr'Length, F) /= Hdr'Length then + File_Error (File); + end if; + if Hdr /= Sig_Header then + File_Error (File); + end if; + if fread (Sig_Buf'Address, 1, Sig_Buf'Length, F) + /= Sig_Buf'Length + then + File_Error (File); + end if; + if Sig_Buf /= Sig (1 .. Sig_Len) then + File_Error (File); + end if; + end; + when Append_Mode => + null; + when others => + null; + end case; + end if; + Files_Table.Table (File).Stream := F; + return Open_Ok; + end File_Open; + + procedure Ghdl_Text_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + is + Res : Ghdl_I32; + begin + Check_File_Mode (File, True); + + Res := File_Open (File, Mode, Str); + + if Res /= Open_Ok then + Error_C ("open: cannot open text file "); + Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1)); + Error_E; + end if; + end Ghdl_Text_File_Open; + + procedure Ghdl_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + is + Res : Ghdl_I32; + begin + Check_File_Mode (File, False); + + Res := File_Open (File, Mode, Str); + + if Res /= Open_Ok then + Error_C ("open: cannot open file "); + Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1)); + Error_E; + end if; + end Ghdl_File_Open; + + function Ghdl_Text_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32 + is + begin + Check_File_Mode (File, True); + return File_Open (File, Mode, Str); + end Ghdl_Text_File_Open_Status; + + function Ghdl_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32 + is + begin + Check_File_Mode (File, False); + return File_Open (File, Mode, Str); + end Ghdl_File_Open_Status; + + procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr) + is + Res : C_Files; + R : size_t; + R1 : int; + pragma Unreferenced (R, R1); + begin + Res := Get_File (File); + Check_File_Mode (File, True); + if Res = NULL_Stream then + Error ("write to a non-opened file"); + end if; + -- FIXME: check mode. + R := fwrite (Str.Base (0)'Address, + size_t (Str.Bounds.Dim_1.Length), 1, Res); + -- FIXME: check r + -- Write '\n'. + R1 := fputc (Character'Pos (Nl), Res); + if Auto_Flush then + fflush (Res); + end if; + end Ghdl_Text_Write; + + procedure Ghdl_Write_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type) + is + Res : C_Files; + R : size_t; + begin + Res := Get_File (File); + Check_File_Mode (File, False); + if Res = NULL_Stream then + Error ("write to a non-opened file"); + end if; + -- FIXME: check mode. + R := fwrite (System.Address (Ptr), size_t (Length), 1, Res); + if R /= 1 then + Error ("write_scalar failed"); + end if; + if Auto_Flush then + fflush (Res); + end if; + end Ghdl_Write_Scalar; + + procedure Ghdl_Read_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type) + is + Res : C_Files; + R : size_t; + begin + Res := Get_File (File); + Check_File_Mode (File, False); + if Res = NULL_Stream then + Error ("write to a non-opened file"); + end if; + -- FIXME: check mode. + R := fread (System.Address (Ptr), size_t (Length), 1, Res); + if R /= 1 then + Error ("read_scalar failed"); + end if; + end Ghdl_Read_Scalar; + + function Ghdl_Text_Read_Length (File : Ghdl_File_Index; + Str : Std_String_Ptr) + return Std_Integer + is + Stream : C_Files; + C : int; + Len : Ghdl_Index_Type; + begin + Stream := Get_File (File); + Check_File_Mode (File, True); + Len := Str.Bounds.Dim_1.Length; + -- Read until EOL (or EOF). + -- Store as much as possible. + for I in Ghdl_Index_Type loop + C := fgetc (Stream); + if C < 0 then + Error ("read: end of file reached"); + return Std_Integer (I); + end if; + if I < Len then + Str.Base (I) := Character'Val (C); + end if; + -- End of line is '\n' or LF or character # 10. + if C = 10 then + return Std_Integer (I + 1); + end if; + end loop; + return 0; + end Ghdl_Text_Read_Length; + + procedure Ghdl_Untruncated_Text_Read + (Res : Ghdl_Untruncated_Text_Read_Result_Acc; + File : Ghdl_File_Index; + Str : Std_String_Ptr) + is + Stream : C_Files; + Len : int; + Idx : Ghdl_Index_Type; + begin + Stream := Get_File (File); + Check_File_Mode (File, True); + Len := int (Str.Bounds.Dim_1.Length); + if fgets (Str.Base (0)'Address, Len, Stream) = Null_Address then + Internal_Error ("ghdl_untruncated_text_read: end of file"); + end if; + -- Compute the length. + for I in Ghdl_Index_Type loop + if Str.Base (I) = NUL then + Idx := I; + exit; + end if; + end loop; + Res.Len := Std_Integer (Idx); + end Ghdl_Untruncated_Text_Read; + + procedure File_Close (File : Ghdl_File_Index; Is_Text : Boolean) + is + Stream : C_Files; + begin + Stream := Get_File (File); + Check_File_Mode (File, Is_Text); + -- LRM 3.4.1 File Operations + -- If F is not associated with an external file, then FILE_CLOSE has + -- no effect. + if Stream = NULL_Stream then + return; + end if; + if fclose (Stream) /= 0 then + Internal_Error ("file_close: fclose error"); + end if; + Files_Table.Table (File).Stream := NULL_Stream; + end File_Close; + + procedure Ghdl_Text_File_Close (File : Ghdl_File_Index) is + begin + File_Close (File, True); + end Ghdl_Text_File_Close; + + procedure Ghdl_File_Close (File : Ghdl_File_Index) is + begin + File_Close (File, False); + end Ghdl_File_Close; + + procedure Ghdl_File_Flush (File : Ghdl_File_Index) + is + Stream : C_Files; + begin + Stream := Get_File (File); + if Stream = NULL_Stream then + return; + end if; + fflush (Stream); + end Ghdl_File_Flush; +end Grt.Files; + diff --git a/src/translate/grt/grt-files.ads b/src/translate/grt/grt-files.ads new file mode 100644 index 0000000..14f9984 --- /dev/null +++ b/src/translate/grt/grt-files.ads @@ -0,0 +1,123 @@ +-- GHDL Run Time (GRT) - VHDL files subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Interfaces; + +package Grt.Files is + type Ghdl_File_Index is new Interfaces.Integer_32; + + -- File open mode. + Read_Mode : constant Ghdl_I32 := 0; + Write_Mode : constant Ghdl_I32 := 1; + Append_Mode : constant Ghdl_I32 := 2; + + -- file_open_status. + Open_Ok : constant Ghdl_I32 := 0; + Status_Error : constant Ghdl_I32 := 1; + Name_Error : constant Ghdl_I32 := 2; + Mode_Error : constant Ghdl_I32 := 3; + + -- General files. + function Ghdl_File_Endfile (File : Ghdl_File_Index) return Boolean; + + -- Elaboration. + function Ghdl_Text_File_Elaborate return Ghdl_File_Index; + function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index; + + -- Finalization. + procedure Ghdl_Text_File_Finalize (File : Ghdl_File_Index); + procedure Ghdl_File_Finalize (File : Ghdl_File_Index); + + -- Subprograms. + procedure Ghdl_Text_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr); + function Ghdl_Text_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32; + + procedure Ghdl_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr); + function Ghdl_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32; + + procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr); + procedure Ghdl_Write_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type); + + procedure Ghdl_Read_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type); + + function Ghdl_Text_Read_Length + (File : Ghdl_File_Index; Str : Std_String_Ptr) return Std_Integer; + + type Ghdl_Untruncated_Text_Read_Result is record + Len : Std_Integer; + end record; + + type Ghdl_Untruncated_Text_Read_Result_Acc is + access Ghdl_Untruncated_Text_Read_Result; + + procedure Ghdl_Untruncated_Text_Read + (Res : Ghdl_Untruncated_Text_Read_Result_Acc; + File : Ghdl_File_Index; + Str : Std_String_Ptr); + + procedure Ghdl_Text_File_Close (File : Ghdl_File_Index); + procedure Ghdl_File_Close (File : Ghdl_File_Index); + + procedure Ghdl_File_Flush (File : Ghdl_File_Index); +private + pragma Export (Ada, Ghdl_File_Endfile, "__ghdl_file_endfile"); + + pragma Export (C, Ghdl_Text_File_Elaborate, "__ghdl_text_file_elaborate"); + pragma Export (C, Ghdl_File_Elaborate, "__ghdl_file_elaborate"); + + pragma Export (C, Ghdl_Text_File_Finalize, "__ghdl_text_file_finalize"); + pragma Export (C, Ghdl_File_Finalize, "__ghdl_file_finalize"); + + pragma Export (C, Ghdl_Text_File_Open, "__ghdl_text_file_open"); + pragma Export (C, Ghdl_Text_File_Open_Status, + "__ghdl_text_file_open_status"); + + pragma Export (C, Ghdl_File_Open, "__ghdl_file_open"); + pragma Export (C, Ghdl_File_Open_Status, "__ghdl_file_open_status"); + + pragma Export (C, Ghdl_Text_Write, "__ghdl_text_write"); + pragma Export (C, Ghdl_Write_Scalar, "__ghdl_write_scalar"); + + pragma Export (C, Ghdl_Read_Scalar, "__ghdl_read_scalar"); + + pragma Export (C, Ghdl_Text_Read_Length, "__ghdl_text_read_length"); + pragma Export (C, Ghdl_Untruncated_Text_Read, + "std__textio__untruncated_text_read"); + + pragma Export (C, Ghdl_Text_File_Close, "__ghdl_text_file_close"); + pragma Export (C, Ghdl_File_Close, "__ghdl_file_close"); + + pragma Export (C, Ghdl_File_Flush, "__ghdl_file_flush"); +end Grt.Files; diff --git a/src/translate/grt/grt-hooks.adb b/src/translate/grt/grt-hooks.adb new file mode 100644 index 0000000..6a77aaf --- /dev/null +++ b/src/translate/grt/grt-hooks.adb @@ -0,0 +1,161 @@ +-- GHDL Run Time (GRT) - Hooks. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package body Grt.Hooks is + type Hooks_Cell; + type Hooks_Cell_Acc is access Hooks_Cell; + type Hooks_Cell is record + Hooks : Hooks_Acc; + Next : Hooks_Cell_Acc; + end record; + + First_Hooks : Hooks_Cell_Acc := null; + Last_Hooks : Hooks_Cell_Acc := null; + + procedure Register_Hooks (Hooks : Hooks_Acc) + is + Cell : Hooks_Cell_Acc; + begin + Cell := new Hooks_Cell'(Hooks => Hooks, + Next => null); + if Last_Hooks = null then + First_Hooks := Cell; + else + Last_Hooks.Next := Cell; + end if; + Last_Hooks := Cell; + end Register_Hooks; + + type Hook_Cell; + type Hook_Cell_Acc is access Hook_Cell; + type Hook_Cell is record + Hook : Proc_Hook_Type; + Next : Hook_Cell_Acc; + end record; + + -- Chain of cycle hooks. + Cycle_Hook : Hook_Cell_Acc := null; + Last_Cycle_Hook : Hook_Cell_Acc := null; + + procedure Register_Cycle_Hook (Proc : Proc_Hook_Type) + is + Cell : Hook_Cell_Acc; + begin + Cell := new Hook_Cell'(Hook => Proc, + Next => null); + if Cycle_Hook = null then + Cycle_Hook := Cell; + else + Last_Cycle_Hook.Next := Cell; + end if; + Last_Cycle_Hook := Cell; + end Register_Cycle_Hook; + + procedure Call_Cycle_Hooks + is + Cell : Hook_Cell_Acc; + begin + Cell := Cycle_Hook; + while Cell /= null loop + Cell.Hook.all; + Cell := Cell.Next; + end loop; + end Call_Cycle_Hooks; + + function Call_Option_Hooks (Opt : String) return Boolean + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Option /= null + and then Cell.Hooks.Option.all (Opt) + then + return True; + end if; + Cell := Cell.Next; + end loop; + return False; + end Call_Option_Hooks; + + procedure Call_Help_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Help /= null then + Cell.Hooks.Help.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Help_Hooks; + + procedure Call_Init_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Init /= null then + Cell.Hooks.Init.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Init_Hooks; + + procedure Call_Start_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Start /= null then + Cell.Hooks.Start.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Start_Hooks; + + procedure Call_Finish_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Finish /= null then + Cell.Hooks.Finish.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Finish_Hooks; + + procedure Proc_Hook_Nil is + begin + null; + end Proc_Hook_Nil; +end Grt.Hooks; + + diff --git a/src/translate/grt/grt-hooks.ads b/src/translate/grt/grt-hooks.ads new file mode 100644 index 0000000..20846c7 --- /dev/null +++ b/src/translate/grt/grt-hooks.ads @@ -0,0 +1,70 @@ +-- GHDL Run Time (GRT) - Hooks. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +package Grt.Hooks is + pragma Preelaborate (Grt.Hooks); + + type Option_Hook_Type is access function (Opt : String) return Boolean; + type Proc_Hook_Type is access procedure; + + type Hooks_Type is record + -- Called for every unknown command line argument. + -- Return TRUE if handled. + Option : Option_Hook_Type; + + -- Display command line help. + Help : Proc_Hook_Type; + + -- Called at initialization (after decoding options). + Init : Proc_Hook_Type; + + -- Called just after elaboration. + Start : Proc_Hook_Type; + + -- Called at the end of execution. + Finish : Proc_Hook_Type; + end record; + + type Hooks_Acc is access constant Hooks_Type; + + -- Registers hook. + procedure Register_Hooks (Hooks : Hooks_Acc); + + -- Register an hook which will call PROC after every non-delta cycles. + procedure Register_Cycle_Hook (Proc : Proc_Hook_Type); + + -- Call hooks. + function Call_Option_Hooks (Opt : String) return Boolean; + procedure Call_Help_Hooks; + procedure Call_Init_Hooks; + procedure Call_Start_Hooks; + procedure Call_Finish_Hooks; + + -- Call non-delta cycles hooks. + procedure Call_Cycle_Hooks; + pragma Inline_Always (Call_Cycle_Hooks); + + -- Nil procedure. + procedure Proc_Hook_Nil; +end Grt.Hooks; diff --git a/src/translate/grt/grt-images.adb b/src/translate/grt/grt-images.adb new file mode 100644 index 0000000..342c98f --- /dev/null +++ b/src/translate/grt/grt-images.adb @@ -0,0 +1,387 @@ +-- GHDL Run Time (GRT) - 'image subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Ada.Unchecked_Conversion; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; +with Grt.Processes; use Grt.Processes; +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Errors; use Grt.Errors; + +package body Grt.Images is + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Basep); + + function To_Std_String_Boundp is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Boundp); + + procedure Set_String_Bounds (Res : Std_String_Ptr; Len : Ghdl_Index_Type) + is + begin + Res.Bounds := To_Std_String_Boundp + (Ghdl_Stack2_Allocate (Std_String_Bound'Size / System.Storage_Unit)); + Res.Bounds.Dim_1 := (Left => 1, + Right => Std_Integer (Len), + Dir => Dir_To, + Length => Len); + end Set_String_Bounds; + + procedure Return_String (Res : Std_String_Ptr; Str : String) + is + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Str'Length)); + for I in 0 .. Str'Length - 1 loop + Res.Base (Ghdl_Index_Type (I)) := Str (Str'First + I); + end loop; + Set_String_Bounds (Res, Str'Length); + end Return_String; + + procedure Return_Enum + (Res : Std_String_Ptr; Rti : Ghdl_Rti_Access; Index : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + Str : Ghdl_C_String; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str := Enum_Rti.Names (Index); + Return_String (Res, Str (1 .. strlen (Str))); + end Return_Enum; + + procedure Ghdl_Image_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access) + is + begin + Return_Enum (Res, Rti, Ghdl_B1'Pos (Val)); + end Ghdl_Image_B1; + + procedure Ghdl_Image_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access) + is + begin + Return_Enum (Res, Rti, Ghdl_E8'Pos (Val)); + end Ghdl_Image_E8; + + procedure Ghdl_Image_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access) + is + begin + Return_Enum (Res, Rti, Ghdl_E32'Pos (Val)); + end Ghdl_Image_E32; + + procedure Ghdl_Image_I32 (Res : Std_String_Ptr; Val : Ghdl_I32) + is + Str : String (1 .. 11); + First : Natural; + begin + To_String (Str, First, Val); + Return_String (Res, Str (First .. Str'Last)); + end Ghdl_Image_I32; + + procedure Ghdl_Image_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access) + is + Str : String (1 .. 21); + First : Natural; + Phys : constant Ghdl_Rtin_Type_Physical_Acc + := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Unit_Len : Natural; + begin + To_String (Str, First, Val); + Unit_Name := Get_Physical_Unit_Name (Phys.Units (0)); + Unit_Len := strlen (Unit_Name); + declare + L : constant Natural := Str'Last + 1 - First; + Str2 : String (1 .. L + 1 + Unit_Len); + begin + Str2 (1 .. L) := Str (First .. Str'Last); + Str2 (L + 1) := ' '; + Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len); + Return_String (Res, Str2); + end; + end Ghdl_Image_P64; + + procedure Ghdl_Image_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access) + is + Str : String (1 .. 11); + First : Natural; + Phys : constant Ghdl_Rtin_Type_Physical_Acc + := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Unit_Len : Natural; + begin + To_String (Str, First, Val); + Unit_Name := Get_Physical_Unit_Name (Phys.Units (0)); + Unit_Len := strlen (Unit_Name); + declare + L : constant Natural := Str'Last + 1 - First; + Str2 : String (1 .. L + 1 + Unit_Len); + begin + Str2 (1 .. L) := Str (First .. Str'Last); + Str2 (L + 1) := ' '; + Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len); + Return_String (Res, Str2); + end; + end Ghdl_Image_P32; + + procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) + is + Str : String (1 .. 24); + P : Natural; + begin + To_String (Str, P, Val); + Return_String (Res, Str (1 .. P)); + end Ghdl_Image_F64; + + procedure Ghdl_To_String_I32 (Res : Std_String_Ptr; Val : Ghdl_I32) + renames Ghdl_Image_I32; + procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) + renames Ghdl_Image_F64; + + procedure Ghdl_To_String_F64_Digits + (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32) + is + Str : String_Real_Digits; + P : Natural; + begin + To_String (Str, P, Val, Nbr_Digits); + Return_String (Res, Str (1 .. P)); + end Ghdl_To_String_F64_Digits; + + procedure Ghdl_To_String_F64_Format + (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr) + is + C_Format : String (1 .. Positive (Format.Bounds.Dim_1.Length + 1)); + Str : Grt.Vstrings.String_Real_Format; + P : Natural; + begin + for I in 1 .. C_Format'Last - 1 loop + C_Format (I) := Format.Base (Ghdl_Index_Type (I - 1)); + end loop; + C_Format (C_Format'Last) := NUL; + + To_String (Str, P, Val, To_Ghdl_C_String (C_Format'Address)); + Return_String (Res, Str (1 .. P)); + end Ghdl_To_String_F64_Format; + + subtype Log_Base_Type is Ghdl_Index_Type range 3 .. 4; + Hex_Chars : constant array (Natural range 0 .. 15) of Character := + "0123456789ABCDEF"; + + procedure Ghdl_BV_To_String (Res : Std_String_Ptr; + Val : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type; + Log_Base : Log_Base_Type) + is + Res_Len : constant Ghdl_Index_Type := (Len + Log_Base - 1) / Log_Base; + Pos : Ghdl_Index_Type; + V : Natural; + Sh : Natural range 0 .. 4; + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Res_Len)); + V := 0; + Sh := 0; + Pos := Res_Len - 1; + for I in reverse 1 .. Len loop + V := V + Std_Bit'Pos (Val (I - 1)) * (2 ** Sh); + Sh := Sh + 1; + if Sh = Natural (Log_Base) or else I = 1 then + Res.Base (Pos) := Hex_Chars (V); + Pos := Pos - 1; + Sh := 0; + V := 0; + end if; + end loop; + Set_String_Bounds (Res, Res_Len); + end Ghdl_BV_To_String; + + procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type) is + begin + Ghdl_BV_To_String (Res, Base, Len, 3); + end Ghdl_BV_To_Ostring; + + procedure Ghdl_BV_To_Hstring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type) is + begin + Ghdl_BV_To_String (Res, Base, Len, 4); + end Ghdl_BV_To_Hstring; + + procedure To_String_Enum + (Res : Std_String_Ptr; Rti : Ghdl_Rti_Access; Index : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + Str : Ghdl_C_String; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str := Enum_Rti.Names (Index); + if Str (1) = ''' then + Return_String (Res, Str (2 .. 2)); + else + Return_String (Res, Str (1 .. strlen (Str))); + end if; + end To_String_Enum; + + procedure Ghdl_To_String_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_B1'Pos (Val)); + end Ghdl_To_String_B1; + + procedure Ghdl_To_String_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_E8'Pos (Val)); + end Ghdl_To_String_E8; + + procedure Ghdl_To_String_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_E32'Pos (Val)); + end Ghdl_To_String_E32; + + procedure Ghdl_To_String_Char (Res : Std_String_Ptr; Val : Std_Character) is + begin + Return_String (Res, (1 => Val)); + end Ghdl_To_String_Char; + + procedure Ghdl_To_String_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access) + renames Ghdl_Image_P32; + + procedure Ghdl_To_String_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access) + renames Ghdl_Image_P64; + + procedure Ghdl_Time_To_String_Unit + (Res : Std_String_Ptr; + Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access) + is + Str : Grt.Vstrings.String_Time_Unit; + First : Natural; + Phys : constant Ghdl_Rtin_Type_Physical_Acc + := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Unit_Len : Natural; + begin + Unit_Name := null; + for I in 1 .. Phys.Nbr loop + if Get_Physical_Unit_Value (Phys.Units (I - 1), Rti) = Ghdl_I64 (Unit) + then + Unit_Name := Get_Physical_Unit_Name (Phys.Units (I - 1)); + exit; + end if; + end loop; + if Unit_Name = null then + Error ("no unit for to_string"); + end if; + Grt.Vstrings.To_String (Str, First, Ghdl_I64 (Val), Ghdl_I64 (Unit)); + Unit_Len := strlen (Unit_Name); + declare + L : constant Natural := Str'Last + 1 - First; + Str2 : String (1 .. L + 1 + Unit_Len); + begin + Str2 (1 .. L) := Str (First .. Str'Last); + Str2 (L + 1) := ' '; + Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len); + Return_String (Res, Str2); + end; + end Ghdl_Time_To_String_Unit; + + procedure Ghdl_Array_Char_To_String_B1 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_B1_Array_Base_Ptr := To_Ghdl_B1_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_B1'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_B1; + + procedure Ghdl_Array_Char_To_String_E8 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_E8_Array_Base_Ptr := To_Ghdl_E8_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_E8'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_E8; + + procedure Ghdl_Array_Char_To_String_E32 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_E32_Array_Base_Ptr := + To_Ghdl_E32_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_E32'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_E32; + +-- procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) +-- is +-- -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1) +-- -- + exp_digits (4) -> 24. +-- Str : String (1 .. 25); + +-- procedure Snprintf_G (Str : System.Address; +-- Size : Integer; +-- Arg : Ghdl_F64); +-- pragma Import (C, Snprintf_G, "__ghdl_snprintf_g"); + +-- function strlen (Str : System.Address) return Integer; +-- pragma Import (C, strlen); +-- begin +-- Snprintf_G (Str'Address, Str'Length, Val); +-- Return_String (Res, Str (1 .. strlen (Str'Address))); +-- end Ghdl_Image_F64; + +end Grt.Images; diff --git a/src/translate/grt/grt-images.ads b/src/translate/grt/grt-images.ads new file mode 100644 index 0000000..cd89110 --- /dev/null +++ b/src/translate/grt/grt-images.ads @@ -0,0 +1,110 @@ +-- GHDL Run Time (GRT) - 'image subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Images is + -- For all images procedures, the result is allocated on the secondary + -- stack. + + procedure Ghdl_Image_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_I32 (Res : Std_String_Ptr; Val : Ghdl_I32); + procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64); + procedure Ghdl_Image_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access); + + procedure Ghdl_To_String_I32 (Res : Std_String_Ptr; Val : Ghdl_I32); + procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64); + procedure Ghdl_To_String_F64_Digits + (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32); + procedure Ghdl_To_String_F64_Format + (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr); + procedure Ghdl_To_String_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_Char + (Res : Std_String_Ptr; Val : Std_Character); + procedure Ghdl_To_String_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access); + procedure Ghdl_Time_To_String_Unit + (Res : Std_String_Ptr; + Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_B1 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_E8 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_E32 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + + procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type); + procedure Ghdl_BV_To_Hstring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type); +private + pragma Export (Ada, Ghdl_Image_B1, "__ghdl_image_b1"); + pragma Export (C, Ghdl_Image_E8, "__ghdl_image_e8"); + pragma Export (C, Ghdl_Image_E32, "__ghdl_image_e32"); + pragma Export (C, Ghdl_Image_I32, "__ghdl_image_i32"); + pragma Export (C, Ghdl_Image_F64, "__ghdl_image_f64"); + pragma Export (C, Ghdl_Image_P64, "__ghdl_image_p64"); + pragma Export (C, Ghdl_Image_P32, "__ghdl_image_p32"); + + pragma Export (C, Ghdl_To_String_I32, "__ghdl_to_string_i32"); + pragma Export (C, Ghdl_To_String_F64, "__ghdl_to_string_f64"); + pragma Export (C, Ghdl_To_String_F64_Digits, "__ghdl_to_string_f64_digits"); + pragma Export (C, Ghdl_To_String_F64_Format, "__ghdl_to_string_f64_format"); + pragma Export (Ada, Ghdl_To_String_B1, "__ghdl_to_string_b1"); + pragma Export (C, Ghdl_To_String_E8, "__ghdl_to_string_e8"); + pragma Export (C, Ghdl_To_String_E32, "__ghdl_to_string_e32"); + pragma Export (C, Ghdl_To_String_Char, "__ghdl_to_string_char"); + pragma Export (C, Ghdl_To_String_P32, "__ghdl_to_string_p32"); + pragma Export (C, Ghdl_To_String_P64, "__ghdl_to_string_p64"); + pragma Export (C, Ghdl_Time_To_String_Unit, "__ghdl_time_to_string_unit"); + pragma Export (C, Ghdl_Array_Char_To_String_B1, + "__ghdl_array_char_to_string_b1"); + pragma Export (C, Ghdl_Array_Char_To_String_E8, + "__ghdl_array_char_to_string_e8"); + pragma Export (C, Ghdl_Array_Char_To_String_E32, + "__ghdl_array_char_to_string_e32"); + pragma Export (C, Ghdl_BV_To_Ostring, "__ghdl_bv_to_ostring"); + pragma Export (C, Ghdl_BV_To_Hstring, "__ghdl_bv_to_hstring"); +end Grt.Images; diff --git a/src/translate/grt/grt-lib.adb b/src/translate/grt/grt-lib.adb new file mode 100644 index 0000000..d2b095c --- /dev/null +++ b/src/translate/grt/grt-lib.adb @@ -0,0 +1,298 @@ +-- GHDL Run Time (GRT) - misc subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; +with Grt.Options; + +package body Grt.Lib is + --procedure Memcpy (Dst : Address; Src : Address; Size : Size_T); + --pragma Import (C, Memcpy); + + procedure Ghdl_Memcpy + (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type) + is + procedure Memmove + (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type); + pragma Import (C, Memmove); + begin + Memmove (Dest, Src, Size); + end Ghdl_Memcpy; + + procedure Do_Report (Msg : String; + Str : Std_String_Ptr; + Default_Str : String; + Severity : Integer; + Loc : Ghdl_Location_Ptr) + is + Level : constant Integer := Severity mod 256; + begin + Report_H; + Report_C (Loc.Filename); + Report_C (":"); + Report_C (Loc.Line); + Report_C (":"); + Report_C (Loc.Col); + Report_C (":@"); + Report_Now_C; + Report_C (":("); + Report_C (Msg); + Report_C (" "); + case Level is + when Note_Severity => + Report_C ("note"); + when Warning_Severity => + Report_C ("warning"); + when Error_Severity => + Report_C ("error"); + when Failure_Severity => + Report_C ("failure"); + when others => + Report_C ("???"); + end case; + Report_C ("): "); + if Str /= null then + Report_E (Str); + else + Report_E (Default_Str); + end if; + if Level >= Grt.Options.Severity_Level then + Error_C (Msg); + Error_E (" failed"); + end if; + end Do_Report; + + procedure Ghdl_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) + is + begin + Do_Report ("assertion", Str, "Assertion violation", Severity, Loc); + end Ghdl_Assert_Failed; + + procedure Ghdl_Ieee_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) + is + use Grt.Options; + begin + if Ieee_Asserts = Disable_Asserts + or else (Ieee_Asserts = Disable_Asserts_At_Time_0 and Current_Time = 0) + then + return; + else + Do_Report ("assertion", Str, "Assertion violation", Severity, Loc); + end if; + end Ghdl_Ieee_Assert_Failed; + + procedure Ghdl_Psl_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is + begin + Do_Report ("psl assertion", Str, "Assertion violation", Severity, Loc); + end Ghdl_Psl_Assert_Failed; + + procedure Ghdl_Psl_Cover + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is + begin + Do_Report ("psl cover", Str, "sequence covered", Severity, Loc); + end Ghdl_Psl_Cover; + + procedure Ghdl_Psl_Cover_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is + begin + Do_Report ("psl cover failure", + Str, "sequence not covered", Severity, Loc); + end Ghdl_Psl_Cover_Failed; + + procedure Ghdl_Report + (Str : Std_String_Ptr; + Severity : Integer; + Loc : Ghdl_Location_Ptr) + is + begin + Do_Report ("report", Str, "Assertion violation", Severity, Loc); + end Ghdl_Report; + + procedure Ghdl_Program_Error (Filename : Ghdl_C_String; + Line : Ghdl_I32; + Code : Ghdl_Index_Type) + is + begin + case Code is + when 1 => + Error_C ("missing return in function"); + when 2 => + Error_C ("block already configured"); + when 3 => + Error_C ("bad configuration"); + when others => + Error_C ("unknown error code "); + Error_C (Integer (Code)); + end case; + Error_C (" at "); + if Filename = null then + Error_C ("*unknown*"); + else + Error_C (Filename); + end if; + Error_C (":"); + Error_C (Integer(Line)); + Error_E (""); + end Ghdl_Program_Error; + + procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String; + Line: Ghdl_I32) + is + begin + Error_C ("bound check failure at "); + Error_C (Filename); + Error_C (":"); + Error_C (Integer (Line)); + Error_E (""); + end Ghdl_Bound_Check_Failed_L1; + + function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32) + return Ghdl_I32 + is + pragma Suppress (Overflow_Check); + + R : Ghdl_I32; + Res : Ghdl_I32; + P : Ghdl_I32; + T : Ghdl_I64; + begin + if E < 0 then + Error ("negative exponent"); + end if; + Res := 1; + P := V; + R := E; + loop + if R mod 2 = 1 then + T := Ghdl_I64 (Res) * Ghdl_I64 (P); + Res := Ghdl_I32 (T); + if Ghdl_I64 (Res) /= T then + Error ("overflow in exponentiation"); + end if; + end if; + R := R / 2; + exit when R = 0; + P := P * P; + end loop; + return Res; + end Ghdl_Integer_Exp; + + function C_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr; + pragma Import (C, C_Malloc, "malloc"); + + function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr is + begin + return C_Malloc (Size); + end Ghdl_Malloc; + + function Ghdl_Malloc0 (Size : Ghdl_Index_Type) return Ghdl_Ptr + is + procedure Memset (Ptr : Ghdl_Ptr; C : Integer; Size : Ghdl_Index_Type); + pragma Import (C, Memset); + + Res : Ghdl_Ptr; + begin + Res := C_Malloc (Size); + Memset (Res, 0, Size); + return Res; + end Ghdl_Malloc0; + + procedure Ghdl_Deallocate (Ptr : Ghdl_Ptr) + is + procedure C_Free (Ptr : Ghdl_Ptr); + pragma Import (C, C_Free, "free"); + begin + C_Free (Ptr); + end Ghdl_Deallocate; + + function Ghdl_Real_Exp (X : Ghdl_Real; Exp : Ghdl_I32) + return Ghdl_Real + is + R : Ghdl_I32; + Res : Ghdl_Real; + P : Ghdl_Real; + begin + Res := 1.0; + P := X; + R := Exp; + if R >= 0 then + loop + if R mod 2 = 1 then + Res := Res * P; + end if; + R := R / 2; + exit when R = 0; + P := P * P; + end loop; + return Res; + else + R := -R; + loop + if R mod 2 = 1 then + Res := Res * P; + end if; + R := R / 2; + exit when R = 0; + P := P * P; + end loop; + if Res = 0.0 then + Error ("division per 0.0"); + return 0.0; + end if; + return 1.0 / Res; + end if; + end Ghdl_Real_Exp; + + function Ghdl_Get_Resolution_Limit return Std_Time is + begin + return 1; + end Ghdl_Get_Resolution_Limit; + + procedure Ghdl_Control_Simulation + (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer) is + begin + Report_H; + -- Report_C (Grt.Options.Progname); + Report_C ("simulation "); + if Stop then + Report_C ("stopped"); + else + Report_C ("finished"); + end if; + Report_C (" @"); + Report_Now_C; + if Has_Status then + Report_C (" with status "); + Report_C (Integer (Status)); + end if; + Report_E (""); + if Has_Status then + Exit_Status := Integer (Status); + end if; + Exit_Simulation; + end Ghdl_Control_Simulation; + +end Grt.Lib; diff --git a/src/translate/grt/grt-lib.ads b/src/translate/grt/grt-lib.ads new file mode 100644 index 0000000..4dac2c8 --- /dev/null +++ b/src/translate/grt/grt-lib.ads @@ -0,0 +1,127 @@ +-- GHDL Run Time (GRT) - misc subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Lib is + pragma Preelaborate (Grt.Lib); + + procedure Ghdl_Memcpy + (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type); + + procedure Ghdl_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + procedure Ghdl_Ieee_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + procedure Ghdl_Psl_Assert_Failed + (Str : Std_String_Ptr; + Severity : Integer; + Loc : Ghdl_Location_Ptr); + + -- Called when a sequence is covered (in a cover directive) + procedure Ghdl_Psl_Cover + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + procedure Ghdl_Psl_Cover_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + procedure Ghdl_Report + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + Note_Severity : constant Integer := 0; + Warning_Severity : constant Integer := 1; + Error_Severity : constant Integer := 2; + Failure_Severity : constant Integer := 3; + + procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String; + Line: Ghdl_I32); + + -- Program error has occured: + -- * configuration of an already configured block. + procedure Ghdl_Program_Error (Filename : Ghdl_C_String; + Line : Ghdl_I32; + Code : Ghdl_Index_Type); + + function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32) + return Ghdl_I32; + + function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr; + + -- Allocate and clear SIZE bytes. + function Ghdl_Malloc0 (Size : Ghdl_Index_Type) return Ghdl_Ptr; + + procedure Ghdl_Deallocate (Ptr : Ghdl_Ptr); + + function Ghdl_Real_Exp (X : Ghdl_Real; Exp : Ghdl_I32) + return Ghdl_Real; + + type Ghdl_Std_Ulogic_Boolean_Array_Type is array (Ghdl_E8 range 0 .. 8) + of Ghdl_B1; + + 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 -- - + ); + + function Ghdl_Get_Resolution_Limit return Std_Time; + procedure Ghdl_Control_Simulation + (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer); +private + pragma Export (C, Ghdl_Memcpy, "__ghdl_memcpy"); + + pragma Export (C, Ghdl_Assert_Failed, "__ghdl_assert_failed"); + pragma Export (C, Ghdl_Ieee_Assert_Failed, "__ghdl_ieee_assert_failed"); + pragma Export (C, Ghdl_Psl_Assert_Failed, "__ghdl_psl_assert_failed"); + pragma Export (C, Ghdl_Psl_Cover, "__ghdl_psl_cover"); + pragma Export (C, Ghdl_Psl_Cover_Failed, "__ghdl_psl_cover_failed"); + pragma Export (C, Ghdl_Report, "__ghdl_report"); + + pragma Export (C, Ghdl_Bound_Check_Failed_L1, + "__ghdl_bound_check_failed_l1"); + pragma Export (C, Ghdl_Program_Error, "__ghdl_program_error"); + + pragma Export (C, Ghdl_Malloc, "__ghdl_malloc"); + pragma Export (C, Ghdl_Malloc0, "__ghdl_malloc0"); + pragma Export (C, Ghdl_Deallocate, "__ghdl_deallocate"); + + 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"); + + pragma Export (C, Ghdl_Get_Resolution_Limit, + "__ghdl_get_resolution_limit"); + pragma Export (Ada, Ghdl_Control_Simulation, + "__ghdl_control_simulation"); +end Grt.Lib; diff --git a/src/translate/grt/grt-main.adb b/src/translate/grt/grt-main.adb new file mode 100644 index 0000000..116ea7b --- /dev/null +++ b/src/translate/grt/grt-main.adb @@ -0,0 +1,190 @@ +-- GHDL Run Time (GRT) - entry point. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Types; use Grt.Types; +with Grt.Errors; +with Grt.Stacks; +with Grt.Processes; +with Grt.Signals; +with Grt.Options; use Grt.Options; +with Grt.Stats; +with Grt.Hooks; +with Grt.Disp_Signals; +with Grt.Disp; +with Grt.Modules; + +-- The following packages are not referenced in this package. +-- These are subprograms called only from GHDL generated code. +-- They are with'ed in order to be present in the binary. +pragma Warnings (Off); +with Grt.Files; +with Grt.Types; +with Grt.Lib; +with Grt.Shadow_Ieee; +with Grt.Images; +with Grt.Values; +with Grt.Names; +pragma Warnings (On); + +package body Grt.Main is + procedure Ghdl_Elaborate; + pragma Import (C, Ghdl_Elaborate, "__ghdl_ELABORATE"); + + -- Wrapper around elaboration just to return 0. + function Ghdl_Elaborate_Wrapper return Integer is + begin + Ghdl_Elaborate; + return 0; + end Ghdl_Elaborate_Wrapper; + + procedure Disp_Stats_Hook (Code : Integer); + pragma Convention (C, Disp_Stats_Hook); + + procedure Disp_Stats_Hook (Code : Integer) + is + pragma Unreferenced (Code); + begin + Stats.End_Simulation; + Stats.Disp_Stats; + end Disp_Stats_Hook; + + procedure Check_Flag_String + is + Err : Boolean; + begin + -- The conditions may be statically known. + pragma Warnings (Off); + + Err := False; + if (Std_Integer'Size = 32 and Flag_String (3) /= 'i') + or else (Std_Integer'Size = 64 and Flag_String (3) /= 'I') + then + Err := True; + end if; + if (Std_Time'Size = 32 and Flag_String (4) /= 't') + or else (Std_Time'Size = 64 and Flag_String (4) /= 'T') + then + Err := True; + end if; + + pragma Warnings (On); + + if Err then + Grt.Errors.Error + ("GRT is not consistent with the flags used for your design"); + end if; + end Check_Flag_String; + + procedure Run + is + use Grt.Errors; + Stop : Boolean; + Status : Integer; + begin + -- Register modules. + -- They may insert hooks. + Grt.Modules.Register_Modules; + + -- If the time resolution is to be set by the user, select a default + -- resolution. Options may override it. + if Flag_String (5) = '?' then + Set_Time_Resolution ('n'); + end if; + + -- Decode options. + Grt.Options.Decode (Stop); + + -- Check coherency between GRT and GHDL generated code. + Check_Flag_String; + + -- Early stop (for options such as --help). + if Stop then + return; + end if; + + -- Internal initializations. + Grt.Stacks.Stack_Init; + + Grt.Hooks.Call_Init_Hooks; + + Grt.Processes.Init; + + Grt.Signals.Init; + + if Flag_Stats then + Stats.Start_Elaboration; + end if; + + -- Elaboration. Run through longjump to catch errors. + if Grt.Processes.Run_Through_Longjump (Ghdl_Elaborate_Wrapper'Access) < 0 + then + Grt.Errors.Error ("error during elaboration"); + return; + end if; + + if Flag_Stats then + Stats.Start_Order; + end if; + + Grt.Hooks.Call_Start_Hooks; + + if not Flag_No_Run then + Grt.Signals.Order_All_Signals; + + if Grt.Options.Disp_Signals_Map then + Grt.Disp_Signals.Disp_Signals_Map; + end if; + if Grt.Options.Disp_Signals_Table then + Grt.Disp_Signals.Disp_Signals_Table; + end if; + 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; + end if; + + if Flag_Stats then + Disp_Stats_Hook (0); + end if; + + if Expect_Failure then + if Status >= 0 then + Expect_Failure := False; + Error ("error expected, but none occured"); + end if; + else + if Status < 0 then + Error ("simulation failed"); + end if; + end if; + end Run; + +end Grt.Main; diff --git a/src/translate/grt/grt-main.ads b/src/translate/grt/grt-main.ads new file mode 100644 index 0000000..4f78477 --- /dev/null +++ b/src/translate/grt/grt-main.ads @@ -0,0 +1,29 @@ +-- GHDL Run Time (GRT) - entry point. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package Grt.Main is + -- Elaborate and simulate the design. + procedure Run; +end Grt.Main; diff --git a/src/translate/grt/grt-modules.adb b/src/translate/grt/grt-modules.adb new file mode 100644 index 0000000..e5304f0 --- /dev/null +++ b/src/translate/grt/grt-modules.adb @@ -0,0 +1,47 @@ +-- GHDL Run Time (GRT) - Modules. +-- Copyright (C) 2005 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Vcd; +with Grt.Vcdz; +with Grt.Vpi; +with Grt.Waves; +with Grt.Vital_Annotate; +with Grt.Disp_Tree; +with Grt.Disp_Rti; + +package body Grt.Modules is + procedure Register_Modules is + begin + -- List of modules to be registered. + Grt.Disp_Tree.Register; + Grt.Vcd.Register; + Grt.Vcdz.Register; + Grt.Waves.Register; + Grt.Vpi.Register; + Grt.Vital_Annotate.Register; + Grt.Disp_Rti.Register; + end Register_Modules; +end Grt.Modules; diff --git a/src/translate/grt/grt-modules.ads b/src/translate/grt/grt-modules.ads new file mode 100644 index 0000000..23c7d6e --- /dev/null +++ b/src/translate/grt/grt-modules.ads @@ -0,0 +1,29 @@ +-- GHDL Run Time (GRT) - Modules. +-- Copyright (C) 2005 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package Grt.Modules is + -- Register optional modules. + procedure Register_Modules; +end Grt.Modules; diff --git a/src/translate/grt/grt-names.adb b/src/translate/grt/grt-names.adb new file mode 100644 index 0000000..e7928f7 --- /dev/null +++ b/src/translate/grt/grt-names.adb @@ -0,0 +1,105 @@ +-- GHDL Run Time (GRT) - 'name* subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +--with Grt.Errors; use Grt.Errors; +with Ada.Unchecked_Conversion; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Processes; use Grt.Processes; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; +with Grt.Vstrings; use Grt.Vstrings; + +package body Grt.Names is + function To_Str_String_Boundp is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Boundp); + + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => String_Ptr, Target => Std_String_Basep); + + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Basep); + + procedure Get_Name (Res : Std_String_Ptr; + Ctxt : Rti_Context; + Name : Ghdl_Str_Len_Ptr; + Is_Path : Boolean) + is + procedure Memcpy (Dst : Address; Src : Address; Len : Integer); + pragma Import (C, Memcpy); + + Bounds : Std_String_Boundp; + Len : Natural; + + Rstr : Rstring; + R_Len : Natural; + begin + if Ctxt.Block /= null then + Prepend (Rstr, ':'); + Get_Path_Name (Rstr, Ctxt, ':', not Is_Path); + R_Len := Length (Rstr); + Len := R_Len + Name.Len; + else + Len := Name.Len; + end if; + + Bounds := To_Str_String_Boundp + (Ghdl_Stack2_Allocate (Std_String_Bound'Size / System.Storage_Unit)); + Bounds.Dim_1.Left := 1; + Bounds.Dim_1.Right := Ghdl_I32 (Len); + Bounds.Dim_1.Dir := Dir_To; + Bounds.Dim_1.Length := Ghdl_Index_Type (Len); + Res.Bounds := Bounds; + if Ctxt.Block /= null then + Res.Base := To_Std_String_Basep + (Ghdl_Stack2_Allocate (Ghdl_Index_Type (Len))); + Memcpy (Res.Base (0)'Address, Get_Address (Rstr), R_Len); + Memcpy (Res.Base (Ghdl_Index_Type (R_Len))'Address, + Name.Str (1)'Address, + Name.Len); + Free (Rstr); + else + Res.Base := To_Std_String_Basep (Name.Str); + end if; + end Get_Name; + + procedure Ghdl_Get_Path_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr) + is + begin + Get_Name (Res, (Base, Ctxt), Name, True); + end Ghdl_Get_Path_Name; + + procedure Ghdl_Get_Instance_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr) + is + begin + Get_Name (Res, (Base, Ctxt), Name, False); + end Ghdl_Get_Instance_Name; + +end Grt.Names; diff --git a/src/translate/grt/grt-names.ads b/src/translate/grt/grt-names.ads new file mode 100644 index 0000000..e0c2842 --- /dev/null +++ b/src/translate/grt/grt-names.ads @@ -0,0 +1,42 @@ +-- GHDL Run Time (GRT) - 'name* subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Names is + procedure Ghdl_Get_Path_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr); + + procedure Ghdl_Get_Instance_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr); +private + pragma Export (C, Ghdl_Get_Path_Name, "__ghdl_get_path_name"); + pragma Export (C, Ghdl_Get_Instance_Name, "__ghdl_get_instance_name"); +end Grt.Names; diff --git a/src/translate/grt/grt-options.adb b/src/translate/grt/grt-options.adb new file mode 100644 index 0000000..df1eb4e --- /dev/null +++ b/src/translate/grt/grt-options.adb @@ -0,0 +1,507 @@ +-- GHDL Run Time (GRT) - command line options. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Interfaces; use Interfaces; +with Grt.Errors; use Grt.Errors; +with Grt.Astdio; +with Grt.Hooks; + +package body Grt.Options is + + Std_Standard_Time_Fs : Std_Time; + Std_Standard_Time_Ps : Std_Time; + Std_Standard_Time_Ns : Std_Time; + Std_Standard_Time_Us : Std_Time; + Std_Standard_Time_Ms : Std_Time; + Std_Standard_Time_Sec : Std_Time; + Std_Standard_Time_Min : Std_Time; + Std_Standard_Time_Hr : Std_Time; + pragma Export (C, Std_Standard_Time_Fs, "std__standard__time__BT__fs"); + pragma Weak_External (Std_Standard_Time_Fs); + pragma Export (C, Std_Standard_Time_Ps, "std__standard__time__BT__ps"); + pragma Weak_External (Std_Standard_Time_Ps); + pragma Export (C, Std_Standard_Time_Ns, "std__standard__time__BT__ns"); + pragma Weak_External (Std_Standard_Time_Ns); + pragma Export (C, Std_Standard_Time_Us, "std__standard__time__BT__us"); + pragma Weak_External (Std_Standard_Time_Us); + pragma Export (C, Std_Standard_Time_Ms, "std__standard__time__BT__ms"); + pragma Weak_External (Std_Standard_Time_Ms); + pragma Export (C, Std_Standard_Time_Sec, "std__standard__time__BT__sec"); + pragma Weak_External (Std_Standard_Time_Sec); + pragma Export (C, Std_Standard_Time_Min, "std__standard__time__BT__min"); + pragma Weak_External (Std_Standard_Time_Min); + pragma Export (C, Std_Standard_Time_Hr, "std__standard__time__BT__hr"); + pragma Weak_External (Std_Standard_Time_Hr); + + procedure Set_Time_Resolution (Res : Character) + is + begin + Std_Standard_Time_Hr := 0; + case Res is + when 'f' => + Std_Standard_Time_Fs := 1; + Std_Standard_Time_Ps := 1000; + Std_Standard_Time_Ns := 1000_000; + Std_Standard_Time_Us := 1000_000_000; + Std_Standard_Time_Ms := Std_Time'Last; + Std_Standard_Time_Sec := Std_Time'Last; + Std_Standard_Time_Min := Std_Time'Last; + Std_Standard_Time_Hr := Std_Time'Last; + when 'p' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 1; + Std_Standard_Time_Ns := 1000; + Std_Standard_Time_Us := 1000_000; + Std_Standard_Time_Ms := 1000_000_000; + Std_Standard_Time_Sec := Std_Time'Last; + Std_Standard_Time_Min := Std_Time'Last; + Std_Standard_Time_Hr := Std_Time'Last; + when 'n' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 1; + Std_Standard_Time_Us := 1000; + Std_Standard_Time_Ms := 1000_000; + Std_Standard_Time_Sec := 1000_000_000; + Std_Standard_Time_Min := Std_Time'Last; + Std_Standard_Time_Hr := Std_Time'Last; + when 'u' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 1; + Std_Standard_Time_Ms := 1000; + Std_Standard_Time_Sec := 1000_000; + Std_Standard_Time_Min := 60_000_000; + Std_Standard_Time_Hr := Std_Time'Last; + when 'm' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 1; + Std_Standard_Time_Sec := 1000; + Std_Standard_Time_Min := 60_000; + Std_Standard_Time_Hr := 3600_000; + when 's' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 0; + Std_Standard_Time_Sec := 1; + Std_Standard_Time_Min := 60; + Std_Standard_Time_Hr := 3600; + when 'M' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 0; + Std_Standard_Time_Sec := 0; + Std_Standard_Time_Min := 1; + Std_Standard_Time_Hr := 60; + when 'h' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 0; + Std_Standard_Time_Sec := 0; + Std_Standard_Time_Min := 0; + Std_Standard_Time_Hr := 1; + when others => + Error ("bad time resolution"); + end case; + end Set_Time_Resolution; + + procedure Help + is + use Grt.Astdio; + procedure P (Str : String) renames Put_Line; + Prog_Name : Ghdl_C_String; + begin + if Argc > 0 then + Prog_Name := Argv (0); + Put ("Usage: "); + Put (Prog_Name (1 .. strlen (Prog_Name))); + Put (" [OPTIONS]"); + New_Line; + end if; + + P ("Options are:"); + P (" --help, -h disp this help"); + P (" --assert-level=LEVEL stop simulation if assert at LEVEL"); + P (" LEVEL is note,warning,error,failure,none"); + P (" --ieee-asserts=POLICY enable or disable asserts from IEEE"); + P (" POLICY is enable,disable,disable-at-0"); + P (" --stop-time=X stop the simulation at time X"); + P (" X is expressed as a time value, without spaces: 1ns, ps..."); + P (" --stop-delta=X stop the simulation cycle after X delta"); + P (" --expect-failure invert exit status"); + P (" --stack-size=X set the stack size of non-sensitized processes"); + P (" --stack-max-size=X set the maximum stack size"); + P (" --no-run do not simulate, only elaborate"); + -- P (" --threads=N use N threads for simulation"); + Grt.Hooks.Call_Help_Hooks; + P ("trace options:"); + P (" --disp-time disp time as simulation advances"); + P (" --trace-signals disp signals after each cycle"); + P (" --trace-processes disp process name before each cycle"); + P (" --stats display run-time statistics"); + P ("debug options:"); + P (" --disp-order disp signals order"); + P (" --disp-sources disp sources while displaying signals"); + P (" --disp-sig-types disp signal types"); + P (" --disp-signals-map disp map bw declared sigs and internal sigs"); + P (" --disp-signals-table disp internal signals"); + P (" --checks do internal checks after each process run"); + P (" --activity=LEVEL watch activity of LEVEL signals"); + P (" LEVEL is all, min (default) or none (unsafe)"); + end Help; + + -- Extract from STR a number. + -- First, all leading blanks are skipped. + -- Then, all next digits are eaten. + -- The position of the first non digit or one past the upper bound is + -- returned into POS. + -- If there is no digits, OK is set to false, else to true. + procedure Extract_Integer + (Str : String; + Ok : out Boolean; + Result : out Integer_64; + Pos : out Natural) + is + begin + Pos := Str'First; + -- Skip blanks. + while Pos <= Str'Last and then Str (Pos) = ' ' loop + Pos := Pos + 1; + end loop; + Ok := False; + Result := 0; + loop + exit when Pos > Str'Last or else Str (Pos) not in '0' .. '9'; + Ok := True; + Result := Result * 10 + + (Character'Pos (Str (Pos)) - Character'Pos ('0')); + Pos := Pos + 1; + end loop; + end Extract_Integer; + + function Extract_Size (Str : String; Option_Name : String) return Natural + is + Ok : Boolean; + Val : Integer_64; + Pos : Natural; + begin + Extract_Integer (Str, Ok, Val, Pos); + if not Ok then + Val := 1; + end if; + if Pos > Str'Last then + -- No suffix. + if Val > Integer_64(Natural'Last) then + Error_C ("Size exceeds limit for option "); + Error_E (Option_Name); + else + return Natural (Val); + end if; + end if; + if Pos = Str'Last + or else (Pos + 1 = Str'Last + and then (Str (Pos + 1) = 'b' or Str (Pos + 1) = 'o')) + then + if Str (Pos) = 'k' or Str (Pos) = 'K' then + return Natural (Val) * 1024; + elsif Str (Pos) = 'm' or Str (Pos) = 'M' then + return Natural (Val) * 1024 * 1024; + end if; + end if; + Error_C ("bad memory unit for option "); + Error_E (Option_Name); + end Extract_Size; + + function To_Lower (C : Character) return Character is + begin + if C in 'A' .. 'Z' then + return Character'Val (Character'Pos (C) + 32); + else + return C; + end if; + end To_Lower; + + procedure Decode_Option + (Option : String; Status : out Decode_Option_Status) + is + pragma Assert (Option'First = 1); + Len : constant Natural := Option'Last; + begin + Status := Decode_Option_Ok; + if Option = "--" then + Status := Decode_Option_Last; + elsif Option = "--help" or else Option = "-h" then + Help; + Status := Decode_Option_Help; + elsif Option = "--disp-time" then + Disp_Time := True; + elsif Option = "--trace-signals" then + Trace_Signals := True; + Disp_Time := True; + elsif Option = "--trace-processes" then + Trace_Processes := True; + Disp_Time := True; + elsif Option = "--disp-order" then + Disp_Signals_Order := True; + elsif Option = "--checks" then + Checks := True; + elsif Option = "--disp-sources" then + Disp_Sources := True; + elsif Option = "--disp-sig-types" then + Disp_Sig_Types := True; + elsif Option = "--disp-signals-map" then + Disp_Signals_Map := True; + elsif Option = "--disp-signals-table" then + Disp_Signals_Table := True; + elsif Option = "--disp-sensitivity" then + Disp_Sensitivity := True; + elsif Option = "--stats" then + Flag_Stats := True; + elsif Option = "--no-run" then + Flag_No_Run := True; + elsif Len > 18 and then Option (1 .. 18) = "--time-resolution=" then + declare + Res : Character; + Unit : String (1 .. 3); + begin + Res := '?'; + if Len >= 20 then + Unit (1) := To_Lower (Option (19)); + Unit (2) := To_Lower (Option (20)); + if Len = 20 then + if Unit (1 .. 2) = "fs" then + Res := 'f'; + elsif Unit (1 .. 2) = "ps" then + Res := 'p'; + elsif Unit (1 .. 2) = "ns" then + Res := 'n'; + elsif Unit (1 .. 2) = "us" then + Res := 'u'; + elsif Unit (1 .. 2) = "ms" then + Res := 'm'; + elsif Unit (1 .. 2) = "hr" then + Res := 'h'; + end if; + elsif Len = 21 then + Unit (3) := To_Lower (Option (21)); + if Unit = "min" then + Res := 'M'; + elsif Unit = "sec" then + Res := 's'; + end if; + end if; + end if; + if Res = '?' then + Error_C ("bad unit for '"); + Error_C (Option); + Error_E ("'"); + else + if Flag_String (5) = '-' then + Error ("time resolution is ignored"); + elsif Flag_String (5) = '?' then + if Stop_Time /= Std_Time'Last then + Error ("time resolution must be set " + & "before --stop-time"); + else + Set_Time_Resolution (Res); + end if; + elsif Flag_String (5) /= Res then + Error ("time resolution is fixed during analysis"); + end if; + end if; + end; + elsif Len > 12 and then Option (1 .. 12) = "--stop-time=" then + declare + Ok : Boolean; + Pos : Natural; + Time : Integer_64; + Unit : String (1 .. 3); + begin + Extract_Integer (Option (13 .. Len), Ok, Time, Pos); + if not Ok then + Time := 1; + end if; + if (Len - Pos + 1) not in 2 .. 3 then + Error_C ("bad unit for '"); + Error_C (Option); + Error_E ("'"); + return; + end if; + Unit (1) := To_Lower (Option (Pos)); + Unit (2) := To_Lower (Option (Pos + 1)); + if Len = Pos + 2 then + Unit (3) := To_Lower (Option (Pos + 2)); + else + Unit (3) := ' '; + end if; + if Unit = "fs " then + null; + elsif Unit = "ps " then + Time := Time * (10 ** 3); + elsif Unit = "ns " then + Time := Time * (10 ** 6); + elsif Unit = "us " then + Time := Time * (10 ** 9); + elsif Unit = "ms " then + Time := Time * (10 ** 12); + elsif Unit = "sec" then + Time := Time * (10 ** 15); + elsif Unit = "min" then + Time := Time * (10 ** 15) * 60; + elsif Unit = "hr " then + Time := Time * (10 ** 15) * 3600; + else + Error_C ("bad unit name for '"); + Error_C (Option); + Error_E ("'"); + end if; + Stop_Time := Std_Time (Time); + end; + elsif Len > 13 and then Option (1 .. 13) = "--stop-delta=" then + declare + Ok : Boolean; + Pos : Natural; + Time : Integer_64; + begin + Extract_Integer (Option (14 .. Len), Ok, Time, Pos); + if not Ok or else Pos <= Len then + Error_C ("bad value in '"); + Error_C (Option); + Error_E ("'"); + else + if Time > Integer_64 (Integer'Last) then + Stop_Delta := Integer'Last; + else + Stop_Delta := Integer (Time); + end if; + end if; + end; + elsif Len > 15 and then Option (1 .. 15) = "--assert-level=" then + if Option (16 .. Len) = "note" then + Severity_Level := Note_Severity; + elsif Option (16 .. Len) = "warning" then + Severity_Level := Warning_Severity; + elsif Option (16 .. Len) = "error" then + Severity_Level := Error_Severity; + elsif Option (16 .. Len) = "failure" then + Severity_Level := Failure_Severity; + elsif Option (16 .. Len) = "none" then + Severity_Level := 4; + else + Error ("bad argument for --assert-level option, try --help"); + end if; + elsif Len > 15 and then Option (1 .. 15) = "--ieee-asserts=" then + if Option (16 .. Len) = "disable" then + Ieee_Asserts := Disable_Asserts; + elsif Option (16 .. Len) = "enable" then + Ieee_Asserts := Enable_Asserts; + elsif Option (16 .. Len) = "disable-at-0" then + Ieee_Asserts := Disable_Asserts_At_Time_0; + else + Error ("bad argument for --ieee-asserts option, try --help"); + end if; + elsif Option = "--expect-failure" then + Expect_Failure := True; + elsif Len >= 13 and then Option (1 .. 13) = "--stack-size=" then + Stack_Size := Extract_Size + (Option (14 .. Len), "--stack-size"); + if Stack_Size > Stack_Max_Size then + Stack_Max_Size := Stack_Size; + end if; + elsif Len >= 17 and then Option (1 .. 17) = "--stack-max-size=" then + Stack_Max_Size := Extract_Size + (Option (18 .. Len), "--stack-size"); + if Stack_Size > Stack_Max_Size then + Stack_Size := Stack_Max_Size; + end if; + elsif Len >= 11 and then Option (1 .. 11) = "--activity=" then + if Option (12 .. Len) = "none" then + Flag_Activity := Activity_None; + elsif Option (12 .. Len) = "min" then + Flag_Activity := Activity_Minimal; + elsif Option (12 .. Len) = "all" then + Flag_Activity := Activity_All; + else + Error ("bad argument for --activity, try --help"); + end if; + elsif Len > 10 and then Option (1 .. 10) = "--threads=" then + declare + Ok : Boolean; + Pos : Natural; + Val : Integer_64; + begin + Extract_Integer (Option (11 .. Len), Ok, Val, Pos); + if not Ok or else Pos <= Len then + Error_C ("bad value in '"); + Error_C (Option); + Error_E ("'"); + else + Nbr_Threads := Integer (Val); + end if; + end; + elsif not Grt.Hooks.Call_Option_Hooks (Option) then + Error_C ("unknown option '"); + Error_C (Option); + Error_E ("', try --help"); + end if; + end Decode_Option; + + procedure Decode (Stop : out Boolean) + is + Arg : Ghdl_C_String; + Len : Natural; + Status : Decode_Option_Status; + begin + Stop := False; + Last_Opt := Argc - 1; + for I in 1 .. Argc - 1 loop + Arg := Argv (I); + Len := strlen (Arg); + declare + Argument : constant String := Arg (1 .. Len); + begin + Decode_Option (Argument, Status); + case Status is + when Decode_Option_Last => + Last_Opt := I; + exit; + when Decode_Option_Help => + Stop := True; + when Decode_Option_Ok => + null; + end case; + end; + end loop; + end Decode; +end Grt.Options; diff --git a/src/translate/grt/grt-options.ads b/src/translate/grt/grt-options.ads new file mode 100644 index 0000000..88b1f50 --- /dev/null +++ b/src/translate/grt/grt-options.ads @@ -0,0 +1,154 @@ +-- GHDL Run Time (GRT) - command line options. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Lib; use Grt.Lib; + +package Grt.Options is + pragma Preelaborate (Grt.Options); + + -- Name of the program, set by argv[0]. + -- Must be set before calling DECODE. + Progname : Ghdl_C_String; + + -- Arguments. + -- This mimics argc/argv of 'main'. + -- These must be set before calling DECODE. + Argc : Integer; + + type Argv_Array_Type is array (Natural) of Ghdl_C_String; + type Argv_Type is access Argv_Array_Type; + + Argv : Argv_Type; + + -- Last option decoded. + -- Following arguments are reserved for the program. + Last_Opt : Integer; + + -- Consistent flags used for analysis. + -- Format is "VVitr", where: + -- 'VV' is the version (87, 93 or 08). + -- 'i' is the integer size ('i' for 32 bits, 'I' for 64 bits). + -- 't' is the time size ('t' for 32 bits, 'T' for 64 bits). + -- 'r' is the resolution ('?' for to be set by the user, '-' for any). + Flag_String : constant String (1 .. 5); + pragma Import (C, Flag_String, "__ghdl_flag_string"); + + -- Display options help. + -- Should not be called directly. + procedure Help; + + -- Status from Decode_Option. + type Decode_Option_Status is + ( + -- Last option, next arguments aren't options. + Decode_Option_Last, + + -- --help option, program shouldn't run. + Decode_Option_Help, + + -- Option was successfuly decoded. + Decode_Option_Ok); + + -- Decode option Option and set Status. + procedure Decode_Option + (Option : String; Status : out Decode_Option_Status); + + -- Decode command line options. + -- If STOP is true, there nothing must happen (set by --help). + procedure Decode (Stop : out Boolean); + + -- Set by --disp-time (and --trace-signals, --trace-processes) to display + -- time and deltas. + Disp_Time : Boolean := False; + + -- Set by --trace-signals, to display signals after each cycle. + Trace_Signals : Boolean := False; + + -- Set by --trace-processes, to display process name before being run. + Trace_Processes : Boolean := False; + + -- Set by --disp-sig-types, to display signals and they types. + Disp_Sig_Types : Boolean := False; + + 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; + + -- Set by --stats to display statistics. + Flag_Stats : Boolean := False; + + -- Set by --checks to do internal checks. + Checks : Boolean := False; + + -- Level at which an assert stop the simulation. + Severity_Level : Integer := Failure_Severity; + + -- How assertions are handled. + type Assert_Handling is + (Enable_Asserts, + Disable_Asserts_At_Time_0, + Disable_Asserts); + + -- Handling of assertions from IEEE library. + Ieee_Asserts : Assert_Handling := Enable_Asserts; + + -- Set by --stop-time=XXX to stop the simulation at or just after XXX. + -- (unit is fs in fact). + Stop_Time : Std_Time := Std_Time'Last; + + -- Set by --stop-delta=XXX to stop the simulation after XXX delta cycles. + Stop_Delta : Natural := 5000; + + -- The default stack size for non-sensitized processes. + Stack_Size : Natural := 8 * 1024; + + -- The maximum stack size for non-sensitized processes. + Stack_Max_Size : Natural := 128 * 1024; + + -- Set by --no-run + -- If set, do not simulate, only elaborate. + Flag_No_Run : Boolean := False; + + type Activity_Mode is (Activity_All, Activity_Minimal, Activity_None); + Flag_Activity : Activity_Mode := Activity_Minimal; + + -- Set by --thread= + -- Number of threads used to do the simulation. + -- 1 mean no additionnal threads, 0 means as many threads as number of + -- CPUs. + Nbr_Threads : Natural := 1; + + -- Set the time resolution. + -- Only call this subprogram if you are allowed to set the time resolution. + procedure Set_Time_Resolution (Res : Character); +private + pragma Export (C, Stack_Size); + pragma Export (C, Stack_Max_Size); + pragma Export (C, Nbr_Threads, "grt_nbr_threads"); +end Grt.Options; diff --git a/src/translate/grt/grt-processes.adb b/src/translate/grt/grt-processes.adb new file mode 100644 index 0000000..64db682 --- /dev/null +++ b/src/translate/grt/grt-processes.adb @@ -0,0 +1,1042 @@ +-- GHDL Run Time (GRT) - processes. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Table; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Disp; +with Grt.Astdio; +with Grt.Errors; use Grt.Errors; +with Grt.Options; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Utils; +with Grt.Hooks; +with Grt.Disp_Signals; +with Grt.Stats; +with Grt.Threads; use Grt.Threads; +pragma Elaborate_All (Grt.Table); + +package body Grt.Processes is + Last_Time : constant Std_Time := Std_Time'Last; + + -- Identifier for a process. + type Process_Id is new Integer; + + -- Table of processes. + package Process_Table is new Grt.Table + (Table_Component_Type => Process_Acc, + Table_Index_Type => Process_Id, + Table_Low_Bound => 1, + Table_Initial => 16); + + type Finalizer_Type is record + -- Subprogram containing process code. + Subprg : Proc_Acc; + + -- Instance (THIS parameter) for the subprogram. + This : Instance_Acc; + 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); + + -- List of processes to be resume at next cycle. + type Process_Acc_Array is array (Natural range <>) of Process_Acc; + type Process_Acc_Array_Acc is access Process_Acc_Array; + + Resume_Process_Table : Process_Acc_Array_Acc; + Last_Resume_Process : Natural := 0; + Postponed_Resume_Process_Table : Process_Acc_Array_Acc; + Last_Postponed_Resume_Process : Natural := 0; + + -- Number of postponed processes. + Nbr_Postponed_Processes : Natural := 0; + Nbr_Non_Postponed_Processes : Natural := 0; + + -- Number of resumed processes. + Nbr_Resumed_Processes : Natural := 0; + + -- Earliest time out within non-sensitized processes. + Process_First_Timeout : Std_Time := Last_Time; + Process_Timeout_Chain : Process_Acc := null; + + procedure Init is + begin + null; + end Init; + + function Get_Nbr_Processes return Natural is + begin + return Natural (Process_Table.Last); + end Get_Nbr_Processes; + + function Get_Nbr_Sensitized_Processes return Natural + is + Res : Natural := 0; + begin + for I in Process_Table.First .. Process_Table.Last loop + if Process_Table.Table (I).State = State_Sensitized then + Res := Res + 1; + end if; + end loop; + return Res; + end Get_Nbr_Sensitized_Processes; + + function Get_Nbr_Resumed_Processes return Natural is + begin + return Nbr_Resumed_Processes; + end Get_Nbr_Resumed_Processes; + + procedure Process_Register (This : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Rti_Context; + State : Process_State; + Postponed : Boolean) + is + Stack : Stack_Type; + P : Process_Acc; + begin + if State /= State_Sensitized and then not One_Stack then + Stack := Stack_Create (Proc, This); + if Stack = Null_Stack then + Internal_Error ("cannot allocate stack: memory exhausted"); + end if; + else + Stack := Null_Stack; + end if; + P := new Process_Type'(Subprg => Proc, + This => This, + Rti => Ctxt, + Sensitivity => null, + Resumed => False, + Postponed => Postponed, + State => State, + Timeout => Bad_Time, + Timeout_Chain_Next => null, + Timeout_Chain_Prev => null, + Stack => Stack); + Process_Table.Append (P); + -- Used to create drivers. + Set_Current_Process (P); + if Postponed then + Nbr_Postponed_Processes := Nbr_Postponed_Processes + 1; + else + Nbr_Non_Postponed_Processes := Nbr_Non_Postponed_Processes + 1; + end if; + end Process_Register; + + procedure Ghdl_Process_Register + (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address) + is + begin + Process_Register (Instance, Proc, (Addr, Ctxt), State_Ready, False); + end Ghdl_Process_Register; + + procedure Ghdl_Sensitized_Process_Register + (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address) + is + begin + Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, False); + end Ghdl_Sensitized_Process_Register; + + procedure Ghdl_Postponed_Process_Register + (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address) + is + begin + Process_Register (Instance, Proc, (Addr, Ctxt), State_Ready, True); + end Ghdl_Postponed_Process_Register; + + procedure Ghdl_Postponed_Sensitized_Process_Register + (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address) + is + begin + Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, True); + end Ghdl_Postponed_Sensitized_Process_Register; + + procedure Verilog_Process_Register (This : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Rti_Context) + is + P : Process_Acc; + begin + P := new Process_Type'(Rti => Ctxt, + Sensitivity => null, + Resumed => False, + Postponed => False, + State => State_Sensitized, + Timeout => Bad_Time, + Timeout_Chain_Next => null, + Timeout_Chain_Prev => null, + Subprg => Proc, + This => This, + Stack => Null_Stack); + Process_Table.Append (P); + -- Used to create drivers. + Set_Current_Process (P); + end Verilog_Process_Register; + + procedure Ghdl_Initial_Register (Instance : Instance_Acc; + Proc : Proc_Acc) + is + begin + Verilog_Process_Register (Instance, Proc, Null_Context); + end Ghdl_Initial_Register; + + procedure Ghdl_Always_Register (Instance : Instance_Acc; + Proc : Proc_Acc) + is + begin + Verilog_Process_Register (Instance, Proc, Null_Context); + end Ghdl_Always_Register; + + procedure Ghdl_Process_Add_Sensitivity (Sig : Ghdl_Signal_Ptr) + is + begin + Resume_Process_If_Event + (Sig, Process_Table.Table (Process_Table.Last)); + end Ghdl_Process_Add_Sensitivity; + + procedure Ghdl_Finalize_Register (Instance : Instance_Acc; + Proc : Proc_Acc) + is + begin + Finalizer_Table.Append (Finalizer_Type'(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 + if not Proc.Resumed then + Proc.Resumed := True; + if Proc.Postponed then + Last_Postponed_Resume_Process := Last_Postponed_Resume_Process + 1; + Postponed_Resume_Process_Table (Last_Postponed_Resume_Process) + := Proc; + else + Last_Resume_Process := Last_Resume_Process + 1; + Resume_Process_Table (Last_Resume_Process) := Proc; + end if; + end if; + end Resume_Process; + + function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type) + return System.Address + is + begin + return Grt.Stack2.Allocate (Get_Stack2, Size); + end Ghdl_Stack2_Allocate; + + function Ghdl_Stack2_Mark return Mark_Id + is + St2 : Stack2_Ptr := Get_Stack2; + begin + if St2 = Null_Stack2_Ptr then + St2 := Grt.Stack2.Create; + Set_Stack2 (St2); + end if; + return Grt.Stack2.Mark (St2); + end Ghdl_Stack2_Mark; + + procedure Ghdl_Stack2_Release (Mark : Mark_Id) is + begin + Grt.Stack2.Release (Get_Stack2, Mark); + end Ghdl_Stack2_Release; + + procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr) + is + Proc : constant Process_Acc := Get_Current_Process; + El : Action_List_Acc; + begin + El := new Action_List'(Dynamic => True, + Next => Sig.Event_List, + Proc => Proc, + Prev => null, + Sig => Sig, + Chain => Proc.Sensitivity); + if Sig.Event_List /= null and then Sig.Event_List.Dynamic then + Sig.Event_List.Prev := El; + end if; + Sig.Event_List := El; + Proc.Sensitivity := El; + end Ghdl_Process_Wait_Add_Sensitivity; + + procedure Update_Process_First_Timeout (Proc : Process_Acc) is + begin + if Proc.Timeout < Process_First_Timeout then + Process_First_Timeout := Proc.Timeout; + end if; + Proc.Timeout_Chain_Next := Process_Timeout_Chain; + Proc.Timeout_Chain_Prev := null; + if Process_Timeout_Chain /= null then + Process_Timeout_Chain.Timeout_Chain_Prev := Proc; + end if; + Process_Timeout_Chain := Proc; + end Update_Process_First_Timeout; + + procedure Remove_Process_From_Timeout_Chain (Proc : Process_Acc) is + begin + -- Remove Proc from the timeout list. + if Proc.Timeout_Chain_Prev /= null then + Proc.Timeout_Chain_Prev.Timeout_Chain_Next := + Proc.Timeout_Chain_Next; + elsif Process_Timeout_Chain = Proc then + -- Only if Proc is in the chain. + Process_Timeout_Chain := Proc.Timeout_Chain_Next; + end if; + if Proc.Timeout_Chain_Next /= null then + Proc.Timeout_Chain_Next.Timeout_Chain_Prev := + Proc.Timeout_Chain_Prev; + Proc.Timeout_Chain_Next := null; + end if; + -- Be sure a second call won't corrupt the chain. + Proc.Timeout_Chain_Prev := null; + end Remove_Process_From_Timeout_Chain; + + procedure Ghdl_Process_Wait_Set_Timeout (Time : Std_Time) + is + Proc : constant Process_Acc := Get_Current_Process; + begin + if Time < 0 then + -- LRM93 8.1 + Error ("negative timeout clause"); + end if; + Proc.Timeout := Current_Time + Time; + Update_Process_First_Timeout (Proc); + end Ghdl_Process_Wait_Set_Timeout; + + function Ghdl_Process_Wait_Has_Timeout return Boolean + is + Proc : constant Process_Acc := Get_Current_Process; + begin + -- Note: in case of timeout, the timeout is removed when process is + -- woken up. + return Proc.State = State_Timeout; + end Ghdl_Process_Wait_Has_Timeout; + + procedure Ghdl_Process_Wait_Wait + is + Proc : constant Process_Acc := Get_Current_Process; + begin + if Proc.State = State_Sensitized then + Error ("wait statement in a sensitized process"); + end if; + -- Suspend this process. + Proc.State := State_Wait; +-- if Cur_Proc.Timeout = Bad_Time then +-- Cur_Proc.Timeout := Std_Time'Last; +-- end if; + end Ghdl_Process_Wait_Wait; + + function Ghdl_Process_Wait_Suspend return Boolean + is + Proc : constant Process_Acc := Get_Current_Process; + begin + Ghdl_Process_Wait_Wait; + if One_Stack then + Internal_Error ("wait_suspend"); + else + Stack_Switch (Get_Main_Stack, Proc.Stack); + end if; + return Ghdl_Process_Wait_Has_Timeout; + end Ghdl_Process_Wait_Suspend; + + procedure Free is new Ada.Unchecked_Deallocation + (Action_List, Action_List_Acc); + + procedure Ghdl_Process_Wait_Close + is + Proc : constant Process_Acc := Get_Current_Process; + El : Action_List_Acc; + N_El : Action_List_Acc; + begin + -- Remove the sensitivity. + El := Proc.Sensitivity; + Proc.Sensitivity := null; + while El /= null loop + pragma Assert (El.Proc = Get_Current_Process); + if El.Prev = null then + El.Sig.Event_List := El.Next; + else + pragma Assert (El.Prev.Dynamic); + El.Prev.Next := El.Next; + end if; + if El.Next /= null and then El.Next.Dynamic then + El.Next.Prev := El.Prev; + end if; + N_El := El.Chain; + Free (El); + El := N_El; + end loop; + + -- Remove Proc from the timeout list. + Remove_Process_From_Timeout_Chain (Proc); + + -- This is necessary when the process has been woken-up by an event + -- before the timeout triggers. + if Process_First_Timeout = Proc.Timeout then + -- Remove the timeout. + Proc.Timeout := Bad_Time; + + declare + Next_Timeout : Std_Time; + P : Process_Acc; + begin + Next_Timeout := Last_Time; + P := Process_Timeout_Chain; + while P /= null loop + case P.State is + when State_Delayed + | State_Wait => + if P.Timeout > 0 + and then P.Timeout < Next_Timeout + then + Next_Timeout := P.Timeout; + end if; + when others => + null; + end case; + P := P.Timeout_Chain_Next; + end loop; + Process_First_Timeout := Next_Timeout; + end; + else + -- Remove the timeout. + Proc.Timeout := Bad_Time; + end if; + Proc.State := State_Ready; + end Ghdl_Process_Wait_Close; + + procedure Ghdl_Process_Wait_Exit + is + Proc : constant Process_Acc := Get_Current_Process; + begin + if Proc.State = State_Sensitized then + Error ("wait statement in a sensitized process"); + end if; + -- Mark this process as dead, in order to kill it. + -- It cannot be killed now, since this code is still in the process. + Proc.State := State_Dead; + + -- Suspend this process. + if not One_Stack then + Stack_Switch (Get_Main_Stack, Proc.Stack); + end if; + end Ghdl_Process_Wait_Exit; + + procedure Ghdl_Process_Wait_Timeout (Time : Std_Time) + is + Proc : constant Process_Acc := Get_Current_Process; + begin + if Proc.State = State_Sensitized then + Error ("wait statement in a sensitized process"); + end if; + if Time < 0 then + -- LRM93 8.1 + Error ("negative timeout clause"); + end if; + Proc.Timeout := Current_Time + Time; + Proc.State := State_Wait; + Update_Process_First_Timeout (Proc); + -- Suspend this process. + if One_Stack then + Internal_Error ("wait_timeout"); + else + Stack_Switch (Get_Main_Stack, Proc.Stack); + end if; + -- Clean-up. + Proc.Timeout := Bad_Time; + Remove_Process_From_Timeout_Chain (Proc); + Proc.State := State_Ready; + end Ghdl_Process_Wait_Timeout; + + -- Verilog. + procedure Ghdl_Process_Delay (Del : Ghdl_U32) + is + Proc : constant Process_Acc := Get_Current_Process; + begin + Proc.Timeout := Current_Time + Std_Time (Del); + Proc.State := State_Delayed; + Update_Process_First_Timeout (Proc); + end Ghdl_Process_Delay; + + -- Protected object lock. + -- Note: there is no real locks, since the kernel is single threading. + -- Multi lock is allowed, and rules are just checked. + type Object_Lock is record + -- The owner of the lock. + -- Nul_Process_Id means the lock is free. + Process : Process_Acc; + -- Number of times the lock has been acquired. + Count : Natural; + end record; + + type Object_Lock_Acc is access Object_Lock; + type Object_Lock_Acc_Acc is access Object_Lock_Acc; + + function To_Lock_Acc_Acc is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Object_Lock_Acc_Acc); + + procedure Ghdl_Protected_Enter (Obj : System.Address) + is + Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all; + begin + if Lock.Process = null then + if Lock.Count /= 0 then + Internal_Error ("protected_enter"); + end if; + Lock.Process := Get_Current_Process; + Lock.Count := 1; + else + if Lock.Process /= Get_Current_Process then + Internal_Error ("protected_enter(2)"); + end if; + Lock.Count := Lock.Count + 1; + end if; + end Ghdl_Protected_Enter; + + procedure Ghdl_Protected_Leave (Obj : System.Address) + is + Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all; + begin + if Lock.Process /= Get_Current_Process then + Internal_Error ("protected_leave(1)"); + end if; + + if Lock.Count = 0 then + Internal_Error ("protected_leave(2)"); + end if; + Lock.Count := Lock.Count - 1; + if Lock.Count = 0 then + Lock.Process := null; + end if; + end Ghdl_Protected_Leave; + + procedure Ghdl_Protected_Init (Obj : System.Address) + is + Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj); + begin + Lock.all := new Object_Lock'(Process => null, Count => 0); + end Ghdl_Protected_Init; + + procedure Ghdl_Protected_Fini (Obj : System.Address) + is + procedure Deallocate is new Ada.Unchecked_Deallocation + (Object => Object_Lock, Name => Object_Lock_Acc); + + Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj); + begin + if Lock.all.Count /= 0 or Lock.all.Process /= null then + Internal_Error ("protected_fini"); + end if; + Deallocate (Lock.all); + end Ghdl_Protected_Fini; + + function Compute_Next_Time return Std_Time + is + Res : Std_Time; + begin + -- f) The time of the next simulation cycle, Tn, is determined by + -- setting it to the earliest of + -- 1) TIME'HIGH + Res := Std_Time'Last; + + -- 2) The next time at which a driver becomes active, or + Res := Std_Time'Min (Res, Grt.Signals.Find_Next_Time); + + if Res = Current_Time then + return Res; + end if; + + -- 3) The next time at which a process resumes. + if Process_First_Timeout < Res then + -- No signals to be updated. + Grt.Signals.Flush_Active_List; + + Res := Process_First_Timeout; + end if; + + return Res; + end Compute_Next_Time; + + procedure Disp_Process_Name (Stream : Grt.Stdio.FILEs; Proc : Process_Acc) + is + begin + Grt.Rtis_Utils.Put (Stream, Proc.Rti); + end Disp_Process_Name; + + procedure Disp_All_Processes + is + use Grt.Stdio; + use Grt.Astdio; + begin + for I in Process_Table.First .. Process_Table.Last loop + declare + Proc : constant Process_Acc := Process_Table.Table (I); + begin + Disp_Process_Name (stdout, Proc); + New_Line (stdout); + Put (stdout, " State: "); + case Proc.State is + when State_Sensitized => + Put (stdout, "sensitized"); + when State_Wait => + Put (stdout, "wait"); + if Proc.Timeout /= Bad_Time then + Put (stdout, " until "); + Put_Time (stdout, Proc.Timeout); + end if; + when State_Ready => + Put (stdout, "ready"); + when State_Timeout => + Put (stdout, "timeout"); + when State_Delayed => + Put (stdout, "delayed"); + when State_Dead => + Put (stdout, "dead"); + end case; +-- Put (stdout, ": time: "); +-- Put_U64 (stdout, Proc.Stats_Time); +-- Put (stdout, ", runs: "); +-- Put_U32 (stdout, Proc.Stats_Run); + New_Line (stdout); + end; + end loop; + end Disp_All_Processes; + + pragma Unreferenced (Disp_All_Processes); + + -- Run resumed processes. + -- If POSTPONED is true, resume postponed processes, else resume + -- non-posponed processes. + -- Returns one of these values: + -- No process has been run. + Run_None : constant Integer := 1; + -- At least one process was run. + Run_Resumed : constant Integer := 2; + -- Simulation is finished. + Run_Finished : constant Integer := 3; + -- Failure, simulation should stop. + Run_Failure : constant Integer := -1; + + Mt_Last : Natural; + Mt_Table : Process_Acc_Array_Acc; + Mt_Index : aliased Natural; + + procedure Run_Processes_Threads + is + Proc : Process_Acc; + Idx : Natural; + begin + loop + -- Atomically get a process to be executed + Idx := Grt.Threads.Atomic_Inc (Mt_Index'Access); + if Idx > Mt_Last then + return; + end if; + Proc := Mt_Table (Idx); + + if Grt.Options.Trace_Processes then + Grt.Astdio.Put ("run process "); + Disp_Process_Name (Stdio.stdout, Proc); + Grt.Astdio.Put (" ["); + Grt.Astdio.Put (Stdio.stdout, To_Address (Proc.This)); + Grt.Astdio.Put ("]"); + Grt.Astdio.New_Line; + end if; + if not Proc.Resumed then + Internal_Error ("run non-resumed process"); + end if; + Proc.Resumed := False; + Set_Current_Process (Proc); + if Proc.State = State_Sensitized or else One_Stack then + Proc.Subprg.all (Proc.This); + else + Stack_Switch (Proc.Stack, Get_Main_Stack); + end if; + if Grt.Options.Checks then + Ghdl_Signal_Internal_Checks; + Grt.Stack2.Check_Empty (Get_Stack2); + end if; + end loop; + end Run_Processes_Threads; + + function Run_Processes (Postponed : Boolean) return Integer + is + Table : Process_Acc_Array_Acc; + Last : Natural; + begin + if Options.Flag_Stats then + Stats.Start_Processes; + end if; + + if Postponed then + Table := Postponed_Resume_Process_Table; + Last := Last_Postponed_Resume_Process; + Last_Postponed_Resume_Process := 0; + else + Table := Resume_Process_Table; + Last := Last_Resume_Process; + Last_Resume_Process := 0; + end if; + Nbr_Resumed_Processes := Nbr_Resumed_Processes + Last; + + if Options.Nbr_Threads = 1 then + for I in 1 .. Last loop + declare + Proc : constant Process_Acc := Table (I); + begin + if not Proc.Resumed then + Internal_Error ("run non-resumed process"); + end if; + if Grt.Options.Trace_Processes then + Grt.Astdio.Put ("run process "); + Disp_Process_Name (Stdio.stdout, Proc); + Grt.Astdio.Put (" ["); + Grt.Astdio.Put (Stdio.stdout, To_Address (Proc.This)); + Grt.Astdio.Put ("]"); + Grt.Astdio.New_Line; + end if; + + Proc.Resumed := False; + Set_Current_Process (Proc); + if Proc.State = State_Sensitized or else One_Stack then + Proc.Subprg.all (Proc.This); + else + Stack_Switch (Proc.Stack, Get_Main_Stack); + end if; + if Grt.Options.Checks then + Ghdl_Signal_Internal_Checks; + Grt.Stack2.Check_Empty (Get_Stack2); + end if; + end; + end loop; + else + Mt_Last := Last; + Mt_Table := Table; + Mt_Index := 1; + Threads.Run_Parallel (Run_Processes_Threads'Access); + end if; + + if Last >= 1 then + return Run_Resumed; + else + return Run_None; + end if; + end Run_Processes; + + function Initialization_Phase return Integer + is + Status : Integer; + begin + -- Allocate processes arrays. + Resume_Process_Table := + new Process_Acc_Array (1 .. Nbr_Non_Postponed_Processes); + Postponed_Resume_Process_Table := + new Process_Acc_Array (1 .. Nbr_Postponed_Processes); + + -- LRM93 12.6.4 + -- At the beginning of initialization, the current time, Tc, is assumed + -- to be 0 ns. + Current_Time := 0; + + -- The initialization phase consists of the following steps: + -- - The driving value and the effective value of each explicitly + -- declared signal are computed, and the current value of the signal + -- is set to the effective value. This value is assumed to have been + -- the value of the signal for an infinite length of time prior to + -- the start of the simulation. + Init_Signals; + + -- - The value of each implicit signal of the form S'Stable(T) or + -- S'Quiet(T) is set to true. The value of each implicit signal of + -- the form S'Delayed is set to the initial value of its prefix, S. + -- GHDL: already done when the signals are created. + null; + + -- - The value of each implicit GUARD signal is set to the result of + -- evaluating the corresponding guard expression. + null; + + for I in Process_Table.First .. Process_Table.Last loop + Resume_Process (Process_Table.Table (I)); + end loop; + + -- - Each nonpostponed process in the model is executed until it + -- suspends. + Status := Run_Processes (Postponed => False); + if Status = Run_Failure then + return Run_Failure; + end if; + + -- - Each postponed process in the model is executed until it suspends. + Status := Run_Processes (Postponed => True); + if Status = Run_Failure then + return Run_Failure; + end if; + + -- - The time of the next simulation cycle (which in this case is the + -- first simulation cycle), Tn, is calculated according to the rules + -- of step f of the simulation cycle, below. + Current_Time := Compute_Next_Time; + + -- Clear current_delta, will be set by Simulation_Cycle. + Current_Delta := 0; + + return Run_Resumed; + end Initialization_Phase; + + -- Launch a simulation cycle. + -- Set FINISHED to true if this is the last cycle. + function Simulation_Cycle return Integer + is + Tn : Std_Time; + Status : Integer; + begin + -- LRM93 12.6.4 + -- A simulation cycle consists of the following steps: + -- + -- a) The current time, Tc is set equal to Tn. Simulation is complete + -- when Tn = TIME'HIGH and there are no active drivers or process + -- resumptions at Tn. + -- GHDL: this is done at the last step of the cycle. + null; + + -- b) Each active explicit signal in the model is updated. (Events + -- may occur on signals as a result). + -- c) Each implicit signal in the model is updated. (Events may occur + -- on signals as a result.) + if Options.Flag_Stats then + Stats.Start_Update; + end if; + Update_Signals; + if Options.Flag_Stats then + Stats.Start_Resume; + end if; + + -- d) For each process P, if P is currently sensitive to a signal S and + -- if an event has occured on S in this simulation cycle, then P + -- resumes. + if Current_Time = Process_First_Timeout then + Tn := Last_Time; + declare + Proc : Process_Acc; + begin + Proc := Process_Timeout_Chain; + while Proc /= null loop + case Proc.State is + when State_Sensitized => + null; + when State_Delayed => + if Proc.Timeout = Current_Time then + Proc.Timeout := Bad_Time; + Resume_Process (Proc); + Proc.State := State_Sensitized; + elsif Proc.Timeout > 0 and then Proc.Timeout < Tn then + Tn := Proc.Timeout; + end if; + when State_Wait => + if Proc.Timeout = Current_Time then + Proc.Timeout := Bad_Time; + Resume_Process (Proc); + Proc.State := State_Timeout; + elsif Proc.Timeout > 0 and then Proc.Timeout < Tn then + Tn := Proc.Timeout; + end if; + when State_Timeout + | State_Ready => + Internal_Error ("process in timeout"); + when State_Dead => + null; + end case; + Proc := Proc.Timeout_Chain_Next; + end loop; + end; + Process_First_Timeout := Tn; + end if; + + -- e) Each nonpostponed that has resumed in the current simulation cycle + -- is executed until it suspends. + Status := Run_Processes (Postponed => False); + if Status = Run_Failure then + return Run_Failure; + end if; + + -- f) The time of the next simulation cycle, Tn, is determined by + -- setting it to the earliest of + -- 1) TIME'HIGH + -- 2) The next time at which a driver becomes active, or + -- 3) The next time at which a process resumes. + -- If Tn = Tc, then the next simulation cycle (if any) will be a + -- delta cycle. + if Options.Flag_Stats then + Stats.Start_Next_Time; + end if; + Tn := Compute_Next_Time; + + -- g) If the next simulation cycle will be a delta cycle, the remainder + -- of the step is skipped. + -- Otherwise, each postponed process that has resumed but has not + -- been executed since its last resumption is executed until it + -- suspends. Then Tn is recalculated according to the rules of + -- step f. It is an error if the execution of any postponed + -- process causes a delta cycle to occur immediatly after the + -- current simulation cycle. + if Tn = Current_Time then + if Current_Time = Last_Time and then Status = Run_None then + return Run_Finished; + else + Current_Delta := Current_Delta + 1; + return Run_Resumed; + end if; + else + Current_Delta := 0; + if Nbr_Postponed_Processes /= 0 then + Status := Run_Processes (Postponed => True); + end if; + if Status = Run_Resumed then + Flush_Active_List; + if Options.Flag_Stats then + Stats.Start_Next_Time; + end if; + Tn := Compute_Next_Time; + if Tn = Current_Time then + Error ("postponed process causes a delta cycle"); + end if; + elsif Status = Run_Failure then + return Run_Failure; + end if; + Current_Time := Tn; + return Run_Resumed; + end if; + end Simulation_Cycle; + + function Simulation return Integer + is + use Options; + Status : Integer; + begin + if Nbr_Threads /= 1 then + Threads.Init; + end if; + +-- if Disp_Sig_Types then +-- Grt.Disp.Disp_Signals_Type; +-- end if; + + Status := Run_Through_Longjump (Initialization_Phase'Access); + if Status /= Run_Resumed then + return -1; + end if; + + Nbr_Delta_Cycles := 0; + Nbr_Cycles := 0; + if Trace_Signals then + Grt.Disp_Signals.Disp_All_Signals; + end if; + + if Current_Time /= 0 then + -- This is the end of a cycle. This can happen when the time is not + -- zero after initialization. + Cycle_Time := 0; + Grt.Hooks.Call_Cycle_Hooks; + end if; + + loop + Cycle_Time := Current_Time; + if Disp_Time then + Grt.Disp.Disp_Now; + end if; + Status := Run_Through_Longjump (Simulation_Cycle'Access); + exit when Status < 0; + if Trace_Signals then + Grt.Disp_Signals.Disp_All_Signals; + end if; + + -- Statistics. + if Current_Delta = 0 then + Nbr_Cycles := Nbr_Cycles + 1; + else + Nbr_Delta_Cycles := Nbr_Delta_Cycles + 1; + end if; + + exit when Status = Run_Finished; + if Current_Delta = 0 then + Grt.Hooks.Call_Cycle_Hooks; + end if; + + if Current_Delta >= Stop_Delta then + Error ("simulation stopped by --stop-delta"); + exit; + end if; + if Current_Time > Stop_Time then + if Current_Time /= Last_Time then + Info ("simulation stopped by --stop-time"); + end if; + exit; + end if; + end loop; + + if Nbr_Threads /= 1 then + Threads.Finish; + end if; + + Call_Finalizers; + + Grt.Hooks.Call_Finish_Hooks; + + if Status = Run_Failure then + return -1; + else + return Exit_Status ; + end if; + end Simulation; + +end Grt.Processes; diff --git a/src/translate/grt/grt-processes.ads b/src/translate/grt/grt-processes.ads new file mode 100644 index 0000000..22326eb --- /dev/null +++ b/src/translate/grt/grt-processes.ads @@ -0,0 +1,260 @@ +-- GHDL Run Time (GRT) - processes. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; +with Grt.Stack2; use Grt.Stack2; +with Grt.Types; use Grt.Types; +with Grt.Signals; use Grt.Signals; +with Grt.Stacks; use Grt.Stacks; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; +with Grt.Stdio; + +package Grt.Processes is + pragma Suppress (All_Checks); + + -- Internal initialisations. + procedure Init; + + -- Do the VHDL simulation. + -- Return 0 in case of success (end of time reached). + function Simulation return Integer; + + -- Number of delta cycles. + Nbr_Delta_Cycles : Integer; + -- Number of non-delta cycles. + Nbr_Cycles : Integer; + + -- If true, the simulation should be stopped. + Break_Simulation : Boolean; + + -- If true, there is one stack for all processes. Non-sensitized + -- processes must save their state. + One_Stack : Boolean := False; + + type Process_Type is private; + -- type Process_Acc is access all Process_Type; + + -- Return the identifier of the current process. + -- During the elaboration, this is the identifier of the last process + -- being elaborated. So, this function can be used to create signal + -- drivers. + + -- Return the total number of processes and number of sensitized processes. + -- Used for statistics. + function Get_Nbr_Processes return Natural; + function Get_Nbr_Sensitized_Processes return Natural; + + -- Total number of resumed processes. + function Get_Nbr_Resumed_Processes return Natural; + + -- Disp the name of process PROC. + procedure Disp_Process_Name (Stream : Grt.Stdio.FILEs; Proc : Process_Acc); + + -- Register a process during elaboration. + -- This procedure is called by vhdl elaboration code. + procedure Ghdl_Process_Register (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + procedure Ghdl_Sensitized_Process_Register (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + procedure Ghdl_Postponed_Process_Register (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + procedure Ghdl_Postponed_Sensitized_Process_Register + (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + + -- For verilog processes. + procedure Ghdl_Finalize_Register (Instance : Instance_Acc; + Proc : Proc_Acc); + + procedure Ghdl_Initial_Register (Instance : Instance_Acc; + Proc : Proc_Acc); + procedure Ghdl_Always_Register (Instance : Instance_Acc; + Proc : Proc_Acc); + + -- Add a simple signal in the sensitivity of the last registered + -- (sensitized) process. + procedure Ghdl_Process_Add_Sensitivity (Sig : Ghdl_Signal_Ptr); + + -- Resume a process. + procedure Resume_Process (Proc : Process_Acc); + + -- Wait without timeout or sensitivity: wait; + procedure Ghdl_Process_Wait_Exit; + -- Wait for a timeout (without sensitivity): wait for X; + procedure Ghdl_Process_Wait_Timeout (Time : Std_Time); + + -- Full wait statement: + -- 1. Call Ghdl_Process_Wait_Set_Timeout (if there is a timeout) + -- 2. Call Ghdl_Process_Wait_Add_Sensitivity (for each signal) + -- 3. Call Ghdl_Process_Wait_Suspend, go to 4 if it returns true (timeout) + -- Evaluate the condition and go to 4 if true + -- Else, restart 3 + -- 4. Call Ghdl_Process_Wait_Close + + -- Add a timeout for a wait. + procedure Ghdl_Process_Wait_Set_Timeout (Time : Std_Time); + -- Add a sensitivity for a wait. + procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr); + -- Wait until timeout or sensitivity. + -- Return TRUE in case of timeout. + function Ghdl_Process_Wait_Suspend return Boolean; + -- Finish a wait statement. + procedure Ghdl_Process_Wait_Close; + + -- For one stack setups, wait_suspend is decomposed into the suspension + -- procedure and the function to get resume status. + procedure Ghdl_Process_Wait_Wait; + function Ghdl_Process_Wait_Has_Timeout return Boolean; + + -- Verilog. + procedure Ghdl_Process_Delay (Del : Ghdl_U32); + + -- Secondary stack. + function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type) + return System.Address; + function Ghdl_Stack2_Mark return Mark_Id; + procedure Ghdl_Stack2_Release (Mark : Mark_Id); + + -- Protected variables. + procedure Ghdl_Protected_Enter (Obj : System.Address); + procedure Ghdl_Protected_Leave (Obj : System.Address); + procedure Ghdl_Protected_Init (Obj : System.Address); + procedure Ghdl_Protected_Fini (Obj : System.Address); + + type Run_Handler is access function return Integer; + + -- Run HAND through a wrapper that catch some errors (in particular on + -- windows). Returns < 0 in case of error. + function Run_Through_Longjump (Hand : Run_Handler) return Integer; + pragma Import (Ada, Run_Through_Longjump, "__ghdl_run_through_longjump"); + +private + -- State of a process. + type Process_State is + ( + -- Sensitized process. Its state cannot change. + State_Sensitized, + + -- Non-sensitized process, ready to run. + State_Ready, + + -- Verilog process, being suspended. + State_Delayed, + + -- Non-sensitized process being suspended. + State_Wait, + + -- Non-sensitized process being awaked by a wait timeout. This state + -- is transcient. + -- This is necessary so that the process will exit immediately from the + -- wait statements without checking if the wait condition is true. + State_Timeout, + + -- Non-sensitized process waiting until end. + State_Dead); + + type Process_Type is record + -- Stack for the process. + -- This must be the first field of the record (and this is the only + -- part visible). + -- Must be NULL_STACK for sensitized processes. + Stack : Stacks.Stack_Type; + + -- Subprogram containing process code. + Subprg : Proc_Acc; + + -- Instance (THIS parameter) for the subprogram. + This : Instance_Acc; + + -- Name of the process. + Rti : Rtis_Addr.Rti_Context; + + -- True if the process is resumed and will be run at next cycle. + Resumed : Boolean; + + -- True if the process is postponed. + Postponed : Boolean; + + State : Process_State; + + -- Timeout value for wait. + Timeout : Std_Time; + + -- Sensitivity list while the (non-sensitized) process is waiting. + Sensitivity : Action_List_Acc; + + Timeout_Chain_Next : Process_Acc; + Timeout_Chain_Prev : Process_Acc; + end record; + + pragma Export (C, Ghdl_Process_Register, + "__ghdl_process_register"); + pragma Export (C, Ghdl_Sensitized_Process_Register, + "__ghdl_sensitized_process_register"); + pragma Export (C, Ghdl_Postponed_Process_Register, + "__ghdl_postponed_process_register"); + 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"); + + pragma Export (C, Ghdl_Process_Add_Sensitivity, + "__ghdl_process_add_sensitivity"); + + pragma Export (C, Ghdl_Process_Wait_Exit, + "__ghdl_process_wait_exit"); + pragma Export (C, Ghdl_Process_Wait_Timeout, + "__ghdl_process_wait_timeout"); + pragma Export (C, Ghdl_Process_Wait_Add_Sensitivity, + "__ghdl_process_wait_add_sensitivity"); + pragma Export (C, Ghdl_Process_Wait_Set_Timeout, + "__ghdl_process_wait_set_timeout"); + pragma Export (Ada, Ghdl_Process_Wait_Suspend, + "__ghdl_process_wait_suspend"); + pragma Export (C, Ghdl_Process_Wait_Close, + "__ghdl_process_wait_close"); + + pragma Export (C, Ghdl_Process_Delay, "__ghdl_process_delay"); + + pragma Export (C, Ghdl_Stack2_Allocate, "__ghdl_stack2_allocate"); + pragma Export (C, Ghdl_Stack2_Mark, "__ghdl_stack2_mark"); + pragma Export (C, Ghdl_Stack2_Release, "__ghdl_stack2_release"); + + pragma Export (C, Ghdl_Protected_Enter, "__ghdl_protected_enter"); + pragma Export (C, Ghdl_Protected_Leave, "__ghdl_protected_leave"); + pragma Export (C, Ghdl_Protected_Init, "__ghdl_protected_init"); + pragma Export (C, Ghdl_Protected_Fini, "__ghdl_protected_fini"); +end Grt.Processes; diff --git a/src/translate/grt/grt-readline.ads b/src/translate/grt/grt-readline.ads new file mode 100644 index 0000000..1a30839 --- /dev/null +++ b/src/translate/grt/grt-readline.ads @@ -0,0 +1,30 @@ +-- Although being part of GRT, the readline binding should be independent of +-- it (for easier reuse). + +with System; use System; + +package Grt.Readline is + subtype Fat_String is String (Positive); + type Char_Ptr is access Fat_String; + pragma Convention (C, Char_Ptr); + -- A C string (which is NUL terminated) is represented as a (thin) access + -- to a fat string (a string whose range is 1 .. integer'Last). + -- The use of an access to a constrained array allows a representation + -- compatible with C. Indexing of object of that type is safe only for + -- indexes until the NUL character. + + function Readline (Prompt : Char_Ptr) return Char_Ptr; + function Readline (Prompt : Address) return Char_Ptr; + pragma Import (C, Readline); + + procedure Free (Buf : Char_Ptr); + pragma Import (C, Free); + + procedure Add_History (Line : Char_Ptr); + pragma Import (C, Add_History); + + function Strlen (Str : Char_Ptr) return Natural; + pragma Import (C, Strlen); + + pragma Linker_Options ("-lreadline"); +end Grt.Readline; diff --git a/src/translate/grt/grt-rtis.adb b/src/translate/grt/grt-rtis.adb new file mode 100644 index 0000000..26d9764 --- /dev/null +++ b/src/translate/grt/grt-rtis.adb @@ -0,0 +1,45 @@ +-- GHDL Run Time (GRT) - Run Time Informations. +-- Copyright (C) 2013 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package body Grt.Rtis is + procedure Ghdl_Rti_Add_Package (Pkg : Ghdl_Rti_Access) is + begin + Ghdl_Rti_Top.Children (Ghdl_Rti_Top.Nbr_Child) := Pkg; + Ghdl_Rti_Top.Nbr_Child := Ghdl_Rti_Top.Nbr_Child + 1; + end Ghdl_Rti_Add_Package; + + procedure Ghdl_Rti_Add_Top (Max_Pkg : Ghdl_Index_Type; + Pkgs : Ghdl_Rti_Arr_Acc; + Top : Ghdl_Rti_Access; + Instance : Address) + is + pragma Unreferenced (Max_Pkg); + begin + Ghdl_Rti_Top.Parent := Top; + Ghdl_Rti_Top.Children := Pkgs; + Ghdl_Rti_Top_Instance := Instance; + end Ghdl_Rti_Add_Top; + +end Grt.Rtis; diff --git a/src/translate/grt/grt-rtis.ads b/src/translate/grt/grt-rtis.ads new file mode 100644 index 0000000..6bb7659 --- /dev/null +++ b/src/translate/grt/grt-rtis.ads @@ -0,0 +1,379 @@ +-- GHDL Run Time (GRT) - Run Time Informations. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Types; use Grt.Types; +with Ada.Unchecked_Conversion; + +package Grt.Rtis is + pragma Preelaborate (Grt.Rtis); + + type Ghdl_Rtik is + (Ghdl_Rtik_Top, + Ghdl_Rtik_Library, -- use scalar + Ghdl_Rtik_Package, + Ghdl_Rtik_Package_Body, + Ghdl_Rtik_Entity, + Ghdl_Rtik_Architecture, + Ghdl_Rtik_Process, + Ghdl_Rtik_Block, + Ghdl_Rtik_If_Generate, + Ghdl_Rtik_For_Generate, + Ghdl_Rtik_Instance, --10 + Ghdl_Rtik_Constant, + Ghdl_Rtik_Iterator, + Ghdl_Rtik_Variable, + Ghdl_Rtik_Signal, + Ghdl_Rtik_File, -- 15 + Ghdl_Rtik_Port, + Ghdl_Rtik_Generic, + Ghdl_Rtik_Alias, + Ghdl_Rtik_Guard, + Ghdl_Rtik_Component, -- 20 + Ghdl_Rtik_Attribute, + Ghdl_Rtik_Type_B1, -- Enum + Ghdl_Rtik_Type_E8, + Ghdl_Rtik_Type_E32, + Ghdl_Rtik_Type_I32, -- 25 Scalar + Ghdl_Rtik_Type_I64, + Ghdl_Rtik_Type_F64, + Ghdl_Rtik_Type_P32, + Ghdl_Rtik_Type_P64, + Ghdl_Rtik_Type_Access, + Ghdl_Rtik_Type_Array, + Ghdl_Rtik_Type_Record, + Ghdl_Rtik_Type_File, + Ghdl_Rtik_Subtype_Scalar, + Ghdl_Rtik_Subtype_Array, + Ghdl_Rtik_Subtype_Unconstrained_Array, + Ghdl_Rtik_Subtype_Record, + Ghdl_Rtik_Subtype_Access, + Ghdl_Rtik_Type_Protected, + Ghdl_Rtik_Element, + Ghdl_Rtik_Unit64, + Ghdl_Rtik_Unitptr, + Ghdl_Rtik_Attribute_Transaction, + Ghdl_Rtik_Attribute_Quiet, + Ghdl_Rtik_Attribute_Stable, + Ghdl_Rtik_Error); + for Ghdl_Rtik'Size use 8; + + type Ghdl_Rti_Depth is range 0 .. 255; + for Ghdl_Rti_Depth'Size use 8; + + type Ghdl_Rti_U8 is mod 2 ** 8; + for Ghdl_Rti_U8'Size use 8; + + -- This structure is common to all RTI nodes. + type Ghdl_Rti_Common is record + -- Kind of the RTI, list is above. + Kind : Ghdl_Rtik; + + Depth : Ghdl_Rti_Depth; + + -- * array types and subtypes, record types, protected types: + -- bit 0: set for complex type + -- bit 1: set for anonymous type definition + -- bit 2: set only for physical type with non-static units (time) + -- * signals: + -- bit 0-3: mode (1: linkage, 2: buffer, 3 : out, 4 : inout, 5: in) + -- bit 4-5: kind (0 : none, 1 : register, 2 : bus) + -- bit 6: set if has 'active attributes + Mode : Ghdl_Rti_U8; + + -- * Types and subtypes definition: + -- maximum depth of all RTIs referenced. + -- * Others: + -- 0 + Max_Depth : Ghdl_Rti_Depth; + end record; + + type Ghdl_Rti_Access is access all Ghdl_Rti_Common; + + -- Fat array of rti accesses. + type Ghdl_Rti_Array is array (Ghdl_Index_Type) of Ghdl_Rti_Access; + type Ghdl_Rti_Arr_Acc is access Ghdl_Rti_Array; + + subtype Ghdl_Rti_Loc is Integer_Address; + Null_Rti_Loc : constant Ghdl_Rti_Loc := 0; + + type Ghdl_C_String_Array is array (Ghdl_Index_Type) of Ghdl_C_String; + type Ghdl_C_String_Array_Ptr is access Ghdl_C_String_Array; + + type Ghdl_Rtin_Block is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Loc : Ghdl_Rti_Loc; + Parent : Ghdl_Rti_Access; + Size : Ghdl_Index_Type; + Nbr_Child : Ghdl_Index_Type; + Children : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Block_Acc is access Ghdl_Rtin_Block; + function To_Ghdl_Rtin_Block_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Block_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Block_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Object is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Loc : Ghdl_Rti_Loc; + Obj_Type : Ghdl_Rti_Access; + end record; + type Ghdl_Rtin_Object_Acc is access Ghdl_Rtin_Object; + function To_Ghdl_Rtin_Object_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Object_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Object_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Instance is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Loc : Ghdl_Rti_Loc; + Parent : Ghdl_Rti_Access; + Instance : Ghdl_Rti_Access; + end record; + type Ghdl_Rtin_Instance_Acc is access Ghdl_Rtin_Instance; + function To_Ghdl_Rtin_Instance_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Instance_Acc); + + -- Must be kept in sync with grt.types.mode_signal_type. + Ghdl_Rti_Signal_Mode_Mask : constant Ghdl_Rti_U8 := 15; + Ghdl_Rti_Signal_Mode_None : constant Ghdl_Rti_U8 := 0; + Ghdl_Rti_Signal_Mode_Linkage : constant Ghdl_Rti_U8 := 1; + Ghdl_Rti_Signal_Mode_Buffer : constant Ghdl_Rti_U8 := 2; + Ghdl_Rti_Signal_Mode_Out : constant Ghdl_Rti_U8 := 3; + 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 := 3 * 16; + Ghdl_Rti_Signal_Kind_Offset : constant Ghdl_Rti_U8 := 1 * 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; + + type Ghdl_Rtin_Component is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbr_Child : Ghdl_Index_Type; + Children : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Component_Acc is access Ghdl_Rtin_Component; + function To_Ghdl_Rtin_Component_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Component_Acc); + + type Ghdl_Rtin_Type_Enum is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbr : Ghdl_Index_Type; + -- Characters are represented as 'X', identifiers are represented as is, + -- extended identifiers are represented as is too. + Names : Ghdl_C_String_Array_Ptr; + end record; + type Ghdl_Rtin_Type_Enum_Acc is access Ghdl_Rtin_Type_Enum; + function To_Ghdl_Rtin_Type_Enum_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Enum_Acc); + + type Ghdl_Rtin_Type_Scalar is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + end record; + type Ghdl_Rtin_Type_Scalar_Acc is access Ghdl_Rtin_Type_Scalar; + function To_Ghdl_Rtin_Type_Scalar_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Scalar_Acc); + + type Ghdl_Rtin_Subtype_Scalar is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Basetype : Ghdl_Rti_Access; + Range_Loc : Ghdl_Rti_Loc; + end record; + type Ghdl_Rtin_Subtype_Scalar_Acc is access Ghdl_Rtin_Subtype_Scalar; + function To_Ghdl_Rtin_Subtype_Scalar_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Scalar_Acc); + 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, set in Mode field. + Ghdl_Rti_Type_Complex_Mask : constant Ghdl_Rti_U8 := 1; + Ghdl_Rti_Type_Complex : constant Ghdl_Rti_U8 := 1; + + -- True if the type is anonymous + Ghdl_Rti_Type_Anonymous_Mask : constant Ghdl_Rti_U8 := 2; + Ghdl_Rti_Type_Anonymous : constant Ghdl_Rti_U8 := 2; + + type Ghdl_Rtin_Type_Array is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Element : Ghdl_Rti_Access; + Nbr_Dim : Ghdl_Index_Type; + Indexes : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Type_Array_Acc is access Ghdl_Rtin_Type_Array; + function To_Ghdl_Rtin_Type_Array_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Array_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Type_Array_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Subtype_Array is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Basetype : Ghdl_Rtin_Type_Array_Acc; + Bounds : Ghdl_Rti_Loc; + Valsize : Ghdl_Rti_Loc; + Sigsize : Ghdl_Rti_Loc; + end record; + type Ghdl_Rtin_Subtype_Array_Acc is access Ghdl_Rtin_Subtype_Array; + function To_Ghdl_Rtin_Subtype_Array_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Array_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Subtype_Array_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Type_Fileacc is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Base : Ghdl_Rti_Access; + end record; + type Ghdl_Rtin_Type_Fileacc_Acc is access Ghdl_Rtin_Type_Fileacc; + function To_Ghdl_Rtin_Type_Fileacc_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Fileacc_Acc); + + type Ghdl_Rtin_Element is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Eltype : Ghdl_Rti_Access; + Val_Off : Ghdl_Index_Type; + Sig_Off : Ghdl_Index_Type; + end record; + type Ghdl_Rtin_Element_Acc is access Ghdl_Rtin_Element; + function To_Ghdl_Rtin_Element_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Element_Acc); + + type Ghdl_Rtin_Type_Record is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbrel : Ghdl_Index_Type; + Elements : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Type_Record_Acc is access Ghdl_Rtin_Type_Record; + function To_Ghdl_Rtin_Type_Record_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Record_Acc); + + type Ghdl_Rtin_Unit64 is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Value : Ghdl_I64; + end record; + type Ghdl_Rtin_Unit64_Acc is access Ghdl_Rtin_Unit64; + function To_Ghdl_Rtin_Unit64_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unit64_Acc); + + type Ghdl_Rtin_Unitptr is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Addr : Ghdl_Value_Ptr; + end record; + type Ghdl_Rtin_Unitptr_Acc is access Ghdl_Rtin_Unitptr; + function To_Ghdl_Rtin_Unitptr_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unitptr_Acc); + + -- Mode field is set to 4 if units value is per address. Otherwise, + -- mode is 0. + type Ghdl_Rtin_Type_Physical is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbr : Ghdl_Index_Type; + Units : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Type_Physical_Acc is access Ghdl_Rtin_Type_Physical; + function To_Ghdl_Rtin_Type_Physical_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Physical_Acc); + + -- Instance linkage. + + -- At the beginning of a component structure (or the object for a direct + -- instantiation), there is a Ghdl_Component_Link_Type record. + -- These record contains a pointer to the instance (down link), + -- and RTIS to the statement and its parent (up link). + type Ghdl_Component_Link_Type; + type Ghdl_Component_Link_Acc is access Ghdl_Component_Link_Type; + + -- At the beginning of an entity structure, there is a Ghdl_Link_Type, + -- which contains the RTI for the architecture (down-link) and a pointer + -- to the instantiation object (up-link). + type Ghdl_Entity_Link_Type is record + Rti : Ghdl_Rti_Access; + Parent : Ghdl_Component_Link_Acc; + end record; + + type Ghdl_Entity_Link_Acc is access Ghdl_Entity_Link_Type; + + function To_Ghdl_Entity_Link_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Entity_Link_Acc); + + type Ghdl_Component_Link_Type is record + Instance : Ghdl_Entity_Link_Acc; + Stmt : Ghdl_Rti_Access; + end record; + + function To_Ghdl_Component_Link_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Component_Link_Acc); + + -- TOP rti. + Ghdl_Rti_Top : Ghdl_Rtin_Block := + (Common => (Ghdl_Rtik_Top, 0, 0, 0), + Name => null, + Loc => Null_Rti_Loc, + Parent => null, + Size => 0, + Nbr_Child => 0, + Children => null); + + -- Address of the top instance. + Ghdl_Rti_Top_Instance : Address; + + -- Instances have a pointer to their RTI at offset 0. + type Ghdl_Rti_Acc_Acc is access Ghdl_Rti_Access; + function To_Ghdl_Rti_Acc_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Rti_Acc_Acc); + + function To_Address is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Address); + + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Rti_Access); + + procedure Ghdl_Rti_Add_Top (Max_Pkg : Ghdl_Index_Type; + Pkgs : Ghdl_Rti_Arr_Acc; + Top : Ghdl_Rti_Access; + Instance : Address); + pragma Export (C, Ghdl_Rti_Add_Top, "__ghdl_rti_add_top"); + + -- Register a package + procedure Ghdl_Rti_Add_Package (Pkg : Ghdl_Rti_Access); + pragma Export (C, Ghdl_Rti_Add_Package, "__ghdl_rti_add_package"); +end Grt.Rtis; diff --git a/src/translate/grt/grt-rtis_addr.adb b/src/translate/grt/grt-rtis_addr.adb new file mode 100644 index 0000000..70a0e21 --- /dev/null +++ b/src/translate/grt/grt-rtis_addr.adb @@ -0,0 +1,299 @@ +-- GHDL Run Time (GRT) - RTI address handling. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; + +package body Grt.Rtis_Addr is + function "+" (L : Address; R : Ghdl_Rti_Loc) return Address + is + begin + return To_Address (To_Integer (L) + R); + end "+"; + + function "+" (L : Address; R : Ghdl_Index_Type) return Address + is + begin + return To_Address (To_Integer (L) + Integer_Address (R)); + end "+"; + + function "-" (L : Address; R : Ghdl_Rti_Loc) return Address + is + begin + return To_Address (To_Integer (L) - R); + end "-"; + + function Align (L : Address; R : Ghdl_Rti_Loc) return Address + is + Nad : Integer_Address; + begin + Nad := To_Integer (L + (R - 1)); + return To_Address (Nad - (Nad mod R)); + end Align; + + function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context + is + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Ctxt.Block.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + return (Base => Ctxt.Base - Blk.Loc, + Block => Blk.Parent); + when Ghdl_Rtik_Architecture => + if Blk.Loc /= Null_Rti_Loc then + Internal_Error ("get_parent_context(3)"); + end if; + return (Base => Ctxt.Base + Blk.Loc, + Block => Blk.Parent); + when Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate => + declare + Nbase : Address; + Parent : Ghdl_Rti_Access; + Blk1 : Ghdl_Rtin_Block_Acc; + begin + -- Read the pointer to the parent. + -- This is the first field. + Nbase := To_Addr_Acc (Ctxt.Base).all; + -- Since the parent may be a grant-parent, adjust + -- the base. + Parent := Blk.Parent; + loop + case Parent.Kind is + when Ghdl_Rtik_Architecture + | Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate => + exit; + when Ghdl_Rtik_Block => + Blk1 := To_Ghdl_Rtin_Block_Acc (Parent); + Nbase := Nbase + Blk1.Loc; + Parent := Blk1.Parent; + when others => + Internal_Error ("get_parent_context(2)"); + end case; + end loop; + return (Base => Nbase, + Block => Blk.Parent); + end; + when others => + Internal_Error ("get_parent_context(1)"); + end case; + end Get_Parent_Context; + + procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc; + Ctxt : out Rti_Context; + Stmt : out Ghdl_Rti_Access) + is + Obj : Ghdl_Rtin_Instance_Acc; + begin + if Link.Parent = null then + -- Top entity. + Stmt := null; + Ctxt := (Base => Null_Address, Block => null); + else + Stmt := Link.Parent.Stmt; + Obj := To_Ghdl_Rtin_Instance_Acc (Stmt); + Ctxt := (Base => Link.Parent.all'Address - Obj.Loc, + Block => Obj.Parent); + end if; + end Get_Instance_Link; + + function Loc_To_Addr (Depth : Ghdl_Rti_Depth; + Loc : Ghdl_Rti_Loc; + Ctxt : Rti_Context) + return Address + is + Cur_Ctxt : Rti_Context; + Nctxt : Rti_Context; + begin + if Depth = 0 then + return To_Address (Loc); + elsif Ctxt.Block.Depth = Depth then + --Addr := Base + Storage_Offset (Obj.Loc.Off); + return Ctxt.Base + Loc; + else + if Ctxt.Block.Depth < Depth then + Internal_Error ("loc_to_addr"); + end if; + Cur_Ctxt := Ctxt; + loop + Nctxt := Get_Parent_Context (Cur_Ctxt); + if Nctxt.Block.Depth = Depth then + return Nctxt.Base + Loc; + end if; + Cur_Ctxt := Nctxt; + end loop; + end if; + end Loc_To_Addr; + + function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access) + return Ghdl_Index_Type + is + begin + case Base_Type.Kind is + when Ghdl_Rtik_Type_B1 => + return Rng.B1.Len; + when Ghdl_Rtik_Type_E8 => + return Rng.E8.Len; + when Ghdl_Rtik_Type_E32 => + return Rng.E32.Len; + when Ghdl_Rtik_Type_I32 => + return Rng.I32.Len; + when others => + Internal_Error ("range_to_length"); + end case; + end Range_To_Length; + + function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context) + return Ghdl_Index_Type + is + Iter_Type : Ghdl_Rtin_Subtype_Scalar_Acc; + Rng : Ghdl_Range_Ptr; + begin + Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc + (To_Ghdl_Rtin_Object_Acc (Blk.Children (0)).Obj_Type); + if Iter_Type.Common.Kind /= Ghdl_Rtik_Subtype_Scalar then + Internal_Error ("get_for_generate_length(1)"); + end if; + Rng := To_Ghdl_Range_Ptr + (Loc_To_Addr (Iter_Type.Common.Depth, Iter_Type.Range_Loc, Ctxt)); + return Range_To_Length (Rng, Iter_Type.Basetype); + end Get_For_Generate_Length; + + procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc; + Ctxt : Rti_Context; + Sub_Ctxt : out Rti_Context) + is + Inst_Addr : Address; + Inst_Base : Address; + begin + -- Address of the field containing the address of the instance. + Inst_Addr := Ctxt.Base + Inst.Loc; + -- Read sub instance address. + Inst_Base := To_Addr_Acc (Inst_Addr).all; + -- Read instance RTI. + if Inst_Base = Null_Address then + Sub_Ctxt := (Base => Null_Address, Block => null); + else + Sub_Ctxt := (Base => Inst_Base, + Block => To_Ghdl_Rti_Acc_Acc (Inst_Base).all); + end if; + end Get_Instance_Context; + + procedure Bound_To_Range (Bounds_Addr : Address; + Def : Ghdl_Rtin_Type_Array_Acc; + Res : out Ghdl_Range_Array) + is + Bounds : Address; + + procedure Align (A : Ghdl_Index_Type) is + begin + Bounds := Align (Bounds, Ghdl_Rti_Loc (A)); + end Align; + + procedure Update (S : Ghdl_Index_Type) is + begin + Bounds := Bounds + (S / Storage_Unit); + end Update; + + Idx_Def : Ghdl_Rti_Access; + begin + if Res'Length /= Def.Nbr_Dim or else Res'First /= 0 then + Internal_Error ("disp_rti.bound_to_range"); + end if; + + Bounds := Bounds_Addr; + + for I in 0 .. Def.Nbr_Dim - 1 loop + Idx_Def := Def.Indexes (I); + + if Bounds = Null_Address then + Res (I) := null; + else + Idx_Def := Get_Base_Type (Idx_Def); + case Idx_Def.Kind is + when Ghdl_Rtik_Type_I32 => + Align (Ghdl_Range_I32'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_I32'Size); + when Ghdl_Rtik_Type_E8 => + Align (Ghdl_Range_E8'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_E8'Size); + when Ghdl_Rtik_Type_E32 => + Align (Ghdl_Range_E32'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_E32'Size); + when others => + -- Bounds are not known anymore. + Bounds := Null_Address; + end case; + end if; + end loop; + end Bound_To_Range; + + function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access + is + begin + case Atype.Kind is + when Ghdl_Rtik_Subtype_Scalar => + return To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype; + when Ghdl_Rtik_Subtype_Array => + return To_Ghdl_Rti_Access + (To_Ghdl_Rtin_Subtype_Array_Acc (Atype).Basetype); + when Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + return Atype; + when others => + Internal_Error ("rtis_addr.get_base_type"); + end case; + end Get_Base_Type; + + function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean + is + begin + return (Atype.Mode and Ghdl_Rti_Type_Complex_Mask) + = Ghdl_Rti_Type_Complex; + end Rti_Complex_Type; + + function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean + is + begin + return (Atype.Mode and Ghdl_Rti_Type_Anonymous_Mask) + = Ghdl_Rti_Type_Anonymous; + end Rti_Anonymous_Type; + + function Get_Top_Context return Rti_Context + is + Ctxt : Rti_Context; + begin + Ctxt := (Base => Ghdl_Rti_Top_Instance, + Block => Ghdl_Rti_Top.Parent); + return Ctxt; + end Get_Top_Context; + +end Grt.Rtis_Addr; diff --git a/src/translate/grt/grt-rtis_addr.ads b/src/translate/grt/grt-rtis_addr.ads new file mode 100644 index 0000000..3fa2792 --- /dev/null +++ b/src/translate/grt/grt-rtis_addr.ads @@ -0,0 +1,110 @@ +-- GHDL Run Time (GRT) - RTI address handling. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Ada.Unchecked_Conversion; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +-- Addresses handling. +package Grt.Rtis_Addr is + function "+" (L : Address; R : Ghdl_Rti_Loc) return Address; + function "+" (L : Address; R : Ghdl_Index_Type) return Address; + + function "-" (L : Address; R : Ghdl_Rti_Loc) return Address; + + function Align (L : Address; R : Ghdl_Rti_Loc) return Address; + + -- An RTI context contains a pointer (BASE) to or into an instance. + -- BLOCK describes data being pointed. If a reference is made to a field + -- described by a parent of BLOCK, BASE must be modified. + type Rti_Context is record + Base : Address; + Block : Ghdl_Rti_Access; + end record; + + Null_Context : constant Rti_Context; + + -- Access to an address. + type Addr_Acc is access Address; + function To_Addr_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Addr_Acc); + + type Ghdl_Index_Acc is access Ghdl_Index_Type; + function To_Ghdl_Index_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Index_Acc); + + -- Get the parent context of CTXT. + -- The parent of an architecture is its entity. + function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context; + + -- From an entity link, extract context and instantiation statement. + procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc; + Ctxt : out Rti_Context; + Stmt : out Ghdl_Rti_Access); + + -- Convert a location to an address. + function Loc_To_Addr (Depth : Ghdl_Rti_Depth; + Loc : Ghdl_Rti_Loc; + Ctxt : Rti_Context) + return Address; + + -- Get the length of for_generate BLK. + function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context) + return Ghdl_Index_Type; + + -- Get the context of instance INST. + procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc; + Ctxt : Rti_Context; + Sub_Ctxt : out Rti_Context); + + -- Extract range of every dimension from bounds. + procedure Bound_To_Range (Bounds_Addr : Address; + Def : Ghdl_Rtin_Type_Array_Acc; + Res : out Ghdl_Range_Array); + + function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access) + return Ghdl_Index_Type; + + -- Get the base type of ATYPE. + function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access; + + -- Return true iff ATYPE is anonymous. + -- Valid only on type and subtype definitions. + function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean; + pragma Inline (Rti_Anonymous_Type); + + -- Return true iff ATYPE is complex. + -- Valid only on type and subtype definitions. + function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean; + pragma Inline (Rti_Complex_Type); + + -- Get the top context. + function Get_Top_Context return Rti_Context; + +private + Null_Context : constant Rti_Context := (Base => Null_Address, + Block => null); +end Grt.Rtis_Addr; diff --git a/src/translate/grt/grt-rtis_binding.ads b/src/translate/grt/grt-rtis_binding.ads new file mode 100644 index 0000000..7e90eea --- /dev/null +++ b/src/translate/grt/grt-rtis_binding.ads @@ -0,0 +1,67 @@ +-- GHDL Run Time (GRT) - Well known RTIs. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Rtis; use Grt.Rtis; + +-- Set RTI_ptr defined in grt.rtis_types. + +package Grt.Rtis_Binding is + pragma Preelaborate (Grt.Rtis_Binding); + + -- Define and set bit and boolean RTIs. + Std_Standard_Bit_RTI : aliased Ghdl_Rti_Common; + + Std_Standard_Boolean_RTI : aliased Ghdl_Rti_Common; + + pragma Import (C, Std_Standard_Bit_RTI, + "std__standard__bit__RTI"); + + pragma Import (C, Std_Standard_Boolean_RTI, + "std__standard__boolean__RTI"); + + Std_Standard_Bit_RTI_Ptr : Ghdl_Rti_Access + := Std_Standard_Bit_RTI'Access; + + Std_Standard_Boolean_RTI_Ptr : Ghdl_Rti_Access + := Std_Standard_Boolean_RTI'Access; + + pragma Export (C, Std_Standard_Bit_RTI_Ptr, + "std__standard__bit__RTI_ptr"); + + pragma Export (C, Std_Standard_Boolean_RTI_Ptr, + "std__standard__boolean__RTI_ptr"); + + + -- Define and set Resolved_Resolv_Ptr. + procedure Ieee_Std_Logic_1164_Resolved_RESOLV; + pragma Import (C, Ieee_Std_Logic_1164_Resolved_RESOLV, + "ieee__std_logic_1164__resolved_RESOLV"); + + Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address := + Ieee_Std_Logic_1164_Resolved_RESOLV'Address; + pragma Export (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr, + "ieee__std_logic_1164__resolved_RESOLV_ptr"); + +end Grt.Rtis_Binding; diff --git a/src/translate/grt/grt-rtis_types.adb b/src/translate/grt/grt-rtis_types.adb new file mode 100644 index 0000000..f22a309 --- /dev/null +++ b/src/translate/grt/grt-rtis_types.adb @@ -0,0 +1,118 @@ +-- GHDL Run Time (GRT) - Well known RTI types. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Astdio; +with Grt.Avhpi; use Grt.Avhpi; + +package body Grt.Rtis_Types is + + procedure Avhpi_Error (Err : AvhpiErrorT) + is + use Grt.Astdio; + pragma Unreferenced (Err); + begin + Put_Line ("grt.rtis_utils.Avhpi_Error!"); + end Avhpi_Error; + + -- Extract std_ulogic type. + procedure Search_Types (Pack : VhpiHandleT) + is + Decl_It : VhpiHandleT; + Decl : VhpiHandleT; + + Error : AvhpiErrorT; + Name : String (1 .. 16); + Name_Len : Natural; + Rti : Ghdl_Rti_Access; + begin + Vhpi_Get_Str (VhpiLibLogicalNameP, Pack, Name, Name_Len); + if not (Name_Len = 4 and then Name (1 .. 4)= "ieee") then + return; + end if; + + Vhpi_Iterator (VhpiDecls, Pack, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + -- Extract packages. + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + if Vhpi_Get_Kind (Decl) = VhpiEnumTypeDeclK then + Vhpi_Get_Str (VhpiNameP, Decl, Name, Name_Len); + Rti := Avhpi_Get_Rti (Decl); + if Name_Len = 10 and then Name (1 .. 10) = "std_ulogic" then + Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr := Rti; + end if; + end if; + end loop; + end Search_Types; + + procedure Search_Packages + is + Pack : VhpiHandleT; + Pack_It : VhpiHandleT; + + Error : AvhpiErrorT; + Name : String (1 .. 16); + Name_Len : Natural; + begin + Get_Package_Inst (Pack_It); + + -- Extract packages. + loop + Vhpi_Scan (Pack_It, Pack, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Vhpi_Get_Str (VhpiNameP, Pack, Name, Name_Len); + if Name_Len = 14 and then Name (1 .. 14) = "std_logic_1164" then + Search_Types (Pack); + end if; + end loop; + end Search_Packages; + + Search_Types_RTI_Done : Boolean := False; + + procedure Search_Types_RTI is + begin + if Search_Types_RTI_Done then + return; + else + Search_Types_RTI_Done := True; + end if; + + Search_Packages; + end Search_Types_RTI; +end Grt.Rtis_Types; diff --git a/src/translate/grt/grt-rtis_types.ads b/src/translate/grt/grt-rtis_types.ads new file mode 100644 index 0000000..f64b173 --- /dev/null +++ b/src/translate/grt/grt-rtis_types.ads @@ -0,0 +1,55 @@ +-- GHDL Run Time (GRT) - Well known RTI types. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Rtis; use Grt.Rtis; + +-- This package allow access to RTIs of some types. +-- This is used to recognize some VHDL logic types. +-- This is also used by grt.signals to set types of some implicit signals +-- (such as 'stable or 'transation). + +package Grt.Rtis_Types is + -- RTIs for some logic types. + Std_Standard_Bit_RTI_Ptr : Ghdl_Rti_Access; + + Std_Standard_Boolean_RTI_Ptr : Ghdl_Rti_Access; + + -- std_ulogic. + -- A VHDL may not contain ieee.std_logic_1164 package. So, this RTI + -- must be dynamicaly searched. + Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr : Ghdl_Rti_Access := null; + + -- Search RTI for types. + -- If a type is not found, its RTI is set to null. + -- If this procedure has already been called, then this is a noop. + procedure Search_Types_RTI; +private + -- These are set either by grt.rtis_binding or by ghdlrun. + -- This is not very clean... + pragma Import (C, Std_Standard_Bit_RTI_Ptr, + "std__standard__bit__RTI_ptr"); + + pragma Import (C, Std_Standard_Boolean_RTI_Ptr, + "std__standard__boolean__RTI_ptr"); +end Grt.Rtis_Types; diff --git a/src/translate/grt/grt-rtis_utils.adb b/src/translate/grt/grt-rtis_utils.adb new file mode 100644 index 0000000..0d4328e --- /dev/null +++ b/src/translate/grt/grt-rtis_utils.adb @@ -0,0 +1,660 @@ +-- GHDL Run Time (GRT) - RTI utilities. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +--with Grt.Disp; use Grt.Disp; +with Grt.Errors; use Grt.Errors; + +package body Grt.Rtis_Utils is + + function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result + is + function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result; + + function Traverse_Blocks_1 (Ctxt : Rti_Context) return Traverse_Result + is + Blk : Ghdl_Rtin_Block_Acc; + + Res : Traverse_Result; + Nctxt : Rti_Context; + Index : Ghdl_Index_Type; + Child : Ghdl_Rti_Access; + begin + Res := Process (Ctxt, Ctxt.Block); + if Res /= Traverse_Ok then + return Res; + end if; + + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + Index := 0; + while Index < Blk.Nbr_Child loop + Child := Blk.Children (Index); + Index := Index + 1; + case Child.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + declare + Nblk : Ghdl_Rtin_Block_Acc; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := (Base => Ctxt.Base + Nblk.Loc, + Block => Child); + Res := Traverse_Blocks_1 (Nctxt); + end; + when Ghdl_Rtik_For_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc; + Length : Ghdl_Index_Type; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := + (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + Length := Get_For_Generate_Length (Nblk, Ctxt); + for I in 1 .. Length loop + Res := Traverse_Blocks_1 (Nctxt); + exit when Res = Traverse_Stop; + Nctxt.Base := Nctxt.Base + Nblk.Size; + end loop; + end; + when Ghdl_Rtik_If_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := + (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + if Nctxt.Base /= Null_Address then + Res := Traverse_Blocks_1 (Nctxt); + end if; + end; + when Ghdl_Rtik_Instance => + Res := Process (Ctxt, Child); + if Res = Traverse_Ok then + declare + Obj : Ghdl_Rtin_Instance_Acc; + begin + Obj := To_Ghdl_Rtin_Instance_Acc (Child); + + Get_Instance_Context (Obj, Ctxt, Nctxt); + if Nctxt /= Null_Context then + Res := Traverse_Instance (Nctxt); + end if; + end; + end if; + when Ghdl_Rtik_Package + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture => + Internal_Error ("traverse_blocks"); + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Res := Process (Ctxt, Child); + when others => + null; + end case; + exit when Res = Traverse_Stop; + end loop; + + return Res; + end Traverse_Blocks_1; + + function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result + is + Blk : Ghdl_Rtin_Block_Acc; + + Res : Traverse_Result; + Nctxt : Rti_Context; + + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + -- The entity. + Res := Traverse_Blocks_1 (Nctxt); + if Res /= Traverse_Stop then + -- The architecture. + Res := Traverse_Blocks_1 (Ctxt); + end if; + when Ghdl_Rtik_Package_Body => + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + Res := Traverse_Blocks_1 (Nctxt); + when others => + Internal_Error ("traverse_blocks"); + end case; + return Res; + end Traverse_Instance; + begin + return Traverse_Instance (Ctxt); + end Traverse_Blocks; + + -- Disp value stored at ADDR and whose type is described by RTI. + procedure Get_Enum_Value + (Vstr : in out Vstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Append (Vstr, Enum_Rti.Names (Val)); + end Get_Enum_Value; + + + procedure Foreach_Scalar (Ctxt : Rti_Context; + Obj_Type : Ghdl_Rti_Access; + Obj_Addr : Address; + Is_Sig : Boolean; + Param : Param_Type) + is + -- Current address. + Addr : Address; + + Name : Vstring; + + procedure Handle_Any (Rti : Ghdl_Rti_Access); + + procedure Handle_Scalar (Rti : Ghdl_Rti_Access) + is + procedure Update (S : Ghdl_Index_Type) is + begin + Addr := Addr + (S / Storage_Unit); + end Update; + begin + Process (Addr, Name, Rti, Param); + + if Is_Sig then + Update (Address'Size); + else + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + Update (32); + when Ghdl_Rtik_Type_E8 => + Update (8); + when Ghdl_Rtik_Type_E32 => + Update (32); + when Ghdl_Rtik_Type_B1 => + Update (8); + when Ghdl_Rtik_Type_F64 => + Update (64); + when Ghdl_Rtik_Type_P64 => + Update (64); + when others => + Internal_Error ("handle_scalar"); + end case; + end if; + end Handle_Scalar; + + procedure Range_Pos_To_Val (Rti : Ghdl_Rti_Access; + Rng : Ghdl_Range_Ptr; + Pos : Ghdl_Index_Type; + Val : out Value_Union) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + case Rng.I32.Dir is + when Dir_To => + Val.I32 := Rng.I32.Left + Ghdl_I32 (Pos); + when Dir_Downto => + Val.I32 := Rng.I32.Left - Ghdl_I32 (Pos); + end case; + when Ghdl_Rtik_Type_E8 => + case Rng.E8.Dir is + when Dir_To => + Val.E8 := Rng.E8.Left + Ghdl_E8 (Pos); + when Dir_Downto => + Val.E8 := Rng.E8.Left - Ghdl_E8 (Pos); + end case; + when Ghdl_Rtik_Type_E32 => + case Rng.E32.Dir is + when Dir_To => + Val.E32 := Rng.E32.Left + Ghdl_E32 (Pos); + when Dir_Downto => + Val.E32 := Rng.E32.Left - Ghdl_E32 (Pos); + end case; + when Ghdl_Rtik_Type_B1 => + case Pos is + when 0 => + Val.B1 := Rng.B1.Left; + when 1 => + Val.B1 := Rng.B1.Right; + when others => + Val.B1 := False; + end case; + when others => + Internal_Error ("grt.rtis_utils.range_pos_to_val"); + end case; + end Range_Pos_To_Val; + + procedure Pos_To_Vstring + (Vstr : in out Vstring; + Rti : Ghdl_Rti_Access; + Rng : Ghdl_Range_Ptr; + Pos : Ghdl_Index_Type) + is + V : Value_Union; + begin + Range_Pos_To_Val (Rti, Rng, Pos, V); + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, V.I32); + Append (Vstr, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value (Vstr, Rti, Ghdl_B1'Pos (V.B1)); + when others => + Append (Vstr, '?'); + end case; + end Pos_To_Vstring; + + procedure Handle_Array_1 (El_Rti : Ghdl_Rti_Access; + Rngs : Ghdl_Range_Array; + Rtis : Ghdl_Rti_Arr_Acc; + Index : Ghdl_Index_Type) + is + Len : Ghdl_Index_Type; + P : Natural; + Base_Type : Ghdl_Rti_Access; + begin + P := Length (Name); + if Index = 0 then + Append (Name, '('); + else + Append (Name, ','); + end if; + + Base_Type := Get_Base_Type (Rtis (Index)); + Len := Range_To_Length (Rngs (Index), Base_Type); + + for I in 1 .. Len loop + Pos_To_Vstring (Name, Base_Type, Rngs (Index), I - 1); + if Index = Rngs'Last then + Append (Name, ')'); + Handle_Any (El_Rti); + else + Handle_Array_1 (El_Rti, Rngs, Rtis, Index + 1); + end if; + Truncate (Name, P + 1); + end loop; + Truncate (Name, P); + end Handle_Array_1; + + procedure Handle_Array (Rti : Ghdl_Rtin_Type_Array_Acc; + Vals : Ghdl_Uc_Array_Acc) + is + Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; + Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); + begin + Bound_To_Range (Vals.Bounds, Rti, Rngs); + Addr := Vals.Base; + Handle_Array_1 (Rti.Element, Rngs, Rti.Indexes, 0); + end Handle_Array; + + procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc) + is + El : Ghdl_Rtin_Element_Acc; + Obj_Addr : Address; + Last_Addr : Address; + P : Natural; + begin + P := Length (Name); + Obj_Addr := Addr; + Last_Addr := Addr; + for I in 1 .. Rti.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); + if Is_Sig then + Addr := Obj_Addr + El.Sig_Off; + else + Addr := Obj_Addr + El.Val_Off; + end if; + if Rti_Complex_Type (El.Eltype) then + Addr := Obj_Addr + To_Ghdl_Index_Acc (Addr).all; + end if; + Append (Name, '.'); + Append (Name, El.Name); + Handle_Any (El.Eltype); + if Addr > Last_Addr then + Last_Addr := Addr; + end if; + Truncate (Name, P); + end loop; + Addr := Last_Addr; + end Handle_Record; + + procedure Handle_Any (Rti : Ghdl_Rti_Access) is + begin + case Rti.Kind is + when Ghdl_Rtik_Subtype_Scalar => + Handle_Scalar (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + Handle_Scalar (Rti); + when Ghdl_Rtik_Type_Array => + Handle_Array (To_Ghdl_Rtin_Type_Array_Acc (Rti), + To_Ghdl_Uc_Array_Acc (Addr)); + when Ghdl_Rtik_Subtype_Array => + declare + St : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); + Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0); + end; +-- when Ghdl_Rtik_Type_File => +-- declare +-- Vptr : Ghdl_Value_Ptr; +-- begin +-- Vptr := To_Ghdl_Value_Ptr (Obj); +-- Put (Stream, "File#"); +-- Put_I32 (Stream, Vptr.I32); +-- -- FIXME: update OBJ (not very useful since never in a +-- -- composite type). +-- end; + when Ghdl_Rtik_Type_Record => + Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti)); + when others => + Internal_Error ("grt.rtis_utils.foreach_scalar.handle_any"); + end case; + end Handle_Any; + begin + if Rti_Complex_Type (Obj_Type) then + Addr := To_Addr_Acc (Obj_Addr).all; + else + Addr := Obj_Addr; + end if; + Handle_Any (Obj_Type); + Free (Name); + end Foreach_Scalar; + + procedure Get_Value (Str : in out Vstring; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access) + is + begin + case Type_Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Append (Str, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value + (Str, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1))); + when Ghdl_Rtik_Type_F64 => + declare + S : String (1 .. 32); + L : Integer; + + function Snprintf_G (Cstr : Address; + Size : Natural; + Arg : Ghdl_F64) + return Integer; + pragma Import (C, Snprintf_G, "__ghdl_snprintf_g"); + + begin + L := Snprintf_G (S'Address, S'Length, Value.F64); + if L < 0 then + -- FIXME. + Append (Str, "?"); + else + Append (Str, S (1 .. L)); + end if; + end; + when Ghdl_Rtik_Type_P32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Append (Str, S (F .. S'Last)); + Append + (Str, Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0))); + end; + when Ghdl_Rtik_Type_P64 => + declare + S : String (1 .. 21); + F : Natural; + begin + To_String (S, F, Value.I64); + Append (Str, S (F .. S'Last)); + Append + (Str, Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0))); + end; + when others => + Internal_Error ("grt.rtis_utils.get_value"); + end case; + end Get_Value; + + procedure Disp_Value (Stream : FILEs; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access) + is + Name : Vstring; + begin + Rtis_Utils.Get_Value (Name, Value, Type_Rti); + Put (Stream, Name); + Free (Name); + end Disp_Value; + + function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access) + return Ghdl_C_String + is + begin + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + return To_Ghdl_Rtin_Unit64_Acc (Unit).Name; + when Ghdl_Rtik_Unitptr => + return To_Ghdl_Rtin_Unitptr_Acc (Unit).Name; + when others => + Internal_Error ("rtis_utils.physical_unit_name"); + end case; + end Get_Physical_Unit_Name; + + function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access; + Type_Rti : Ghdl_Rti_Access) + return Ghdl_I64 is + begin + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + return To_Ghdl_Rtin_Unit64_Acc (Unit).Value; + when Ghdl_Rtik_Unitptr => + case Type_Rti.Kind is + when Ghdl_Rtik_Type_P64 => + return To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64; + when Ghdl_Rtik_Type_P32 => + return Ghdl_I64 + (To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32); + when others => + Internal_Error ("get_physical_unit_value(1)"); + end case; + when others => + Internal_Error ("get_physical_unit_value(2)"); + end case; + end Get_Physical_Unit_Value; + + procedure Get_Enum_Value + (Rstr : in out Rstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Prepend (Rstr, Enum_Rti.Names (Val)); + end Get_Enum_Value; + + + procedure Get_Value (Rstr : in out Rstring; + Addr : Address; + Type_Rti : Ghdl_Rti_Access) + is + Value : constant Ghdl_Value_Ptr := To_Ghdl_Value_Ptr (Addr); + begin + case Type_Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Prepend (Rstr, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value + (Rstr, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1))); + when others => + Internal_Error ("grt.rtis_utils.get_value(rstr)"); + end case; + end Get_Value; + + procedure Get_Path_Name (Rstr : in out Rstring; + Last_Ctxt : Rti_Context; + Sep : Character; + Is_Instance : Boolean := True) + is + Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context; + begin + Ctxt := Last_Ctxt; + loop + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Ctxt.Block.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate => + Prepend (Rstr, Blk.Name); + Prepend (Rstr, Sep); + Ctxt := Get_Parent_Context (Ctxt); + when Ghdl_Rtik_Entity => + declare + Link : Ghdl_Entity_Link_Acc; + begin + Link := To_Ghdl_Entity_Link_Acc (Ctxt.Base); + Ctxt := (Base => Ctxt.Base, + Block => Link.Rti); + if Ctxt.Block = null then + -- Process in an entity. + -- FIXME: check. + Prepend (Rstr, Blk.Name); + return; + end if; + end; + when Ghdl_Rtik_Architecture => + declare + Entity_Ctxt: Rti_Context; + Link : Ghdl_Entity_Link_Acc; + Parent_Inst : Ghdl_Rti_Access; + begin + -- Architecture name. + if Is_Instance then + Prepend (Rstr, ')'); + Prepend (Rstr, Blk.Name); + Prepend (Rstr, '('); + end if; + + Entity_Ctxt := Get_Parent_Context (Ctxt); + + -- Instance parent. + Link := To_Ghdl_Entity_Link_Acc (Entity_Ctxt.Base); + Get_Instance_Link (Link, Ctxt, Parent_Inst); + + -- Add entity name. + if Is_Instance or Parent_Inst = null then + Prepend (Rstr, + To_Ghdl_Rtin_Block_Acc (Entity_Ctxt.Block).Name); + end if; + + if Parent_Inst = null then + -- Top reached. + Prepend (Rstr, Sep); + return; + else + -- Instantiation statement label. + if Is_Instance then + Prepend (Rstr, '@'); + end if; + Prepend (Rstr, + To_Ghdl_Rtin_Object_Acc (Parent_Inst).Name); + Prepend (Rstr, Sep); + end if; + end; + when Ghdl_Rtik_For_Generate => + declare + Iter : Ghdl_Rtin_Object_Acc; + Addr : Address; + begin + Prepend (Rstr, ')'); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); + Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type)); + Prepend (Rstr, '('); + Prepend (Rstr, Blk.Name); + Prepend (Rstr, Sep); + Ctxt := Get_Parent_Context (Ctxt); + end; + when others => + Internal_Error ("grt.rtis_utils.get_path_name"); + end case; + end loop; + end Get_Path_Name; + + procedure Put (Stream : FILEs; Ctxt : Rti_Context) + is + Rstr : Rstring; + begin + Get_Path_Name (Rstr, Ctxt, '.'); + Put (Stream, Rstr); + Free (Rstr); + end Put; + +end Grt.Rtis_Utils; diff --git a/src/translate/grt/grt-rtis_utils.ads b/src/translate/grt/grt-rtis_utils.ads new file mode 100644 index 0000000..10c1a0f --- /dev/null +++ b/src/translate/grt/grt-rtis_utils.ads @@ -0,0 +1,92 @@ +-- GHDL Run Time (GRT) - RTI utilities. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Stdio; use Grt.Stdio; + +package Grt.Rtis_Utils is + -- Action to perform after a node was handled by the user function: + -- Traverse_Ok: continue to process. + -- Traverse_Skip: do not traverse children. + -- 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 + with function Process (Ctxt : Rti_Context; + Obj : Ghdl_Rti_Access) + return Traverse_Result; + 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; + Param : Param_Type); + procedure Foreach_Scalar (Ctxt : Rti_Context; + Obj_Type : Ghdl_Rti_Access; + Obj_Addr : Address; + Is_Sig : Boolean; + Param : Param_Type); + + procedure Get_Value (Str : in out Vstring; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access); + + -- Get the name of a physical unit. + function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access) + return Ghdl_C_String; + + -- Get the value of a physical unit. + function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access; + Type_Rti : Ghdl_Rti_Access) + return Ghdl_I64; + + -- Disp a value. + procedure Disp_Value (Stream : FILEs; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access); + + -- Get context as a path name. + -- If IS_INSTANCE is true, the architecture name of entities is added. + procedure Get_Path_Name (Rstr : in out Rstring; + Last_Ctxt : Rti_Context; + Sep : Character; + Is_Instance : Boolean := True); + + -- Disp a context as a path. + procedure Put (Stream : FILEs; Ctxt : Rti_Context); +end Grt.Rtis_Utils; diff --git a/src/translate/grt/grt-sdf.adb b/src/translate/grt/grt-sdf.adb new file mode 100644 index 0000000..73534e3 --- /dev/null +++ b/src/translate/grt/grt-sdf.adb @@ -0,0 +1,1389 @@ +-- GHDL Run Time (GRT) - SDF parser. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Errors; use Grt.Errors; +with Ada.Characters.Latin_1; +with Ada.Unchecked_Deallocation; +with Grt.Vital_Annotate; + +package body Grt.Sdf is + EOT : constant Character := Character'Val (4); + + type Sdf_Token_Type is + ( + Tok_Oparen, -- ( + Tok_Cparen, -- ) + Tok_Qstring, + Tok_Identifier, + Tok_Rnumber, + Tok_Dnumber, + Tok_Div, -- / + Tok_Dot, -- . + Tok_Cln, -- : + + Tok_Error, + Tok_Eof + ); + + type Sdf_Context_Acc is access Sdf_Context_Type; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => Sdf_Context_Acc, Object => Sdf_Context_Type); + + Sdf_Context : Sdf_Context_Acc; + + -- Current data read from the file. + Buf : String_Access (1 .. Buf_Size) := null; + + -- Length of the buffer, including the EOT. + Buf_Len : Natural; + Pos : Natural; + Line_Start : Integer; + + Sdf_Stream : FILEs := NULL_Stream; + Sdf_Filename : String_Access := null; + Sdf_Line : Natural; + + function Open_Sdf (Filename : String) return Boolean + is + N_Filename : String (1 .. Filename'Length + 1); + Mode : constant String := "rt" & NUL; + begin + N_Filename (1 .. Filename'Length) := Filename; + N_Filename (N_Filename'Last) := NUL; + Sdf_Stream := fopen (N_Filename'Address, Mode'Address); + if Sdf_Stream = NULL_Stream then + Error_C ("cannot open SDF file '"); + Error_C (Filename); + Error_E ("'"); + return False; + end if; + Sdf_Context := new Sdf_Context_Type; + + Sdf_Context.Version := Sdf_Version_Unknown; + + -- Set the timescale to 1 ns. + Sdf_Context.Timescale := 1000; + + Buf := new String (1 .. Buf_Size); + Buf_Len := 1; + Buf (1) := EOT; + Sdf_Line := 1; + Sdf_Filename := new String'(Filename); + Pos := 1; + Line_Start := 1; + return True; + end Open_Sdf; + + procedure Close_Sdf + is + begin + fclose (Sdf_Stream); + Sdf_Stream := NULL_Stream; + Unchecked_Deallocation (Sdf_Context); + Unchecked_Deallocation (Buf); + end Close_Sdf; + + procedure Read_Sdf + is + Res : size_t; + begin + Res := fread (Buf (Pos)'Address, 1, size_t (Read_Size), Sdf_Stream); + Line_Start := Line_Start - Buf_Len + Pos; + Buf_Len := Pos + Natural (Res); + Buf (Buf_Len) := EOT; + end Read_Sdf; + + + Ident_Start : Natural; + Ident_End : Natural; + + procedure Read_Append + is + Len : Natural; + begin + Len := Pos - Ident_Start; + if Ident_Start = 1 or Len >= 1024 then + Error_C ("SDF line "); + Error_C (Sdf_Line); + Error_E (" is too long"); + return; + end if; + Buf (1 .. Len) := Buf (Ident_Start .. Ident_Start + Len - 1); + Pos := Len + 1; + Ident_Start := 1; + Read_Sdf; + end Read_Append; + + procedure Error_Sdf_C is + begin + Error_C (Sdf_Filename.all); + Error_C (":"); + Error_C (Sdf_Line); + 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; + + procedure Error_Bad_Character is + begin + Error_Sdf ("bad character in SDF file"); + end Error_Bad_Character; + + procedure Scan_Identifier + is + begin + Ident_Start := Pos; + loop + Pos := Pos + 1; + case Buf (Pos) is + when 'a' .. 'z' + | 'A' .. 'Z' + | '0' .. '9' + | '_' => + null; + when '\' => + Error_Sdf ("escape character not handled"); + Ident_End := Pos - 1; + return; + when EOT => + Read_Append; + Pos := Pos - 1; + when others => + Ident_End := Pos - 1; + return; + end case; + end loop; + end Scan_Identifier; + + function Ident_Length return Natural is + begin + return Ident_End - Ident_Start + 1; + end Ident_Length; + + function Is_Ident (Str : String) return Boolean + is + begin + if Ident_Length /= Str'Length then + return False; + end if; + return Buf (Ident_Start .. Ident_End) = Str; + end Is_Ident; + + procedure Scan_Qstring + is + begin + Ident_Start := Pos + 1; + loop + Pos := Pos + 1; + case Buf (Pos) is + when EOT => + Read_Append; + when NUL .. Character'Val (3) + | Character'Val (5) .. Character'Val (31) + | Character'Val (127) .. Character'Val (255) => + Error_Bad_Character; + when ' ' + | '!' + | '#' .. '~' => + null; + when '"' => -- " + Ident_End := Pos - 1; + Pos := Pos + 1; + exit; + end case; + end loop; + end Scan_Qstring; + + Scan_Int : Integer; + Scan_Exp : Integer; + + function Scan_Number return Sdf_Token_Type + is + Has_Dot : Boolean; + begin + Has_Dot := False; + Scan_Int := 0; + Scan_Exp := 0; + loop + case Buf (Pos) is + when '0' .. '9' => + Scan_Int := Scan_Int * 10 + + Character'Pos (Buf (Pos)) - Character'Pos ('0'); + if Has_Dot then + Scan_Exp := Scan_Exp - 1; + end if; + Pos := Pos + 1; + when '.' => + if Has_Dot then + Error_Bad_Character; + return Tok_Error; + else + Has_Dot := True; + end if; + Pos := Pos + 1; + when EOT => + if Pos /= Buf_Len then + Error_Bad_Character; + return Tok_Error; + end if; + Pos := 1; + Read_Sdf; + exit when Buf_Len = 1; + when others => + exit; + end case; + end loop; + if Has_Dot then + return Tok_Rnumber; + else + return Tok_Dnumber; + end if; + end Scan_Number; + + procedure Refill_Buf is + begin + Buf (1 .. Buf_Len - Pos) := Buf (Pos .. Buf_Len - 1); + Pos := Buf_Len - Pos + 1; + Read_Sdf; + Pos := 1; + end Refill_Buf; + + procedure Skip_Spaces + is + use Ada.Characters.Latin_1; + begin + -- Fast blanks skipping. + while Buf (Pos) = ' ' loop + Pos := Pos + 1; + end loop; + + loop + -- Be sure there is at least 1 character. + if Pos + 1 >= Buf_Len then + Refill_Buf; + end if; + + case Buf (Pos) is + when EOT => + if Pos /= Buf_Len then + return; + end if; + Pos := 1; + Read_Sdf; + if Buf_Len = 1 then + return; + end if; + when LF => + Pos := Pos + 1; + if Buf (Pos) = CR then + Pos := Pos + 1; + end if; + Line_Start := Pos; + Sdf_Line := Sdf_Line + 1; + when CR => + Pos := Pos + 1; + if Buf (Pos) = LF then + Pos := Pos + 1; + end if; + Line_Start := Pos; + Sdf_Line := Sdf_Line + 1; + when ' ' + | HT => + Pos := Pos + 1; + when '/' => + if Buf (Pos + 1) = '/' then + Pos := Pos + 2; + -- Skip line comment. + loop + exit when Buf (Pos) = CR; + exit when Buf (Pos) = LF; + exit when Buf (Pos) = EOT; + Pos := Pos + 1; + if Pos >= Buf_Len then + Refill_Buf; + end if; + end loop; + else + return; + end if; + when others => + return; + end case; + end loop; + end Skip_Spaces; + + function Get_Token return Sdf_Token_Type + is + use Ada.Characters.Latin_1; + begin + Skip_Spaces; + + -- Be sure there is at least 4 characters. + if Pos + 4 >= Buf_Len then + Refill_Buf; + end if; + + case Buf (Pos) is + when EOT => + if Buf_Len = 1 then + return Tok_Eof; + else + Error_Bad_Character; + return Tok_Error; + end if; + when '"' => -- " + Scan_Qstring; + return Tok_Qstring; + when '/' => + -- Skip_Spaces has already handled line comments. + Pos := Pos + 1; + return Tok_Div; + when '.' => + Pos := Pos + 1; + return Tok_Dot; + when ':' => + Pos := Pos + 1; + return Tok_Cln; + when '(' => + Pos := Pos + 1; + return Tok_Oparen; + when ')' => + Pos := Pos + 1; + return Tok_Cparen; + when 'a' .. 'z' + | 'A' .. 'Z' => + Scan_Identifier; + return Tok_Identifier; + when '0' .. '9' => + return Scan_Number; + when others => + Error_Bad_Character; + return Tok_Error; + end case; + end Get_Token; + + function Is_White_Space (C : Character) return Boolean + is + use Ada.Characters.Latin_1; + begin + case C is + when ' ' + | HT + | CR + | LF => + return True; + when others => + return False; + end case; + end Is_White_Space; + + function Get_Edge_Token return Edge_Type + is + use Ada.Characters.Latin_1; + begin + Skip_Spaces; + + -- Be sure there is at least 4 characters. + if Pos + 4 >= Buf_Len then + Refill_Buf; + end if; + + case Buf (Pos) is + when '0' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = 'z' then + Pos := Pos + 2; + return Edge_0z; + elsif Buf (Pos + 1) = '1' then + Pos := Pos + 2; + return Edge_01; + end if; + end if; + when '1' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = 'z' then + Pos := Pos + 2; + return Edge_1z; + elsif Buf (Pos + 1) = '0' then + Pos := Pos + 2; + return Edge_10; + end if; + end if; + when 'z' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = '0' then + Pos := Pos + 2; + return Edge_Z0; + elsif Buf (Pos + 1) = '1' then + Pos := Pos + 2; + return Edge_Z1; + end if; + end if; + when 'p' => + Scan_Identifier; + if Is_Ident ("posedge") then + return Edge_Posedge; + end if; + when 'n' => + Scan_Identifier; + if Is_Ident ("negedge") then + return Edge_Negedge; + end if; + when others => + null; + end case; + Error_Sdf ("edge_identifier expected"); + return Edge_Error; + end Get_Edge_Token; + + procedure Error_Sdf (Tok : Sdf_Token_Type) + is + begin + case Tok is + when Tok_Qstring => + Error_Sdf ("qstring expected"); + when Tok_Oparen => + Error_Sdf ("'(' expected"); + when Tok_Identifier => + Error_Sdf ("identifier expected"); + when Tok_Cln => + Error_Sdf ("':' (colon) expected"); + when others => + Error_Sdf ("parse error"); + end case; + end Error_Sdf; + + function Expect (Tok : Sdf_Token_Type) return Boolean + is + begin + if Get_Token = Tok then + return True; + end if; + Error_Sdf (Tok); + return False; + end Expect; + + function Expect_Cp_Op_Ident (Tok : Sdf_Token_Type) return Boolean + is + begin + if Tok /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return False; + end if; + if not Expect (Tok_Oparen) + or else not Expect (Tok_Identifier) + then + return False; + end if; + return True; + end Expect_Cp_Op_Ident; + + function Expect_Qstr_Cp_Op_Ident (Str : String) return Boolean + is + Tok : Sdf_Token_Type; + begin + if not Is_Ident (Str) then + return True; + end if; + + Tok := Get_Token; + if Tok = Tok_Qstring then + Tok := Get_Token; + end if; + + return Expect_Cp_Op_Ident (Tok); + end Expect_Qstr_Cp_Op_Ident; + + procedure Start_Generic_Name (Kind : Timing_Generic_Kind) is + begin + Sdf_Context.Kind := Kind; + Sdf_Context.Port_Num := 0; + Sdf_Context.Ports (1).L := Invalid_Dnumber; + Sdf_Context.Ports (2).L := Invalid_Dnumber; + Sdf_Context.Ports (1).Edge := Edge_None; + Sdf_Context.Ports (2).Edge := Edge_None; + end Start_Generic_Name; + + -- 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. + type Parse_Status_Type is + ( + Status_Error, + Status_Altern, + Status_Optional, + Status_Found, + Status_Set + ); + + function Num_To_Time return Ghdl_I64 + is + Res : Ghdl_I64; + begin + Res := Ghdl_I64 (Scan_Int) * Ghdl_I64 (Sdf_Context.Timescale); + while Scan_Exp < 0 loop + Res := Res / 10; + Scan_Exp := Scan_Exp + 1; + end loop; + return Res; + end Num_To_Time; + + -- Parse: REXPRESSION? ')' + procedure Parse_Rexpression + (Status : out Parse_Status_Type; Val : out Ghdl_I64) + is + Tok : Sdf_Token_Type; + + procedure Pr_Rnumber (Mtm : Mtm_Type) + is + begin + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Mtm = Sdf_Mtm then + Val := Num_To_Time; + Status := Status_Set; + elsif Status /= Status_Set then + Status := Status_Found; + end if; + Tok := Get_Token; + end if; + end Pr_Rnumber; + + function Pr_Colon return Boolean + is + begin + if Tok /= Tok_Cln then + Error_Sdf (Tok_Cln); + Status := Status_Error; + return False; + else + Tok := Get_Token; + return True; + end if; + end Pr_Colon; + + begin + Val := 0; + Tok := Get_Token; + Status := Status_Error; + if Tok = Tok_Cparen then + Status := Status_Optional; + return; + end if; + + Pr_Rnumber (Minimum); + + if not Pr_Colon then + return; + end if; + + Pr_Rnumber (Typical); + + if not Pr_Colon then + return; + end if; + + Pr_Rnumber (Maximum); + + if Status = Status_Error then + Error_Sdf ("at least one number required in an rexpression"); + return; + end if; + + if Tok /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + Status := Status_Error; + end if; + end Parse_Rexpression; + + function Expect_Rexpr_Cp_Op_Ident return Boolean + is + Status : Parse_Status_Type; + Val : Ghdl_I64; + begin + Parse_Rexpression (Status, Val); + if Status = Status_Error then + return False; + end if; + if not Expect (Tok_Oparen) + or else not Expect (Tok_Identifier) + then + Error_Sdf (Tok_Identifier); + return False; + end if; + return True; + end Expect_Rexpr_Cp_Op_Ident; + + function To_Lower (C : Character) return Character is + begin + if C >= 'A' and C <= 'Z' then + return Character'Val (Character'Pos (C) + - Character'Pos ('A') + Character'Pos ('a')); + else + return C; + end if; + end To_Lower; + + function Parse_Port_Path1 (Tok : Sdf_Token_Type) return Boolean + is + Port_Spec : Port_Spec_Type + renames Sdf_Context.Ports (Sdf_Context.Port_Num); + Len : Natural; + begin + if Tok /= Tok_Identifier then + Error_Sdf ("port path expected"); + return False; + end if; + Len := 0; + for I in Ident_Start .. Ident_End loop + Len := Len + 1; + Port_Spec.Name (Len) := To_Lower (Buf (I)); + end loop; + Port_Spec.Name_Len := Len; + + -- Parse [ DNUMBER ] + -- | [ DNUMBER : DNUMBER ] + Skip_Spaces; + if Buf (Pos) = '[' then + Port_Spec.R := Invalid_Dnumber; + Pos := Pos + 1; + if Get_Token /= Tok_Dnumber then + Error_Sdf (Tok); + else + Port_Spec.L := Ghdl_I32 (Scan_Int); + end if; + Skip_Spaces; + if Buf (Pos) = ':' then + Pos := Pos + 1; + if Get_Token /= Tok_Dnumber then + Error_Sdf (Tok); + else + Port_Spec.R := Ghdl_I32 (Scan_Int); + end if; + Skip_Spaces; + end if; + if Buf (Pos) /= ']' then + Error_Sdf ("']' expected"); + else + Pos := Pos + 1; + end if; + end if; + + return True; + end Parse_Port_Path1; + + function Parse_Port_Path return Boolean + is + begin + Sdf_Context.Port_Num := Sdf_Context.Port_Num + 1; + return Parse_Port_Path1 (Get_Token); + end Parse_Port_Path; + + function Parse_Port_Spec return Boolean + is + Tok : Sdf_Token_Type; + Edge : Edge_Type; + begin + Sdf_Context.Port_Num := Sdf_Context.Port_Num + 1; + Tok := Get_Token; + if Tok = Tok_Identifier then + return Parse_Port_Path1 (Tok); + elsif Tok /= Tok_Oparen then + Error_Sdf ("port spec expected"); + return False; + end if; + Edge := Get_Edge_Token; + if Edge = Edge_Error then + return False; + end if; + Sdf_Context.Ports (Sdf_Context.Port_Num).Edge := Edge; + if not Parse_Port_Path1 (Get_Token) then + return False; + end if; + if Get_Token /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return False; + end if; + return True; + end Parse_Port_Spec; + + function Parse_Port_Tchk return Boolean renames Parse_Port_Spec; + + -- tc_rvalue ::= ( RNUMBER ) + -- ||= ( rexpression ) + -- Return status_optional for ( ) + function Parse_Tc_Rvalue return Parse_Status_Type + is + Tok : Sdf_Token_Type; + Res : Parse_Status_Type; + begin + -- '(' + if Get_Token /= Tok_Oparen then + Error_Sdf (Tok_Oparen); + return Status_Error; + end if; + Res := Status_Found; + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + Sdf_Context.Timing (1) := Num_To_Time; + Tok := Get_Token; + if Tok = Tok_Cparen then + -- This is a simple RNUMBER. + return Status_Altern; + end if; + if Sdf_Mtm = Minimum then + Res := Status_Set; + end if; + end if; + if Tok = Tok_Cparen then + return Status_Optional; + end if; + if Tok /= Tok_Cln then + Error_Sdf (Tok_Cln); + return Status_Error; + end if; + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Sdf_Mtm = Typical then + Sdf_Context.Timing (1) := Num_To_Time; + Res := Status_Set; + end if; + Tok := Get_Token; + end if; + if Tok /= Tok_Cln then + Error_Sdf (Tok_Cln); + return Status_Error; + end if; + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Sdf_Mtm = Maximum then + Sdf_Context.Timing (1) := Num_To_Time; + Res := Status_Set; + end if; + Tok := Get_Token; + end if; + if Tok /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return Status_Error; + end if; + return Res; + end Parse_Tc_Rvalue; + + function Parse_Simple_Tc_Rvalue return Boolean is + begin + Sdf_Context.Timing_Nbr := 0; + + case Parse_Tc_Rvalue is + when Status_Error + | Status_Optional => + return False; + when Status_Altern => + null; + when Status_Found => + Sdf_Context.Timing_Set (1) := False; + when Status_Set => + Sdf_Context.Timing_Set (1) := True; + end case; + return True; + end Parse_Simple_Tc_Rvalue; + + -- rvalue ::= ( RNUMBER ) + -- ||= rexp_list + -- Parse: rvalue ) + function Parse_Rvalue return Boolean + is + Tok : Sdf_Token_Type; + begin + Sdf_Context.Timing_Nbr := 0; + Sdf_Context.Timing_Set := (others => False); + + case Parse_Tc_Rvalue 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 => + null; + when Status_Set => + Sdf_Context.Timing_Set (1) := True; + end case; + + Sdf_Context.Timing_Nbr := 1; + loop + Tok := Get_Token; + exit when Tok = Tok_Cparen; + if Tok /= Tok_Oparen then + Error_Sdf (Tok_Oparen); + return False; + end if; + + Sdf_Context.Timing_Nbr := Sdf_Context.Timing_Nbr + 1; + declare + Status : Parse_Status_Type; + Val : Ghdl_I64; + begin + Parse_Rexpression (Status, Val); + case Status is + when Status_Error + | Status_Altern => + return False; + when Status_Optional + | Status_Found => + null; + when Status_Set => + Sdf_Context.Timing_Set (Sdf_Context.Timing_Nbr) := True; + Sdf_Context.Timing (Sdf_Context.Timing_Nbr) := Val; + end case; + end; + end loop; + if Boolean'(False) then + -- Do not expand here, since the most used is 01. + case Sdf_Context.Timing_Nbr is + when 1 => + for I in 2 .. 6 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (1); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (1); + end loop; + when 2 => + for I in 3 .. 4 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (1); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (1); + end loop; + for I in 5 .. 6 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (2); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (2); + end loop; + when 3 => + for I in 4 .. 6 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (I - 3); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (I - 3); + end loop; + when 6 + | 12 => + null; + when others => + Error_Sdf ("bad number of rvalue"); + return False; + end case; + end if; + return True; + end Parse_Rvalue; + + function Handle_Generic return Boolean + is + Name : String (1 .. 1024); + Len : Natural; + + procedure Start (Str : String) is + begin + Name (1 .. Str'Length) := Str; + Len := Str'Length; + end Start; + + procedure Add (Str : String) + is + Nlen : Natural; + begin + Len := Len + 1; + Name (Len) := '_'; + Nlen := Len + Str'Length; + Name (Len + 1 .. Nlen) := Str; + Len := Nlen; + end Add; + + procedure Add_Edge (Edge : Edge_Type; Force : Boolean) is + begin + case Edge is + when Edge_Posedge => + Add ("posedge"); + when Edge_Negedge => + Add ("negedge"); + when Edge_01 => + Add ("01"); + when Edge_10 => + Add ("10"); + when Edge_0z => + Add ("0z"); + when Edge_Z1 => + Add ("Z1"); + when Edge_1z => + Add ("1z"); + when Edge_Z0 => + Add ("ZO"); + when Edge_None => + if Force then + Add ("noedge"); + end if; + when Edge_Error => + Add ("?"); + end case; + end Add_Edge; + + Ok : Boolean; + begin + case Sdf_Context.Kind is + when Delay_Iopath => + Start ("tpd"); + when Delay_Port => + Start ("tipd"); + when Timingcheck_Setup => + Start ("tsetup"); + when Timingcheck_Hold => + Start ("thold"); + when Timingcheck_Setuphold => + Start ("tsetup"); + when Timingcheck_Recovery => + Start ("trecovery"); + when Timingcheck_Skew => + Start ("tskew"); + when Timingcheck_Width => + Start ("tpw"); + when Timingcheck_Period => + Start ("tperiod"); + when Timingcheck_Nochange => + Start ("tncsetup"); + end case; + for I in 1 .. Sdf_Context.Port_Num loop + Add (Sdf_Context.Ports (I).Name + (1 .. Sdf_Context.Ports (I).Name_Len)); + end loop; + if Sdf_Context.Kind in Timing_Generic_Full_Condition then + Add_Edge (Sdf_Context.Ports (1).Edge, True); + Add_Edge (Sdf_Context.Ports (2).Edge, False); + elsif Sdf_Context.Kind in Timing_Generic_Simple_Condition then + Add_Edge (Sdf_Context.Ports (1).Edge, False); + end if; + Vital_Annotate.Sdf_Generic (Sdf_Context.all, Name (1 .. Len), Ok); + if not Ok then + Error_Sdf_C; + Error_C ("could not annotate generic "); + Error_E (Name (1 .. Len)); + return False; + end if; + return True; + end Handle_Generic; + + function Parse_Sdf return Boolean + is + Tok : Sdf_Token_Type; + Ok : Boolean; + begin + if Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + or else not Is_Ident ("DELAYFILE") + or else Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("not an SDF file"); + return False; + end if; + + if Is_Ident ("SDFVERSION") then + Tok := Get_Token; + if Tok = Tok_Qstring then + Sdf_Context.Version := Sdf_Version_Bad; + if Ident_Length = 3 and then Buf (Ident_Start + 1) = '.' then + -- Version has the format '"X.Y"' (without simple quote). + if Buf (Ident_Start) = '2' + and then Buf (Ident_Start + 2) = '1' + then + Sdf_Context.Version := Sdf_2_1; + end if; + end if; + Tok := Get_Token; + end if; + + if not Expect_Cp_Op_Ident (Tok) then + return False; + end if; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("DESIGN") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("DATE") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("VENDOR") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("PROGRAM") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("VERSION") then + return False; + end if; + + if Is_Ident ("DIVIDER") then + Tok := Get_Token; + if Tok = Tok_Div or Tok = Tok_Dot then + Tok := Get_Token; + end if; + if not Expect_Cp_Op_Ident (Tok) then + return False; + end if; + end if; + + if Is_Ident ("VOLTAGE") then + if not Expect_Rexpr_Cp_Op_Ident then + return False; + end if; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("PROCESS") then + return False; + end if; + + if Is_Ident ("TEMPERATURE") then + if not Expect_Rexpr_Cp_Op_Ident then + return False; + end if; + end if; + + if Is_Ident ("TIMESCALE") then + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Scan_Exp = 0 and (Scan_Int = 1 + or Scan_Int = 10 + or Scan_Int = 100) + then + Sdf_Context.Timescale := Scan_Int; + else + Error_Sdf ("bad timescale value"); + return False; + end if; + Tok := Get_Token; + if Tok /= Tok_Identifier then + Error_Sdf (Tok_Identifier); + end if; + if Is_Ident ("ps") then + null; + elsif Is_Ident ("ns") then + Sdf_Context.Timescale := Sdf_Context.Timescale * 1000; + elsif Is_Ident ("us") then + Sdf_Context.Timescale := Sdf_Context.Timescale * 1000_000; + else + Error_Sdf ("bad timescale unit"); + return False; + end if; + Tok := Get_Token; + end if; + if not Expect_Cp_Op_Ident (Tok) then + return False; + end if; + end if; + + Vital_Annotate.Sdf_Header (Sdf_Context.all); + + -- Parse cell+ + loop + if not Is_Ident ("CELL") then + Error_Sdf ("CELL expected"); + return False; + end if; + -- Parse celltype + if Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + or else not Is_Ident ("CELLTYPE") + or else Get_Token /= Tok_Qstring + then + Error_Sdf ("CELLTYPE expected"); + return False; + end if; + Sdf_Context.Celltype_Len := Ident_Length; + if Sdf_Context.Celltype_Len > Sdf_Context.Celltype'Length then + Error_Sdf ("CELLTYPE qstring is too long"); + return False; + end if; + for I in Ident_Start .. Ident_End loop + Sdf_Context.Celltype (I - Ident_Start + 1) := To_Lower (Buf (I)); + end loop; + Vital_Annotate.Sdf_Celltype (Sdf_Context.all); + if Get_Token /= Tok_Cparen + or else Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + or else not Is_Ident ("INSTANCE") + then + Error_Sdf ("INSTANCE expected"); + return False; + end if; + -- Parse instance+ + loop + exit when not Is_Ident ("INSTANCE"); + Tok := Get_Token; + if Tok /= Tok_Cparen then + loop + if Tok /= Tok_Identifier then + Error_Sdf ("instance identifier expected"); + return False; + end if; + for I in Ident_Start .. Ident_End loop + Buf (I) := To_Lower (Buf (I)); + end loop; + Vital_Annotate.Sdf_Instance + (Sdf_Context.all, Buf (Ident_Start .. Ident_End), Ok); + if not Ok then + Error_Sdf ("cannot find instance"); + return False; + end if; + Tok := Get_Token; + exit when Tok /= Tok_Dot; + Tok := Get_Token; + end loop; + end if; + if Tok /= Tok_Cparen + or else Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("instance or timing_spec expected"); + return False; + end if; + end loop; + Vital_Annotate.Sdf_Instance_End (Sdf_Context.all, Ok); + if not Ok then + Error_Sdf ("bad instance or celltype mistmatch"); + return False; + end if; + + -- Parse timing_spec+ + loop + if Is_Ident ("DELAY") then + -- Parse deltype+ + Tok := Get_Token; + loop + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("deltype expected"); + return False; + end if; + if Is_Ident ("PATHPULSE") + or else Is_Ident ("GLOBALPATHPULSE") + then + Error_Sdf ("PATHPULSE and GLOBALPATHPULSE not allowed"); + return False; + end if; + if Is_Ident ("ABSOLUTE") then + null; + elsif Is_Ident ("INCREMENT") then + null; + else + Error_Sdf ("ABSOLUTE or INCREMENT expected"); + return False; + end if; + -- Parse absvals+ or incvals+ + Tok := Get_Token; + loop + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("absvals or incvals expected"); + return False; + end if; + if Is_Ident ("IOPATH") then + Start_Generic_Name (Delay_Iopath); + if not Parse_Port_Spec + or else not Parse_Port_Path + or else not Parse_Rvalue + then + return False; + end if; + elsif Is_Ident ("PORT") then + Start_Generic_Name (Delay_Port); + if not Parse_Port_Path + or else not Parse_Rvalue + then + return False; + end if; + elsif Is_Ident ("COND") + or else Is_Ident ("INTERCONNECT") + or else Is_Ident ("DEVICE") + then + Error_Sdf + ("COND, INTERCONNECT, or DEVICE not handled"); + return False; + elsif Is_Ident ("NETDELAY") then + Error_Sdf ("NETDELAY not allowed in VITAL SDF"); + return False; + else + Error_Sdf ("absvals or incvals expected"); + return False; + end if; + + if not Handle_Generic then + return False; + end if; + + Tok := Get_Token; + exit when Tok = Tok_Cparen; + end loop; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + end loop; + elsif Is_Ident ("TIMINGCHECK") then + -- parse tc_def+ + Tok := Get_Token; + loop + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("tc_def expected"); + return False; + end if; + if Is_Ident ("SETUP") then + Start_Generic_Name (Timingcheck_Setup); + elsif Is_Ident ("HOLD") then + Start_Generic_Name (Timingcheck_Hold); + elsif Is_Ident ("SETUPHOLD") then + Start_Generic_Name (Timingcheck_Setuphold); + elsif Is_Ident ("RECOVERY") then + Start_Generic_Name (Timingcheck_Recovery); + elsif Is_Ident ("SKEW") then + Start_Generic_Name (Timingcheck_Skew); + elsif Is_Ident ("WIDTH") then + Start_Generic_Name (Timingcheck_Width); + elsif Is_Ident ("PERIOD") then + Start_Generic_Name (Timingcheck_Period); + elsif Is_Ident ("NOCHANGE") then + Start_Generic_Name (Timingcheck_Nochange); + elsif Is_Ident ("PATHCONSTRAINT") + or else Is_Ident ("SUM") + or else Is_Ident ("DIFF") + or else Is_Ident ("SKEWCONSTRAINT") + then + Error_Sdf ("non-VITAL tc_def"); + return False; + else + Error_Sdf ("bad tc_def"); + return False; + end if; + + case Sdf_Context.Kind is + when Timingcheck_Setup + | Timingcheck_Hold + | Timingcheck_Recovery + | Timingcheck_Skew + | Timingcheck_Setuphold + | Timingcheck_Nochange => + if not Parse_Port_Tchk + or else not Parse_Port_Tchk + or else not Parse_Simple_Tc_Rvalue + then + return False; + end if; + when Timingcheck_Width + | Timingcheck_Period => + if not Parse_Port_Tchk + or else not Parse_Simple_Tc_Rvalue + then + return False; + end if; + when others => + Internal_Error ("sdf_parse"); + end case; + + if not Handle_Generic then + return False; + end if; + + case Sdf_Context.Kind is + when Timingcheck_Setuphold + | Timingcheck_Nochange => + if not Parse_Simple_Tc_Rvalue then + return False; + end if; + Error_Sdf ("setuphold and nochange not yet handled"); + return False; + when others => + null; + end case; + + if Get_Token /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return False; + end if; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + end loop; + end if; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + if Tok /= Tok_Oparen then + Error_Sdf (Tok_Oparen); + return False; + end if; + if Get_Token /= Tok_Identifier then + Error_Sdf (Tok_Identifier); + return False; + end if; + end loop; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf (Tok_Identifier); + end if; + end loop; + if Get_Token /= Tok_Eof then + Error_Sdf ("EOF expected"); + return False; + end if; + return True; + end Parse_Sdf; + + function Parse_Sdf_File (Filename : String) return Boolean + is + Res : Boolean; + begin + if not Open_Sdf (Filename) then + return False; + end if; + Res := Parse_Sdf; + Close_Sdf; + return Res; + end Parse_Sdf_File; + +end Grt.Sdf; diff --git a/src/translate/grt/grt-sdf.ads b/src/translate/grt/grt-sdf.ads new file mode 100644 index 0000000..fd05b9e --- /dev/null +++ b/src/translate/grt/grt-sdf.ads @@ -0,0 +1,131 @@ +-- GHDL Run Time (GRT) - SDF parser. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; + +package Grt.Sdf is + type Edge_Type is + ( + Edge_Error, + Edge_None, + Edge_Posedge, + Edge_Negedge, + Edge_01, + Edge_10, + Edge_0z, + Edge_Z1, + Edge_1z, + Edge_Z0 + ); + + type Timing_Generic_Kind is + ( + Delay_Port, + --Delay_Interconnect, + --Delay_Device, + + -- Simple condition + Delay_Iopath, + Timingcheck_Width, + Timingcheck_Period, + + -- Full condition + Timingcheck_Setup, + Timingcheck_Hold, + Timingcheck_Recovery, + Timingcheck_Skew, + Timingcheck_Nochange, + Timingcheck_Setuphold + ); + + subtype Timing_Generic_Simple_Condition is Timing_Generic_Kind + range Delay_Iopath .. Timingcheck_Period; + + subtype Timing_Generic_Full_Condition is Timing_Generic_Kind + range Timingcheck_Setup .. Timingcheck_Setuphold; + + type Sdf_Version_Type is + ( + Sdf_2_1, + Sdf_Version_Unknown, + Sdf_Version_Bad + ); + + Read_Size : constant Natural := 4096; + Buf_Size : constant Natural := Read_Size + 1024 + 1; + + Invalid_Dnumber : constant Ghdl_I32 := -1; + + type Port_Spec_Type is record + -- Port identifier. + Name : String (1 .. 128); + Name_Len : Natural; + + -- Left and Right range. + -- If L = R = Invalid_Dnumber, this is a simple scalar port. + -- If R = Invalid_Dnumber, this is a scalar port (from a vector) + -- Otherwise, this is a bus port. + L, R : Ghdl_I32; + + -- Cond : String (1 .. 1024); + -- Cond_Len : Natural; + + Edge : Edge_Type; + end record; + + type Port_Spec_Array_Type is array (Natural range <>) of Port_Spec_Type; + + type Ghdl_I64_Array is array (1 .. 12) of Ghdl_I64; + type Boolean_Array is array (1 .. 12) of Boolean; + + type Sdf_Context_Type is record + -- Version of the SDF file. + Version : Sdf_Version_Type; + + -- Timescale; 1 corresponds to 1 ps. + -- Default is 1000 (1 ns). + Timescale : Natural; + + Kind : Timing_Generic_Kind; + + -- Cell type. + Celltype : String (1 .. 128); + Celltype_Len : Natural; + + -- Current port. + Port_Num : Natural; + Ports : Port_Spec_Array_Type (1 .. 2); + + -- timing spec. + Timing : Ghdl_I64_Array; + Timing_Set : Boolean_Array; + Timing_Nbr : Natural; + end record; + + -- Which value is extracted. + type Mtm_Type is (Minimum, Typical, Maximum); + Sdf_Mtm : Mtm_Type := Typical; + + function Parse_Sdf_File (Filename : String) return Boolean; +end Grt.Sdf; diff --git a/src/translate/grt/grt-shadow_ieee.adb b/src/translate/grt/grt-shadow_ieee.adb new file mode 100644 index 0000000..32af4be --- /dev/null +++ b/src/translate/grt/grt-shadow_ieee.adb @@ -0,0 +1,32 @@ +-- GHDL Run Time (GRT) - ghost declarations for ieee. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; + +package body Grt.Shadow_Ieee is + procedure Ieee_Std_Logic_1164_Resolved_RESOLV is + begin + Internal_Error ("resolved_RESOLV from shadow ieee called"); + end Ieee_Std_Logic_1164_Resolved_RESOLV; +end Grt.Shadow_Ieee; diff --git a/src/translate/grt/grt-shadow_ieee.ads b/src/translate/grt/grt-shadow_ieee.ads new file mode 100644 index 0000000..f12b479 --- /dev/null +++ b/src/translate/grt/grt-shadow_ieee.ads @@ -0,0 +1,41 @@ +-- GHDL Run Time (GRT) - ghost declarations for ieee. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +-- This packages provides dummy declaration for main IEEE.STD_LOGIC_1164 +-- type descriptors. +-- The package must not have elaboration code, since the actual type +-- descriptors are not writable (they are constant). Making it preelaborated +-- is not enough, the variables must be initialized. This current +-- implementation provides bad values; this is not a problem since they are +-- not read in grt. + +package Grt.Shadow_Ieee is + pragma Preelaborate (Grt.Shadow_Ieee); + + procedure Ieee_Std_Logic_1164_Resolved_RESOLV; +private + pragma Export (C, Ieee_Std_Logic_1164_Resolved_RESOLV, + "ieee__std_logic_1164__resolved_RESOLV"); +end Grt.Shadow_Ieee; diff --git a/src/translate/grt/grt-signals.adb b/src/translate/grt/grt-signals.adb new file mode 100644 index 0000000..9698d81 --- /dev/null +++ b/src/translate/grt/grt-signals.adb @@ -0,0 +1,3400 @@ +-- GHDL Run Time (GRT) - signals management. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Ada.Unchecked_Deallocation; +with Grt.Errors; use Grt.Errors; +with Grt.Processes; use Grt.Processes; +with Grt.Options; use Grt.Options; +with Grt.Rtis_Types; use Grt.Rtis_Types; +with Grt.Disp_Signals; +with Grt.Astdio; +with Grt.Stdio; +with Grt.Threads; use Grt.Threads; + +package body Grt.Signals is + procedure Free is new Ada.Unchecked_Deallocation + (Object => Transaction, Name => Transaction_Acc); + + procedure Free_In (Trans : Transaction_Acc) + is + Ntrans : Transaction_Acc; + begin + Ntrans := Trans; + Free (Ntrans); + end Free_In; + pragma Inline (Free_In); + + -- RTI for the current signal. + Sig_Rti : Ghdl_Rtin_Object_Acc; + + -- Signal mode (and flags) for the current signal. + Sig_Mode : Mode_Signal_Type; + Sig_Has_Active : Boolean; + Sig_Kind : Kind_Signal_Type; + + -- Last created implicit signal. This is used to add dependencies on + -- the prefix. + Last_Implicit_Signal : Ghdl_Signal_Ptr; + + -- Current signal resolver. + Current_Resolv : Resolved_Signal_Acc := null; + + function Get_Current_Mode_Signal return Mode_Signal_Type is + begin + return Sig_Mode; + end Get_Current_Mode_Signal; + + procedure Ghdl_Signal_Name_Rti (Sig : Ghdl_Rti_Access; + Ctxt : Ghdl_Rti_Access; + Addr : Address) + is + pragma Unreferenced (Ctxt); + pragma Unreferenced (Addr); + begin + Sig_Rti := To_Ghdl_Rtin_Object_Acc (Sig); + Sig_Mode := Mode_Signal_Type'Val + (Sig.Mode and Ghdl_Rti_Signal_Mode_Mask); + Sig_Kind := Kind_Signal_Type'Val + ((Sig.Mode and Ghdl_Rti_Signal_Kind_Mask) + / Ghdl_Rti_Signal_Kind_Offset); + Sig_Has_Active := + (Sig_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0; + end Ghdl_Signal_Name_Rti; + + procedure Ghdl_Signal_Set_Mode (Mode : Mode_Signal_Type; + Kind : Kind_Signal_Type; + Has_Active : Boolean) is + begin + Sig_Rti := null; + Sig_Mode := Mode; + Sig_Kind := Kind; + Sig_Has_Active := Has_Active; + end Ghdl_Signal_Set_Mode; + + function Is_Signal_Guarded (Sig : Ghdl_Signal_Ptr) return Boolean is + begin + return Sig.Sig_Kind /= Kind_Signal_No; + end Is_Signal_Guarded; + + function To_Address is new Ada.Unchecked_Conversion + (Source => Ghdl_Signal_Ptr, Target => Address); + + function Create_Signal + (Mode : Mode_Type; + Init_Val : Value_Union; + Mode_Sig : Mode_Signal_Type; + Resolv_Proc : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; + Resolv : Resolved_Signal_Acc; + S : Ghdl_Signal_Data (Mode_Sig); + begin + Sig_Table.Increment_Last; + + if Current_Resolv = null then + if Resolv_Proc /= null then + Resolv := new Resolved_Signal_Type' + (Resolv_Proc => Resolv_Proc, + Resolv_Inst => Resolv_Inst, + Resolv_Ptr => Null_Address, + Sig_Range => (Sig_Table.Last, Sig_Table.Last), + Disconnect_Time => Bad_Time); + else + Resolv := null; + end if; + else + if Resolv_Proc /= null then + -- Only one resolution function is allowed! + Internal_Error ("create_signal"); + end if; + Resolv := Current_Resolv; + if Current_Resolv.Sig_Range.Last = Sig_Table.Last then + Current_Resolv := null; + end if; + end if; + + case Mode_Sig is + when Mode_Signal_User => + S.Nbr_Drivers := 0; + S.Drivers := null; + S.Effective := null; + S.Resolv := Resolv; + when Mode_Conv_In + | Mode_Conv_Out => + S.Conv := null; + when Mode_Stable + | Mode_Quiet + | Mode_Delayed => + S.Time := 0; + when Mode_Guard => + S.Guard_Func := null; + S.Guard_Instance := System.Null_Address; + when Mode_Transaction + | Mode_End => + null; + end case; + + Res := new Ghdl_Signal'(Value => Init_Val, + Driving_Value => Init_Val, + Last_Value => Init_Val, + -- Note: use -Std_Time'last instead of + -- Std_Time'First so that NOW - x'last_event + -- returns time'high at initialization! + Last_Event => -Std_Time'Last, + Last_Active => -Std_Time'Last, + Event => False, + Active => False, + Has_Active => False, + Sig_Kind => Sig_Kind, + + Is_Direct_Active => False, + Mode => Mode, + Flags => (Propag => Propag_None, + Is_Dumped => False, + Cyc_Event => False, + Seen => False), + + Net => No_Signal_Net, + Link => null, + Alink => null, + Flink => null, + + Event_List => null, + Rti => Sig_Rti, + + Nbr_Ports => 0, + Ports => null, + + S => S); + + if Resolv /= null and then Resolv.Resolv_Ptr = System.Null_Address then + Resolv.Resolv_Ptr := To_Address (Res); + end if; + + case Flag_Activity is + when Activity_All => + Res.Has_Active := True; + when Activity_Minimal => + Res.Has_Active := Sig_Has_Active; + when Activity_None => + Res.Has_Active := False; + end case; + + -- Put the signal in the table. + Sig_Table.Table (Sig_Table.Last) := Res; + + return Res; + end Create_Signal; + + procedure Ghdl_Signal_Init (Sig : Ghdl_Signal_Ptr; Val : Value_Union) is + begin + Sig.Value := Val; + Sig.Driving_Value := Val; + Sig.Last_Value := Val; + end Ghdl_Signal_Init; + + procedure Ghdl_Signal_Merge_Rti (Sig : Ghdl_Signal_Ptr; + Rti : Ghdl_Rti_Access) + is + S_Rti : Ghdl_Rtin_Object_Acc; + begin + S_Rti := To_Ghdl_Rtin_Object_Acc (Rti); + if Flag_Activity = Activity_Minimal then + if (S_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0 then + Sig.Has_Active := True; + end if; + end if; + end Ghdl_Signal_Merge_Rti; + + procedure Ghdl_Signal_Create_Resolution (Proc : Resolver_Acc; + Instance : System.Address; + Sig : System.Address; + Nbr_Sig : Ghdl_Index_Type) + is + begin + if Current_Resolv /= null then + Internal_Error ("Ghdl_Signal_Create_Resolution"); + end if; + Current_Resolv := new Resolved_Signal_Type' + (Resolv_Proc => Proc, + Resolv_Inst => Instance, + Resolv_Ptr => Sig, + Sig_Range => (First => Sig_Table.Last + 1, + Last => Sig_Table.Last + Sig_Table_Index (Nbr_Sig)), + Disconnect_Time => Bad_Time); + end Ghdl_Signal_Create_Resolution; + + procedure Check_New_Source (Sig : Ghdl_Signal_Ptr) + is + use Grt.Stdio; + use Grt.Astdio; + begin + if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 0 then + if Sig.S.Resolv = null then + -- LRM 4.3.1.2 Signal Declaration + -- It is an error if, after the elaboration of a description, a + -- signal has multiple sources and it is not a resolved signal. + if Sig.Rti /= null then + Put ("for signal: "); + Disp_Signals.Put_Signal_Name (stderr, Sig); + New_Line (stderr); + end if; + Error ("several sources for unresolved signal"); + elsif Sig.S.Mode_Sig = Mode_Buffer and False then + -- LRM 1.1.1.2 Ports + -- A BUFFER port may have at most one source. + + -- FIXME: this is not true with VHDL-02. + -- With VHDL-87/93, should also check that: any actual associated + -- with a formal buffer port may have at most one source. + Error ("buffer port which more than one source"); + end if; + end if; + end Check_New_Source; + + -- Return TRUE if already present. + function Ghdl_Signal_Add_Driver (Sign : Ghdl_Signal_Ptr; + Trans : Transaction_Acc) + return Boolean + is + type Size_T is mod 2**Standard'Address_Size; + + function Malloc (Size : Size_T) return Driver_Arr_Ptr; + pragma Import (C, Malloc); + + function Realloc (Ptr : Driver_Arr_Ptr; Size : Size_T) + return Driver_Arr_Ptr; + pragma Import (C, Realloc); + + function Size (N : Ghdl_Index_Type) return Size_T is + begin + return Size_T (N * Driver_Fat_Array'Component_Size + / System.Storage_Unit); + end Size; + + Proc : Process_Acc; + begin + Proc := Get_Current_Process; + if Sign.S.Nbr_Drivers = 0 then + Check_New_Source (Sign); + Sign.S.Drivers := Malloc (Size (1)); + Sign.S.Nbr_Drivers := 1; + else + -- Do not create a driver twice. + for I in 0 .. Sign.S.Nbr_Drivers - 1 loop + if Sign.S.Drivers (I).Proc = Proc then + return True; + end if; + end loop; + Check_New_Source (Sign); + Sign.S.Nbr_Drivers := Sign.S.Nbr_Drivers + 1; + Sign.S.Drivers := Realloc (Sign.S.Drivers, Size (Sign.S.Nbr_Drivers)); + end if; + Sign.S.Drivers (Sign.S.Nbr_Drivers - 1) := + (First_Trans => Trans, + Last_Trans => Trans, + Proc => Proc); + return False; + end Ghdl_Signal_Add_Driver; + + procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Sign.Value); + if Ghdl_Signal_Add_Driver (Sign, Trans) then + Free (Trans); + end if; + end Ghdl_Process_Add_Driver; + + procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr; + Drv : Ghdl_Value_Ptr) + is + Trans : Transaction_Acc; + Trans1 : Transaction_Acc; + begin + -- Create transaction for current driving value. + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Sign.Value); + if Ghdl_Signal_Add_Driver (Sign, Trans) then + Free (Trans); + return; + end if; + -- Create transaction for the next driving value. + Trans1 := new Transaction'(Kind => Trans_Direct, + Line => 0, + Time => 0, + Next => null, + Val_Ptr => Drv); + Sign.S.Drivers (Sign.S.Nbr_Drivers - 1).Last_Trans := Trans1; + Trans.Next := Trans1; + end Ghdl_Signal_Add_Direct_Driver; + + procedure Append_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr) + is + type Size_T is new Integer; + + function Malloc (Size : Size_T) return Signal_Arr_Ptr; + pragma Import (C, Malloc); + + function Realloc (Ptr : Signal_Arr_Ptr; Size : Size_T) + return Signal_Arr_Ptr; + pragma Import (C, Realloc); + + function Size (N : Ghdl_Index_Type) return Size_T is + begin + return Size_T (N * Ghdl_Signal_Ptr'Size / System.Storage_Unit); + end Size; + begin + if Targ.Nbr_Ports = 0 then + Targ.Ports := Malloc (Size (1)); + Targ.Nbr_Ports := 1; + else + Targ.Nbr_Ports := Targ.Nbr_Ports + 1; + Targ.Ports := Realloc (Targ.Ports, Size (Targ.Nbr_Ports)); + end if; + Targ.Ports (Targ.Nbr_Ports - 1) := Src; + end Append_Port; + + -- Add SRC to port list of TARG, but only if not already in this list. + procedure Add_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr) + is + begin + for I in 1 .. Targ.Nbr_Ports loop + if Targ.Ports (I - 1) = Src then + return; + end if; + end loop; + Append_Port (Targ, Src); + end Add_Port; + + procedure Ghdl_Signal_Add_Source (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr) + is + begin + Check_New_Source (Targ); + Append_Port (Targ, Src); + end Ghdl_Signal_Add_Source; + + procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr; + Time : Std_Time) is + begin + if Sign.S.Resolv = null then + Internal_Error ("ghdl_signal_set_disconnect: not resolved"); + end if; + if Sign.S.Resolv.Disconnect_Time /= Bad_Time then + Error ("disconnection already specified for signal"); + end if; + if Time < 0 then + Error ("disconnection time is negative"); + end if; + Sign.S.Resolv.Disconnect_Time := Time; + end Ghdl_Signal_Set_Disconnect; + + procedure Direct_Assign + (Targ : out Value_Union; Val : Ghdl_Value_Ptr; Mode : Mode_Type) + is + begin + case Mode is + when Mode_B1 => + Targ.B1 := Val.B1; + when Mode_E8 => + Targ.E8 := Val.E8; + when Mode_E32 => + Targ.E32 := Val.E32; + when Mode_I32 => + Targ.I32 := Val.I32; + when Mode_I64 => + Targ.I64 := Val.I64; + when Mode_F64 => + Targ.F64 := Val.F64; + end case; + end Direct_Assign; + + function Value_Equal (Left, Right : Value_Union; Mode : Mode_Type) + return Boolean + is + begin + case Mode is + when Mode_B1 => + return Left.B1 = Right.B1; + when Mode_E8 => + return Left.E8 = Right.E8; + when Mode_E32 => + return Left.E32 = Right.E32; + when Mode_I32 => + return Left.I32 = Right.I32; + when Mode_I64 => + return Left.I64 = Right.I64; + when Mode_F64 => + return Left.F64 = Right.F64; + end case; + end Value_Equal; + + procedure Error_Trans_Error (Trans : Transaction_Acc) is + begin + Error_C ("range check error on signal at "); + Error_C (Trans.File); + Error_C (":"); + Error_C (Natural (Trans.Line)); + Error_E (""); + end Error_Trans_Error; + pragma No_Return (Error_Trans_Error); + + function Find_Driver (Sig : Ghdl_Signal_Ptr) return Ghdl_Index_Type + is + Proc : Process_Acc; + begin + if Sig.S.Drivers = null then + Error ("assignment to a signal without any driver"); + end if; + Proc := Get_Current_Process; + for I in 0 .. Sig.S.Nbr_Drivers - 1 loop + if Sig.S.Drivers (I).Proc = Proc then + return I; + end if; + end loop; + Error ("assignment to a signal without a driver for the process"); + end Find_Driver; + + function Get_Driver (Sig : Ghdl_Signal_Ptr) return Driver_Acc + is + Proc : Process_Acc; + begin + if Sig.S.Drivers = null then + return null; + end if; + Proc := Get_Current_Process; + for I in 0 .. Sig.S.Nbr_Drivers - 1 loop + if Sig.S.Drivers (I).Proc = Proc then + return Sig.S.Drivers (I)'Access; + end if; + end loop; + return null; + end Get_Driver; + + -- Return TRUE iff SIG has a future transaction for the current time, + -- ie iff SIG will be active in the next delta cycle. This is used to + -- recompute wether SIG must be in the active chain. SIG must be a user + -- signal. + function Has_Transaction_In_Next_Delta (Sig : Ghdl_Signal_Ptr) + return Boolean is + begin + if Sig.Is_Direct_Active then + return True; + end if; + + for I in 1 .. Sig.S.Nbr_Drivers loop + declare + Trans : constant Transaction_Acc := + Sig.S.Drivers (I - 1).First_Trans.Next; + begin + if Trans.Kind /= Trans_Direct + and then Trans.Time = Current_Time + then + return True; + end if; + end; + end loop; + return False; + end Has_Transaction_In_Next_Delta; + + -- Unused but well-known signal which always terminate + -- ghdl_signal_active_chain. + -- As a consequence, every element of the chain has a link field set to + -- a non-null value (this is of course not true for SIGNAL_END). This may + -- be used to quickly check if a signal is in the list. + -- This signal is not in the signal table. + Signal_End : Ghdl_Signal_Ptr; + + -- List of signals which have projected waveforms in the future (beyond + -- the next delta cycle). + Future_List : aliased Ghdl_Signal_Ptr; + + procedure Ghdl_Signal_Start_Assign (Sign : Ghdl_Signal_Ptr; + Reject : Std_Time; + Trans : Transaction_Acc; + After : Std_Time) + is + Assign_Time : Std_Time; + Drv : constant Ghdl_Index_Type := Find_Driver (Sign); + Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers; + Driver : Driver_Type renames Drv_Ptr (Drv); + begin + -- LRM93 8.4.1 + -- It is an error if the time expression in a waveform element + -- evaluates to a negative value. + if After < 0 then + Error ("negative time expression in signal assignment"); + end if; + + if After = 0 then + -- Put SIGN on the active list if the transaction is scheduled + -- for the next delta cycle. + if Sign.Link = null then + Sign.Link := Grt.Threads.Atomic_Insert + (Ghdl_Signal_Active_Chain'access, Sign); + end if; + else + -- AFTER > 0. + -- Put SIGN on the future list. + if Sign.Flink = null then + Sign.Flink := Grt.Threads.Atomic_Insert (Future_List'access, Sign); + end if; + end if; + + Assign_Time := Current_Time + After; + if Assign_Time < 0 then + -- Beyond the future + Free_In (Trans); + return; + end if; + + -- Handle sign as direct driver. + if Driver.Last_Trans.Kind = Trans_Direct then + if After /= 0 then + Internal_Error ("direct assign with non-0 after"); + end if; + -- FIXME: can be a bound-error too! + if Trans.Kind = Trans_Value then + case Sign.Mode is + when Mode_B1 => + Driver.Last_Trans.Val_Ptr.B1 := Trans.Val.B1; + when Mode_E8 => + Driver.Last_Trans.Val_Ptr.E8 := Trans.Val.E8; + when Mode_E32 => + Driver.Last_Trans.Val_Ptr.E32 := Trans.Val.E32; + when Mode_I32 => + Driver.Last_Trans.Val_Ptr.I32 := Trans.Val.I32; + when Mode_I64 => + Driver.Last_Trans.Val_Ptr.I64 := Trans.Val.I64; + when Mode_F64 => + Driver.Last_Trans.Val_Ptr.F64 := Trans.Val.F64; + end case; + Free_In (Trans); + elsif Trans.Kind = Trans_Error then + Error_Trans_Error (Trans); + else + Internal_Error ("direct assign with non-value"); + end if; + return; + end if; + + -- LRM93 8.4.1 + -- 1. All old transactions that are projected to occur at or after the + -- time at which the earliest new transaction is projected to occur + -- are deleted from the projected output waveform. + if Driver.Last_Trans.Time >= Assign_Time then + declare + -- LAST is the last transaction to keep. + Last : Transaction_Acc; + Next : Transaction_Acc; + begin + Last := Driver.First_Trans; + -- Find the first transaction to be deleted. + Next := Last.Next; + while Next /= null and then Next.Time < Assign_Time loop + Last := Next; + Next := Next.Next; + end loop; + -- Delete old transactions. + if Next /= null then + -- Set the last transaction of the driver. + Driver.Last_Trans := Last; + -- Cut the chain. This is not strickly necessary, since + -- it will be overriden below, by appending TRANS to the + -- driver. + Last.Next := null; + -- Free removed transactions. + loop + Last := Next.Next; + Free (Next); + exit when Last = null; + Next := Last; + end loop; + end if; + end; + end if; + + -- 2. The new transaction are then appended to the projected output + -- waveform in the order of their projected occurence. + Trans.Time := Assign_Time; + Driver.Last_Trans.Next := Trans; + Driver.Last_Trans := Trans; + + -- If the initial delay is inertial delay according to the definitions + -- of section 8.4, the projected output waveform is further modified + -- as follows: + -- 1. All of the new transactions are marked. + -- 2. An old transaction is marked if the time at which it is projected + -- to occur is less than the time at which the first new transaction + -- is projected to occur minus the pulse rejection limit. + -- 3. For each remaining unmarked, old transaction, the old transaction + -- is marked if it immediatly precedes a marked transaction and its + -- value component is the same as that of the marked transaction; + -- 4. The transaction that determines the current value of the driver + -- is marked. + -- 5. All unmarked transactions (all of which are old transactions) are + -- deleted from the projected output waveform. + -- + -- GHDL: only transactions that are projected to occur at [T-R, T[ + -- can be deleted (R is the reject time, T is now + after time). + if Reject > 0 then + -- LRM93 8.4 + -- It is an error if the pulse rejection limit for any inertially + -- delayed signal assignment statement is [...] or greater than the + -- time expression associated with the first waveform element. + if Reject > After then + Error ("pulse rejection greater than first waveform delay"); + end if; + + declare + Prev : Transaction_Acc; + Next : Transaction_Acc; + begin + -- Find the first transaction after the project time less the + -- rejection time. + -- PREV will be the last old transaction which is projected to + -- occur before T - R. + Prev := Driver.First_Trans; + loop + Next := Prev.Next; + exit when Next.Time >= Assign_Time - Reject; + Prev := Next; + end loop; + + -- Scan every transaction until TRANS. If a transaction value is + -- different from the TRANS value, then delete all previous + -- transactions (from T - R to the currently scanned transaction), + -- since they are not marked. + while Next /= Trans loop + if Next.Kind /= Trans.Kind + or else + (Trans.Kind = Trans_Value + and then not Value_Equal (Next.Val, Trans.Val, Sign.Mode)) + then + -- NEXT is different from TRANS. + -- Delete ]PREV;NEXT]. + declare + D, N : Transaction_Acc; + begin + D := Prev.Next; + Next := Next.Next; + Prev.Next := Next; + loop + N := D.Next; + Free (D); + exit when N = Next; + D := N; + end loop; + end; + else + Next := Next.Next; + end if; + end loop; + + -- A previous assignment (with a 0 after time) may have put this + -- signal on the active chain. But maybe this previous + -- transaction has been removed (due to rejection) and therefore + -- this signal won't be active at the next delta. So remove it + -- from the active chain. This is a little bit costly (because + -- the chain is simply linked), but that issue doesn't appear + -- frequently. + if Sign.Link /= null + and then not Has_Transaction_In_Next_Delta (Sign) + then + if Ghdl_Signal_Active_Chain = Sign then + -- At the head of the chain. + -- FIXME: this is not atomic. + Ghdl_Signal_Active_Chain := Sign.Link; + else + -- In the middle of the chain. + declare + Prev : Ghdl_Signal_Ptr := Ghdl_Signal_Active_Chain; + begin + while Prev.Link /= Sign loop + Prev := Prev.Link; + end loop; + Prev.Link := Sign.Link; + end; + end if; + Sign.Link := null; + end if; + end; + elsif Reject /= 0 then + -- LRM93 8.4 + -- It is an error if the pulse rejection limit for any inertially + -- delayed signal assignment statement is either negative or [...]. + Error ("pulse rejection is negative"); + end if; + + -- Do some checks. + if Driver.Last_Trans.Next /= null then + Error ("ghdl_signal_start_assign internal_error"); + end if; + end Ghdl_Signal_Start_Assign; + + procedure Ghdl_Signal_Next_Assign (Sign : Ghdl_Signal_Ptr; + Val : Value_Union; + After : Std_Time) + is + Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers; + Driver : Driver_Type renames Drv_Ptr (Find_Driver (Sign)); + + Trans : Transaction_Acc; + begin + if After > 0 and then Sign.Flink = null then + -- Put SIGN on the future list. + Sign.Flink := Future_List; + Future_List := Sign; + end if; + + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => Current_Time + After, + Next => null, + Val => Val); + if Trans.Time <= Driver.Last_Trans.Time then + Error ("transactions not in ascending order"); + end if; + Driver.Last_Trans.Next := Trans; + Driver.Last_Trans := Trans; + end Ghdl_Signal_Next_Assign; + + procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr) is + begin + if Sign.Link = null then + Sign.Link := Grt.Threads.Atomic_Insert + (Ghdl_Signal_Active_Chain'access, Sign); + end if; + + -- Must be always set (as Sign.Link may be set by a regular driver). + Sign.Is_Direct_Active := True; + end Ghdl_Signal_Direct_Assign; + + procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr; + File : Ghdl_C_String; + Line : Ghdl_I32) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction'(Kind => Trans_Error, + Line => Line, + Time => 0, + Next => null, + File => File); + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_Error; + + procedure Ghdl_Signal_Start_Assign_Error (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction'(Kind => Trans_Error, + Line => Line, + Time => 0, + Next => null, + File => File); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_Error; + + procedure Ghdl_Signal_Next_Assign_Error (Sign : Ghdl_Signal_Ptr; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32) + is + Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers; + Driver : Driver_Type renames Drv_Ptr (Find_Driver (Sign)); + + Trans : Transaction_Acc; + begin + if After > 0 and then Sign.Flink = null then + -- Put SIGN on the future list. + Sign.Flink := Future_List; + Future_List := Sign; + end if; + + Trans := new Transaction'(Kind => Trans_Error, + Line => Line, + Time => Current_Time + After, + Next => null, + File => File); + if Trans.Time <= Driver.Last_Trans.Time then + Error ("transactions not in ascending order"); + end if; + Driver.Last_Trans.Next := Trans; + Driver.Last_Trans := Trans; + end Ghdl_Signal_Next_Assign_Error; + + procedure Ghdl_Signal_Start_Assign_Null (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + if not Is_Signal_Guarded (Sign) then + Error ("null transaction for a non-guarded target"); + end if; + Trans := new Transaction'(Kind => Trans_Null, + Line => 0, + Time => 0, + Next => null); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_Null; + + procedure Ghdl_Signal_Disconnect (Sign : Ghdl_Signal_Ptr) + is + Trans : Transaction_Acc; + Time : Std_Time; + begin + if not Is_Signal_Guarded (Sign) then + Error ("null transaction for a non-guarded target"); + end if; + Trans := new Transaction'(Kind => Trans_Null, + Line => 0, + Time => 0, + Next => null); + Time := Sign.S.Resolv.Disconnect_Time; + Ghdl_Signal_Start_Assign (Sign, Time, Trans, Time); + end Ghdl_Signal_Disconnect; + + procedure Ghdl_Signal_Associate (Sig : Ghdl_Signal_Ptr; Val : Value_Union) + is + begin + Sig.Value := Val; + Sig.Driving_Value := Val; + end Ghdl_Signal_Associate; + + function Ghdl_Create_Signal_B1 + (Init_Val : Ghdl_B1; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_B1; + + procedure Ghdl_Signal_Init_B1 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_B1) is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_B1, B1 => Init_Val)); + end Ghdl_Signal_Init_B1; + + procedure Ghdl_Signal_Associate_B1 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_B1) is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_B1, B1 => Val)); + end Ghdl_Signal_Associate_B1; + + procedure Ghdl_Signal_Simple_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.B1 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_B1, B1 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_B1; + + procedure Ghdl_Signal_Start_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_B1; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_B1, B1 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_B1; + + procedure Ghdl_Signal_Next_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_B1, B1 => Val), After); + end Ghdl_Signal_Next_Assign_B1; + + function Ghdl_Create_Signal_E8 + (Init_Val : Ghdl_E8; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_E8, Value_Union'(Mode => Mode_E8, E8 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_E8; + + procedure Ghdl_Signal_Init_E8 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E8) is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_E8, E8 => Init_Val)); + end Ghdl_Signal_Init_E8; + + procedure Ghdl_Signal_Associate_E8 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E8) is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_E8, E8 => Val)); + end Ghdl_Signal_Associate_E8; + + procedure Ghdl_Signal_Simple_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.E8 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E8, E8 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_E8; + + procedure Ghdl_Signal_Start_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E8; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E8, E8 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_E8; + + procedure Ghdl_Signal_Next_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_E8, E8 => Val), After); + end Ghdl_Signal_Next_Assign_E8; + + function Ghdl_Create_Signal_E32 + (Init_Val : Ghdl_E32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_E32, Value_Union'(Mode => Mode_E32, E32 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_E32; + + procedure Ghdl_Signal_Init_E32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E32) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_E32, E32 => Init_Val)); + end Ghdl_Signal_Init_E32; + + procedure Ghdl_Signal_Associate_E32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E32) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_E32, E32 => Val)); + end Ghdl_Signal_Associate_E32; + + procedure Ghdl_Signal_Simple_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.E32 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E32, E32 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_E32; + + procedure Ghdl_Signal_Start_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E32; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E32, E32 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_E32; + + procedure Ghdl_Signal_Next_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_E32, E32 => Val), After); + end Ghdl_Signal_Next_Assign_E32; + + function Ghdl_Create_Signal_I32 + (Init_Val : Ghdl_I32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_I32, Value_Union'(Mode => Mode_I32, I32 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_I32; + + procedure Ghdl_Signal_Init_I32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I32) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_I32, I32 => Init_Val)); + end Ghdl_Signal_Init_I32; + + procedure Ghdl_Signal_Associate_I32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I32) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_I32, I32 => Val)); + end Ghdl_Signal_Associate_I32; + + procedure Ghdl_Signal_Simple_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.I32 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I32, I32 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_I32; + + procedure Ghdl_Signal_Start_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I32; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I32, I32 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_I32; + + procedure Ghdl_Signal_Next_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_I32, I32 => Val), After); + end Ghdl_Signal_Next_Assign_I32; + + function Ghdl_Create_Signal_I64 + (Init_Val : Ghdl_I64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_I64, Value_Union'(Mode => Mode_I64, I64 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_I64; + + procedure Ghdl_Signal_Init_I64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I64) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_I64, I64 => Init_Val)); + end Ghdl_Signal_Init_I64; + + procedure Ghdl_Signal_Associate_I64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I64) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_I64, I64 => Val)); + end Ghdl_Signal_Associate_I64; + + procedure Ghdl_Signal_Simple_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.I64 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I64, I64 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_I64; + + procedure Ghdl_Signal_Start_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I64; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I64, I64 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_I64; + + procedure Ghdl_Signal_Next_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_I64, I64 => Val), After); + end Ghdl_Signal_Next_Assign_I64; + + function Ghdl_Create_Signal_F64 + (Init_Val : Ghdl_F64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_F64, Value_Union'(Mode => Mode_F64, F64 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_F64; + + procedure Ghdl_Signal_Init_F64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_F64) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_F64, F64 => Init_Val)); + end Ghdl_Signal_Init_F64; + + procedure Ghdl_Signal_Associate_F64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_F64) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_F64, F64 => Val)); + end Ghdl_Signal_Associate_F64; + + procedure Ghdl_Signal_Simple_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.F64 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_F64, F64 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_F64; + + procedure Ghdl_Signal_Start_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_F64; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_F64, F64 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_F64; + + procedure Ghdl_Signal_Next_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_F64, F64 => Val), After); + end Ghdl_Signal_Next_Assign_F64; + + procedure Ghdl_Signal_Internal_Checks + is + Sig : Ghdl_Signal_Ptr; + begin + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + + -- Check drivers. + case Sig.S.Mode_Sig is + when Mode_Signal_User => + for J in 1 .. Sig.S.Nbr_Drivers loop + declare + Trans : Transaction_Acc; + begin + Trans := Sig.S.Drivers (J - 1).First_Trans; + while Trans.Next /= null loop + if Trans.Next.Time < Trans.Time then + Internal_Error ("ghdl_signal_internal_checks: " + & "bad transaction order"); + end if; + Trans := Trans.Next; + end loop; + if Trans /= Sig.S.Drivers (J - 1).Last_Trans then + Internal_Error ("ghdl_signal_internal_checks: " + & "last transaction mismatch"); + end if; + end; + end loop; + when others => + null; + end case; + end loop; + end Ghdl_Signal_Internal_Checks; + + procedure Ghdl_Signal_Effective_Value (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr) + is + begin + if Targ.S.Effective /= null then + Error ("internal error: already effective value"); + end if; + Targ.S.Effective := Src; + end Ghdl_Signal_Effective_Value; + + Bit_Signal_Rti : aliased Ghdl_Rtin_Object := + (Common => (Kind => Ghdl_Rtik_Signal, + Depth => 0, + Mode => Ghdl_Rti_Signal_Mode_None, + Max_Depth => 0), + Name => null, + Loc => Null_Rti_Loc, + Obj_Type => null); + + Boolean_Signal_Rti : aliased Ghdl_Rtin_Object := + (Common => (Kind => Ghdl_Rtik_Signal, + Depth => 0, + Mode => Ghdl_Rti_Signal_Mode_None, + Max_Depth => 0), + Name => null, + Loc => Null_Rti_Loc, + Obj_Type => null); + + function Ghdl_Create_Signal_Attribute + (Mode : Mode_Signal_Type; Time : Std_Time) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; +-- Sig_Type : Ghdl_Desc_Ptr; + begin + case Mode is + when Mode_Transaction => + Sig_Rti := To_Ghdl_Rtin_Object_Acc + (To_Ghdl_Rti_Access (Bit_Signal_Rti'Address)); + when Mode_Quiet + | Mode_Stable => + Sig_Rti := To_Ghdl_Rtin_Object_Acc + (To_Ghdl_Rti_Access (Boolean_Signal_Rti'Address)); + when others => + Internal_Error ("ghdl_create_signal_attribute"); + end case; + -- Note: bit and boolean are both mode_b1. + Res := Create_Signal + (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => True), + Mode, null, Null_Address); + Sig_Rti := null; + Last_Implicit_Signal := Res; + + if Mode /= Mode_Transaction then + Res.S.Time := Time; + Res.S.Attr_Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Res.Value); + end if; + + if Time > 0 then + Res.Flink := Future_List; + Future_List := Res; + end if; + + return Res; + end Ghdl_Create_Signal_Attribute; + + function Ghdl_Create_Stable_Signal (Val : Std_Time) return Ghdl_Signal_Ptr + is + begin + return Ghdl_Create_Signal_Attribute (Mode_Stable, Val); + end Ghdl_Create_Stable_Signal; + + function Ghdl_Create_Quiet_Signal (Val : Std_Time) return Ghdl_Signal_Ptr + is + begin + return Ghdl_Create_Signal_Attribute (Mode_Quiet, Val); + end Ghdl_Create_Quiet_Signal; + + function Ghdl_Create_Transaction_Signal return Ghdl_Signal_Ptr + is + begin + return Ghdl_Create_Signal_Attribute (Mode_Transaction, 0); + end Ghdl_Create_Transaction_Signal; + + procedure Ghdl_Signal_Attribute_Register_Prefix (Sig : Ghdl_Signal_Ptr) + is + begin + Add_Port (Last_Implicit_Signal, Sig); + end Ghdl_Signal_Attribute_Register_Prefix; + + --Guard_String : constant String := "guard"; + --Guard_Name : constant Ghdl_Str_Len_Address_Type := + -- (Len => 5, Str => Guard_String'Address); + --function To_Ghdl_Str_Len_Ptr is new Ada.Unchecked_Conversion + -- (Source => System.Address, Target => Ghdl_Str_Len_Ptr); + + Guard_Rti : aliased constant Ghdl_Rtin_Object := + (Common => (Kind => Ghdl_Rtik_Signal, + Depth => 0, + Mode => Ghdl_Rti_Signal_Mode_None, + Max_Depth => 0), + Name => null, + Loc => Null_Rti_Loc, + Obj_Type => Std_Standard_Boolean_RTI_Ptr); + + function Ghdl_Signal_Create_Guard (This : System.Address; + Proc : Guard_Func_Acc) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; + begin + Sig_Rti := To_Ghdl_Rtin_Object_Acc + (To_Ghdl_Rti_Access (Guard_Rti'Address)); + Res := Create_Signal + (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => Proc.all (This)), + Mode_Guard, null, Null_Address); + Sig_Rti := null; + Res.S.Guard_Func := Proc; + Res.S.Guard_Instance := This; + Last_Implicit_Signal := Res; + return Res; + end Ghdl_Signal_Create_Guard; + + procedure Ghdl_Signal_Guard_Dependence (Sig : Ghdl_Signal_Ptr) + is + begin + Add_Port (Last_Implicit_Signal, Sig); + Sig.Has_Active := True; + end Ghdl_Signal_Guard_Dependence; + + function Ghdl_Create_Delayed_Signal (Sig : Ghdl_Signal_Ptr; Val : Std_Time) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; + begin + Res := Create_Signal (Sig.Mode, Sig.Value, + Mode_Delayed, null, Null_Address); + Res.S.Time := Val; + if Val > 0 then + Res.Flink := Future_List; + Future_List := Res; + end if; + Res.S.Attr_Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Res.Value); + Append_Port (Res, Sig); + return Res; + end Ghdl_Create_Delayed_Signal; + + function Signal_Ptr_To_Index (Ptr : Ghdl_Signal_Ptr) return Sig_Table_Index + is + begin + -- Note: we may start from ptr.instance_name.sig_index, but + -- instance_name is *not* set for conversion signals. + for I in reverse Sig_Table.First .. Sig_Table.Last loop + if Sig_Table.Table (I) = Ptr then + return I; + end if; + end loop; + return -1; + end Signal_Ptr_To_Index; + + function Ghdl_Signal_Get_Nbr_Ports (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type is + begin + return Sig.Nbr_Ports; + end Ghdl_Signal_Get_Nbr_Ports; + + function Ghdl_Signal_Get_Nbr_Drivers (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type is + begin + return Sig.S.Nbr_Drivers; + end Ghdl_Signal_Get_Nbr_Drivers; + + function Ghdl_Signal_Read_Port + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr + is + begin + if Index >= Sig.Nbr_Ports then + Internal_Error ("ghdl_signal_read_port: bad index"); + end if; + return To_Ghdl_Value_Ptr (Sig.Ports (Index).Driving_Value'Address); + end Ghdl_Signal_Read_Port; + + function Ghdl_Signal_Read_Driver + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr + is + Trans : Transaction_Acc; + begin + if Index >= Sig.S.Nbr_Drivers then + Internal_Error ("ghdl_signal_read_driver: bad index"); + end if; + Trans := Sig.S.Drivers (Index).First_Trans; + case Trans.Kind is + when Trans_Value => + return To_Ghdl_Value_Ptr (Trans.Val'Address); + when Trans_Direct => + Internal_Error ("ghdl_signal_read_driver: trans_direct"); + when Trans_Null => + return null; + when Trans_Error => + Error_Trans_Error (Trans); + end case; + end Ghdl_Signal_Read_Driver; + + procedure Ghdl_Signal_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type; + Mode : Mode_Signal_Type) + is + Data : Sig_Conversion_Acc; + Sig : Ghdl_Signal_Ptr; + begin + Data := new Sig_Conversion_Type'(Func => Func, + Instance => Instance, + Src => (-1, -1), + Dest => (-1, -1)); + Data.Src.First := Signal_Ptr_To_Index (Src); + Data.Src.Last := Data.Src.First + Sig_Table_Index (Src_Len) - 1; + + Data.Dest.First := Signal_Ptr_To_Index (Dst); + Data.Dest.Last := Data.Dest.First + Sig_Table_Index (Dst_Len) - 1; + + -- Convert DEST to new mode. + for I in Data.Dest.First .. Data.Dest.Last loop + Sig := Sig_Table.Table (I); + case Mode is + when Mode_Conv_In => + Sig.S := (Mode_Sig => Mode_Conv_In, + Conv => Data); + when Mode_Conv_Out => + Sig.S := (Mode_Sig => Mode_Conv_Out, + Conv => Data); + when others => + Internal_Error ("ghdl_signal_conversion"); + end case; + end loop; + end Ghdl_Signal_Conversion; + + procedure Ghdl_Signal_In_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type) + is + begin + Ghdl_Signal_Conversion + (Func, Instance, Src, Src_Len, Dst, Dst_Len, Mode_Conv_In); + end Ghdl_Signal_In_Conversion; + + procedure Ghdl_Signal_Out_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type) + is + begin + Ghdl_Signal_Conversion + (Func, Instance, Src, Src_Len, Dst, Dst_Len, Mode_Conv_Out); + end Ghdl_Signal_Out_Conversion; + + function Ghdl_Signal_Driving (Sig : Ghdl_Signal_Ptr) return Ghdl_B1 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null then + -- FIXME: disp signal and process. + Error ("'driving error: no driver in process for signal"); + end if; + if Drv.First_Trans.Kind /= Trans_Null then + return True; + else + return False; + end if; + end Ghdl_Signal_Driving; + + function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr) return Ghdl_B1 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.B1; + end if; + end Ghdl_Signal_Driving_Value_B1; + + function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E8 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.E8; + end if; + end Ghdl_Signal_Driving_Value_E8; + + function Ghdl_Signal_Driving_Value_E32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E32 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.E32; + end if; + end Ghdl_Signal_Driving_Value_E32; + + function Ghdl_Signal_Driving_Value_I32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I32 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.I32; + end if; + end Ghdl_Signal_Driving_Value_I32; + + function Ghdl_Signal_Driving_Value_I64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I64 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.I64; + end if; + end Ghdl_Signal_Driving_Value_I64; + + function Ghdl_Signal_Driving_Value_F64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_F64 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.F64; + end if; + end Ghdl_Signal_Driving_Value_F64; + + Ghdl_Implicit_Signal_Active_Chain : Ghdl_Signal_Ptr; + + procedure Flush_Active_List + is + Sig : Ghdl_Signal_Ptr; + Next_Sig : Ghdl_Signal_Ptr; + begin + -- Free active_chain. + Sig := Ghdl_Signal_Active_Chain; + loop + Next_Sig := Sig.Link; + exit when Next_Sig = null; + Sig.Link := null; + Sig := Next_Sig; + end loop; + Ghdl_Signal_Active_Chain := Sig; + end Flush_Active_List; + + function Find_Next_Time return Std_Time + is + Res : Std_Time; + Sig : Ghdl_Signal_Ptr; + + procedure Check_Transaction (Trans : Transaction_Acc) + is + begin + if Trans = null or else Trans.Kind = Trans_Direct then + -- Activity of direct drivers is done through link. + return; + end if; + + if Trans.Time = Res and Sig.Link = null then + Sig.Link := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Sig; + elsif Trans.Time < Res then + Flush_Active_List; + + -- Put sig on the list. + Sig.Link := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Sig; + + Res := Trans.Time; + end if; + if Res = Current_Time then + -- Must have been in the active list. + Internal_Error ("find_next_time(2)"); + end if; + end Check_Transaction; + begin + -- If there is signals in the active list, then next cycle is a delta + -- cycle, so next time is current_time. + if Ghdl_Signal_Active_Chain.Link /= null then + return Current_Time; + end if; + if Ghdl_Implicit_Signal_Active_Chain.Link /= null then + return Current_Time; + end if; + Res := Std_Time'Last; + + Sig := Future_List; + while Sig.Flink /= null loop + case Sig.S.Mode_Sig is + when Mode_Signal_User => + for J in 1 .. Sig.S.Nbr_Drivers loop + Check_Transaction (Sig.S.Drivers (J - 1).First_Trans.Next); + end loop; + when Mode_Delayed + | Mode_Stable + | Mode_Quiet => + Check_Transaction (Sig.S.Attr_Trans.Next); + when others => + Internal_Error ("find_next_time(3)"); + end case; + Sig := Sig.Flink; + end loop; + return Res; + end Find_Next_Time; + +-- function Get_Nbr_Non_Null_Source (Sig : Ghdl_Signal_Ptr) +-- return Natural +-- is +-- Length : Natural; +-- begin +-- Length := Sig.Nbr_Ports; +-- for I in 0 .. Sig.Nbr_Drivers - 1 loop +-- case Sig.Drivers (I).First_Trans.Kind is +-- when Trans_Value => +-- Length := Length + 1; +-- when Trans_Null => +-- null; +-- when Trans_Error => +-- Error ("range check error"); +-- end case; +-- end loop; +-- return Length; +-- end Get_Nbr_Non_Null_Source; + + function To_Resolver_Acc is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Resolver_Acc); + + procedure Compute_Resolved_Signal (Resolv : Resolved_Signal_Acc) + is + Sig : constant Ghdl_Signal_Ptr := + Sig_Table.Table (Resolv.Sig_Range.First); + Length : Ghdl_Index_Type; + type Bool_Array_Type is array (1 .. Sig.S.Nbr_Drivers) of Boolean; + Vec : Bool_Array_Type; + begin + -- Compute number of non-null drivers. + Length := 0; + for I in 1 .. Sig.S.Nbr_Drivers loop + case Sig.S.Drivers (I - 1).First_Trans.Kind is + when Trans_Value => + Length := Length + 1; + Vec (I) := True; + when Trans_Null => + Vec (I) := False; + when Trans_Error => + Error ("range check error"); + when Trans_Direct => + Internal_Error ("compute_resolved_signal: trans_direct"); + end case; + end loop; + + -- Check driving condition on all signals. + for J in Resolv.Sig_Range.First + 1.. Resolv.Sig_Range.Last loop + for I in 1 .. Sig.S.Nbr_Drivers loop + if (Sig_Table.Table (J).S.Drivers (I - 1).First_Trans.Kind + /= Trans_Null) + xor Vec (I) + then + Error ("null-transaction required"); + end if; + end loop; + end loop; + + -- if no driving sources and register, exit. + if Length = 0 + and then Sig.Nbr_Ports = 0 + and then Sig.Sig_Kind = Kind_Signal_Register + then + return; + end if; + + -- Call the procedure. + Resolv.Resolv_Proc.all (Resolv.Resolv_Inst, + Resolv.Resolv_Ptr, + Vec'Address, + Length, + Sig.S.Nbr_Drivers, + Sig.Nbr_Ports); + end Compute_Resolved_Signal; + + procedure Call_Conversion_Function (Conv : Sig_Conversion_Acc) + is + F : Conversion_Func_Acc; + begin + F := To_Conversion_Func_Acc (Conv.Func); + F.all (Conv.Instance); + end Call_Conversion_Function; + + procedure Resume_Process_If_Event + (Sig : Ghdl_Signal_Ptr; Proc : Process_Acc) + is + El : Action_List_Acc; + begin + El := new Action_List'(Dynamic => False, + Proc => Proc, + Next => Sig.Event_List); + Sig.Event_List := El; + end Resume_Process_If_Event; + + -- Order of signals: + -- To be computed: driving value or/and effective value + -- To be considered: ports, signals, implicit signals, resolution, + -- conversion + -- + + procedure Add_Propagation (P : Propagation_Type) is + begin + Propagation.Increment_Last; + Propagation.Table (Propagation.Last) := P; + end Add_Propagation; + + procedure Add_Forward_Propagation (Sig : Ghdl_Signal_Ptr) + is + begin + for I in 1 .. Sig.Nbr_Ports loop + Add_Propagation + ((Kind => Imp_Forward_Build, + Forward => new Forward_Build_Type'(Src => Sig.Ports (I - 1), + Targ => Sig))); + end loop; + end Add_Forward_Propagation; + + -- Put SIG in PROPAGATION table until ORDER level. + procedure Order_Signal (Sig : Ghdl_Signal_Ptr; Order : Propag_Order_Flag); + + -- Return TRUE is the effective value of SIG is the driving value of SIG. + function Is_Eff_Drv (Sig : Ghdl_Signal_Ptr) return Boolean + is + begin + case Sig.S.Mode_Sig is + when Mode_Signal + | Mode_Buffer => + return True; + when Mode_Linkage + | Mode_Out => + -- No effective value. + return False; + when Mode_Inout + | Mode_In => + if Sig.S.Effective = null then + if Sig.S.Nbr_Drivers > 0 or Sig.Nbr_Ports > 0 then + -- Only for inout. + return True; + else + return False; + end if; + else + return False; + end if; + when Mode_Conv_In + | Mode_Conv_Out => + return False; + when Mode_Stable + | Mode_Guard + | Mode_Quiet + | Mode_Transaction + | Mode_Delayed => + return True; + when Mode_End => + return False; + end case; + end Is_Eff_Drv; + + procedure Order_Signal_List (Sig : Ghdl_Signal_Ptr; + Order : Propag_Order_Flag) + is + begin + for I in 1 .. Sig.Nbr_Ports loop + Order_Signal (Sig.Ports (I - 1), Order); + end loop; + end Order_Signal_List; + + -- Put SIG in PROPAGATION table until ORDER level. + procedure Order_Signal (Sig : Ghdl_Signal_Ptr; Order : Propag_Order_Flag) + is + begin + if Sig = null then + return; + end if; + + -- Catch infinite loops, which must never happen. + -- Also exit if the signal is already fully ordered. + case Sig.Flags.Propag is + when Propag_None => + null; + when Propag_Being_Driving => + Internal_Error ("order_signal: being driving"); + when Propag_Being_Effective => + Internal_Error ("order_signal: being effective"); + when Propag_Driving => + null; + when Propag_Done => + -- If sig was already handled, nothing to do! + return; + end case; + + -- First, the driving value. + if Sig.Flags.Propag = Propag_None then + case Sig.S.Mode_Sig is + when Mode_Signal_User => + if Sig.S.Nbr_Drivers = 0 and Sig.Nbr_Ports = 0 then + -- No source. + Sig.Flags.Propag := Propag_Driving; + elsif Sig.S.Resolv = null then + -- Not resolved (so at most one source). + if Sig.S.Nbr_Drivers = 1 then + -- Not resolved, 1 source : a driver. + if Is_Eff_Drv (Sig) then + Add_Propagation ((Kind => Eff_One_Driver, Sig => Sig)); + Sig.Flags.Propag := Propag_Done; + else + Add_Propagation ((Kind => Drv_One_Driver, Sig => Sig)); + Sig.Flags.Propag := Propag_Driving; + end if; + else + Sig.Flags.Propag := Propag_Being_Driving; + -- not resolved, 1 source : Source is a port. + Order_Signal (Sig.Ports (0), Propag_Driving); + if Is_Eff_Drv (Sig) then + Add_Propagation ((Kind => Eff_One_Port, Sig => Sig)); + Sig.Flags.Propag := Propag_Done; + else + Add_Propagation ((Kind => Drv_One_Port, Sig => Sig)); + Sig.Flags.Propag := Propag_Driving; + end if; + end if; + else + -- Resolved signal. + declare + Resolv : Resolved_Signal_Acc; + S : Ghdl_Signal_Ptr; + begin + -- Compute driving value of brothers. + Resolv := Sig.S.Resolv; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + S := Sig_Table.Table (I); + if S.Flags.Propag /= Propag_None then + Internal_Error ("order_signal(1)"); + end if; + S.Flags.Propag := Propag_Being_Driving; + end loop; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + S := Sig_Table.Table (I); + -- Compute driving value of the sources. + for J in 1 .. S.Nbr_Ports loop + Order_Signal (S.Ports (J - 1), Propag_Driving); + end loop; + end loop; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + S := Sig_Table.Table (I); + S.Flags.Propag := Propag_Driving; + end loop; + + if Is_Eff_Drv (Sig) then + if Resolv.Sig_Range.First = Resolv.Sig_Range.Last then + Add_Propagation ((Kind => Eff_One_Resolved, + Sig => Sig)); + else + Add_Propagation ((Kind => Eff_Multiple, + Resolv => Resolv)); + end if; + else + if Resolv.Sig_Range.First = Resolv.Sig_Range.Last then + Add_Propagation ((Kind => Drv_One_Resolved, + Sig => Sig)); + else + Add_Propagation ((Kind => Drv_Multiple, + Resolv => Resolv)); + end if; + end if; + end; + end if; + when Mode_Signal_Implicit => + Sig.Flags.Propag := Propag_Being_Driving; + Order_Signal_List (Sig, Propag_Done); + Sig.Flags.Propag := Propag_Done; + if Sig.S.Mode_Sig in Mode_Signal_Forward then + Add_Forward_Propagation (Sig); + end if; + case Mode_Signal_Implicit (Sig.S.Mode_Sig) is + when Mode_Guard => + Add_Propagation ((Kind => Imp_Guard, Sig => Sig)); + when Mode_Stable => + Add_Propagation ((Kind => Imp_Stable, Sig => Sig)); + when Mode_Quiet => + Add_Propagation ((Kind => Imp_Quiet, Sig => Sig)); + when Mode_Transaction => + Add_Propagation ((Kind => Imp_Transaction, Sig => Sig)); + when Mode_Delayed => + Add_Propagation ((Kind => Imp_Delayed, Sig => Sig)); + end case; + return; + when Mode_Conv_In => + -- In conversion signals have no driving value + null; + when Mode_Conv_Out => + declare + Conv : Sig_Conversion_Acc; + begin + Conv := Sig.S.Conv; + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Being_Driving; + end loop; + for I in Conv.Src.First .. Conv.Src.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Driving); + end loop; + Add_Propagation ((Kind => Out_Conversion, Conv => Conv)); + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Done; + end loop; + end; + when Mode_End => + Internal_Error ("order_signal: mode_end"); + end case; + end if; + + -- Effective value. + if Order = Propag_Driving then + -- Will be done later. + return; + end if; + + case Sig.S.Mode_Sig is + when Mode_Signal + | Mode_Buffer => + -- Effective value is driving value. + Sig.Flags.Propag := Propag_Done; + when Mode_Linkage + | Mode_Out => + -- No effective value. + Sig.Flags.Propag := Propag_Done; + when Mode_Inout + | Mode_In => + if Sig.S.Effective = null then + -- Effective value is driving value or initial value. + null; + else + Sig.Flags.Propag := Propag_Being_Effective; + Order_Signal (Sig.S.Effective, Propag_Done); + Add_Propagation ((Kind => Eff_Actual, Sig => Sig)); + Sig.Flags.Propag := Propag_Done; + end if; + when Mode_Stable + | Mode_Guard + | Mode_Quiet + | Mode_Transaction + | Mode_Delayed => + -- Sig.Propag is already set to PROPAG_DONE. + null; + when Mode_Conv_In => + declare + Conv : Sig_Conversion_Acc; + begin + Conv := Sig.S.Conv; + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Being_Effective; + end loop; + for I in Conv.Src.First .. Conv.Src.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Done); + end loop; + Add_Propagation ((Kind => In_Conversion, Conv => Conv)); + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Done; + end loop; + end; + when Mode_Conv_Out => + -- No effective value. + null; + when Mode_End => + Internal_Error ("order_signal: mode_end"); + end case; + end Order_Signal; + + procedure Set_Net (Sig : Ghdl_Signal_Ptr; + Net : Signal_Net_Type; + Link : Ghdl_Signal_Ptr) + is + use Astdio; + use Stdio; + begin + if Sig = null then + return; + end if; + + if Boolean'(False) then + Put ("set_net "); + Put_I32 (stdout, Ghdl_I32 (Net)); + Put (" on "); + Put (stdout, Sig.all'Address); + Put (" "); + Disp_Signals.Disp_Mode_Signal (Sig.S.Mode_Sig); + New_Line; + end if; + + if Sig.Net /= No_Signal_Net then + if Sig.Net /= Net then + -- Renumber. + if Boolean'(False) then + Put ("set_net renumber "); + Put_I32 (stdout, Ghdl_I32 (Net)); + Put (" on "); + Put (stdout, Sig.all'Address); + New_Line; + end if; + + declare + S : Ghdl_Signal_Ptr; + Old : constant Signal_Net_Type := Sig.Net; + begin + -- Merge the old net into NET. + S := Sig; + loop + S.Net := Net; + S := S.Link; + exit when S = Sig; + end loop; + + -- Add to the ring. + S := Sig.Link; + Sig.Link := Link.Link; + Link.Link := S; + + -- Check. + for I in Sig_Table.First .. Sig_Table.Last loop + if Sig_Table.Table (I).Net = Old then +-- Disp_Signals.Disp_Signals_Table; +-- Disp_Signals.Disp_Signals_Map; + + Internal_Error ("set_net: link corrupted"); + end if; + end loop; + end; + end if; + return; + end if; + + Sig.Net := Net; + + -- Add SIG in the LINK ring. + -- Note: this works even if LINK is not a ring (ie, LINK.link = null). + if Link.Link = null and then Sig /= Link then + Internal_Error ("set_net: bad link"); + end if; + Sig.Link := Link.Link; + Link.Link := Sig; + + -- Dependences. + case Sig.S.Mode_Sig is + when Mode_Signal_User => + for I in 1 .. Sig.Nbr_Ports loop + Set_Net (Sig.Ports (I - 1), Net, Link); + end loop; + Set_Net (Sig.S.Effective, Net, Link); + if Sig.S.Resolv /= null then + for I in Sig.S.Resolv.Sig_Range.First + .. Sig.S.Resolv.Sig_Range.Last + loop + Set_Net (Sig_Table.Table (I), Net, Link); + end loop; + end if; + when Mode_Signal_Forward => + null; + when Mode_Transaction + | Mode_Guard => + for I in 1 .. Sig.Nbr_Ports loop + Set_Net (Sig.Ports (I - 1), Net, Link); + end loop; + when Mode_Conv_In + | Mode_Conv_Out => + declare + S : Ghdl_Signal_Ptr; + Conv : Sig_Conversion_Acc; + begin + Conv := Sig.S.Conv; + S := Sig_Table.Table (Conv.Src.First); + if Sig = S or else S.Net /= Net then + for J in Conv.Src.First .. Conv.Src.Last loop + Set_Net (Sig_Table.Table (J), Net, Link); + end loop; + for J in Conv.Dest.First .. Conv.Dest.Last loop + Set_Net (Sig_Table.Table (J), Net, Link); + end loop; + end if; + end; + when Mode_End => + Internal_Error ("set_net"); + end case; + end Set_Net; + + function Get_Propagation_Net (P : Signal_Net_Type) return Signal_Net_Type + is + begin + case Propagation.Table (P).Kind is + when Drv_Multiple + | Eff_Multiple => + return Sig_Table.Table + (Propagation.Table (P).Resolv.Sig_Range.First).Net; + when In_Conversion + | Out_Conversion => + return Sig_Table.Table + (Propagation.Table (P).Conv.Src.First).Net; + when Imp_Forward_Build => + return Propagation.Table (P).Forward.Src.Net; + when others => + return Propagation.Table (P).Sig.Net; + end case; + end Get_Propagation_Net; + + Last_Signal_Net : Signal_Net_Type; + + -- Create a net for SIG, or if one of its dependences has already a net, + -- merge SIG in this net. + procedure Merge_Net (Sig : Ghdl_Signal_Ptr) + is + begin + if Sig.S.Mode_Sig in Mode_Signal_User then + if Sig.S.Resolv = null + and then Sig.Nbr_Ports = 0 + and then Sig.S.Effective = null + then + Internal_Error ("merge_net(1)"); + end if; + + if Sig.S.Effective /= null + and then Sig.S.Effective.Net /= No_Signal_Net + then + -- Avoid to create a net, just merge. + Set_Net (Sig, Sig.S.Effective.Net, Sig.S.Effective); + return; + end if; + end if; + + if Sig.Nbr_Ports >= 1 + and then Sig.Ports (0).Net /= No_Signal_Net + then + -- Avoid to create a net, just merge. + Set_Net (Sig, Sig.Ports (0).Net, Sig.Ports (0)); + else + Last_Signal_Net := Last_Signal_Net + 1; + Set_Net (Sig, Last_Signal_Net, Sig); + end if; + end Merge_Net; + + -- Create nets. + -- For all signals, set the net field. + procedure Create_Nets + is + Sig : Ghdl_Signal_Ptr; + begin + Last_Signal_Net := No_Signal_Net; + + for I in reverse Propagation.First .. Propagation.Last loop + case Propagation.Table (I).Kind is + when Drv_Error + | Prop_End => + null; + when Drv_One_Driver + | Eff_One_Driver => + null; + when Eff_One_Resolved => + Sig := Propagation.Table (I).Sig; + -- Do not create a net if the signal has no dependences. + if Sig.Net = No_Signal_Net + and then (Sig.S.Effective /= null or Sig.Nbr_Ports /= 0) + then + Merge_Net (Sig); + end if; + when Drv_One_Port + | Eff_One_Port + | Imp_Guard + | Imp_Transaction + | Eff_Actual + | Drv_One_Resolved => + Sig := Propagation.Table (I).Sig; + if Sig.Net = No_Signal_Net then + Merge_Net (Sig); + end if; + when Imp_Forward => + -- Should not yet appear. + Internal_Error ("create_nets - forward"); + when Imp_Forward_Build => + Sig := Propagation.Table (I).Forward.Src; + if Sig.Net = No_Signal_Net then + -- Create a new net with only sig. + Last_Signal_Net := Last_Signal_Net + 1; + Set_Net (Sig, Last_Signal_Net, Sig); + end if; + when Imp_Quiet + | Imp_Stable + | Imp_Delayed => + Sig := Propagation.Table (I).Sig; + if Sig.Net = No_Signal_Net then + -- Create a new net with only sig. + Last_Signal_Net := Last_Signal_Net + 1; + Sig.Net := Last_Signal_Net; + Sig.Link := Sig; + end if; + when Drv_Multiple + | Eff_Multiple => + declare + Resolv : Resolved_Signal_Acc; + Link : Ghdl_Signal_Ptr; + begin + Last_Signal_Net := Last_Signal_Net + 1; + Resolv := Propagation.Table (I).Resolv; + Link := Sig_Table.Table (Resolv.Sig_Range.First); + for J in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop + Set_Net (Sig_Table.Table (J), Last_Signal_Net, Link); + end loop; + end; + when In_Conversion + | Out_Conversion => + declare + Conv : Sig_Conversion_Acc; + Link : Ghdl_Signal_Ptr; + begin + Conv := Propagation.Table (I).Conv; + Link := Sig_Table.Table (Conv.Src.First); + if Link.Net = No_Signal_Net then + Last_Signal_Net := Last_Signal_Net + 1; + Set_Net (Link, Last_Signal_Net, Link); + end if; + end; + end case; + end loop; + + -- Reorder propagation table. + declare + type Off_Array is array (Signal_Net_Type range <>) of Signal_Net_Type; + Offs : Off_Array (0 .. Last_Signal_Net) := (others => 0); + + Last_Off : Signal_Net_Type; + Num : Signal_Net_Type; + +-- procedure Disp_Offs +-- is +-- use Grt.Astdio; +-- use Grt.Stdio; +-- begin +-- for I in Offs'Range loop +-- if Offs (I) /= 0 then +-- Put_I32 (stdout, Ghdl_I32 (I)); +-- Put (": "); +-- Put_I32 (stdout, Ghdl_I32 (Offs (I))); +-- New_Line; +-- end if; +-- end loop; +-- end Disp_Offs; + + type Propag_Array is array (Signal_Net_Type range <>) + of Propagation_Type; + + procedure Deallocate is new Ada.Unchecked_Deallocation + (Object => Forward_Build_Type, Name => Forward_Build_Acc); + + Net : Signal_Net_Type; + begin + -- 1) Count number of propagation cell per net. + for I in Propagation.First .. Propagation.Last loop + Net := Get_Propagation_Net (I); + Offs (Net) := Offs (Net) + 1; + end loop; + + -- 2) Convert numbers to offsets. + Last_Off := 1; + for I in 1 .. Last_Signal_Net loop + Num := Offs (I); + if Num /= 0 then + -- Reserve one slot for a prepended 'prop_end'. + Offs (I) := Last_Off + 1; + Last_Off := Last_Off + 1 + Num; + end if; + end loop; + Offs (0) := Last_Off + 1; + + declare + Propag : Propag_Array (1 .. Last_Off); -- := (others => 0); + begin + for I in Propagation.First .. Propagation.Last loop + Net := Get_Propagation_Net (I); + if Net /= No_Signal_Net then + Propag (Offs (Net)) := Propagation.Table (I); + Offs (Net) := Offs (Net) + 1; + end if; + end loop; + Propagation.Set_Last (Last_Off); + Propagation.Release; + for I in Propagation.First .. Propagation.Last loop + if Propag (I).Kind = Imp_Forward_Build then + Propagation.Table (I) := (Kind => Imp_Forward, + Sig => Propag (I).Forward.Targ); + Deallocate (Propag (I).Forward); + else + Propagation.Table (I) := Propag (I); + end if; + end loop; + end; + for I in 1 .. Last_Signal_Net loop + -- Ignore holes. + if Offs (I) /= 0 then + Propagation.Table (Offs (I)) := + (Kind => Prop_End, Updated => True); + end if; + end loop; + Propagation.Table (1) := (Kind => Prop_End, Updated => True); + + -- 4) Convert back from offset to start position (on the prop_end + -- cell). + Offs (0) := 1; + Last_Off := 1; + for I in 1 .. Last_Signal_Net loop + if Offs (I) /= 0 then + Num := Offs (I); + Offs (I) := Last_Off; + Last_Off := Num; + end if; + end loop; + + -- 5) Re-map the nets to cell indexes. + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + if Sig.Net = No_Signal_Net then + if Sig.S.Resolv /= null then + Sig.Net := Net_One_Resolved; + elsif Sig.S.Nbr_Drivers = 1 then + if Sig.S.Drivers (0).Last_Trans.Kind = Trans_Direct then + Sig.Net := Net_One_Direct; + else + Sig.Net := Net_One_Driver; + end if; + end if; + else + Sig.Net := Offs (Sig.Net); + end if; + Sig.Link := null; + end loop; + end; + end Create_Nets; + + function Get_Nbr_Future return Ghdl_I32 + is + Res : Ghdl_I32; + Sig : Ghdl_Signal_Ptr; + begin + Res := 0; + Sig := Future_List; + while Sig.Flink /= null loop + Res := Res + 1; + Sig := Sig.Flink; + end loop; + return Res; + end Get_Nbr_Future; + + -- Check every scalar subelement of a resolved signal has a driver + -- in the same process. + procedure Check_Resolved_Driver (Resolv : Resolved_Signal_Acc) + is + First_Sig : Ghdl_Signal_Ptr; + Nbr : Ghdl_Index_Type; + begin + First_Sig := Sig_Table.Table (Resolv.Sig_Range.First); + Nbr := First_Sig.S.Nbr_Drivers; + for I in Resolv.Sig_Range.First + 1 .. Resolv.Sig_Range.Last loop + if Sig_Table.Table (I).S.Nbr_Drivers /= Nbr then + -- FIXME: provide more information (signal name, process name). + Error ("missing drivers for subelement of a resolved signal"); + end if; + end loop; + end Check_Resolved_Driver; + + Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address; + pragma Import (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr, + "ieee__std_logic_1164__resolved_RESOLV_ptr"); + + procedure Free is new Ada.Unchecked_Deallocation + (Name => Resolved_Signal_Acc, Object => Resolved_Signal_Type); + + procedure Order_All_Signals + is + Sig : Ghdl_Signal_Ptr; + Resolv : Resolved_Signal_Acc; + begin + -- Do checks and optimization. + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + + -- LRM 5.3 + -- If, by the above rules, no disconnection specification applies to + -- the drivers of a guarded, scalar signal S whose type mark is T + -- (including a scalar subelement of a composite signal), then the + -- following default disconnection specification is implicitly + -- assumed: + -- disconnect S : T after 0 ns; + if Sig.S.Mode_Sig in Mode_Signal_User then + Resolv := Sig.S.Resolv; + if Resolv /= null and then Resolv.Disconnect_Time = Bad_Time then + Resolv.Disconnect_Time := 0; + end if; + + if Resolv /= null + and then Resolv.Sig_Range.First = I + and then Resolv.Sig_Range.Last > I + then + -- Check every scalar subelement of a resolved signal + -- has a driver in the same process. + Check_Resolved_Driver (Resolv); + end if; + + if Resolv /= null + and then Resolv.Sig_Range.First = I + and then Resolv.Sig_Range.Last = I + and then + (Resolv.Resolv_Proc + = To_Resolver_Acc (Ieee_Std_Logic_1164_Resolved_Resolv_Ptr)) + and then Sig.S.Nbr_Drivers + Sig.Nbr_Ports <= 1 + then + -- Optimization: remove resolver if there is at most one + -- source. + Free (Sig.S.Resolv); + end if; + end if; + end loop; + + -- Really order them. + for I in Sig_Table.First .. Sig_Table.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Driving); + end loop; + for I in Sig_Table.First .. Sig_Table.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Done); + end loop; + + Create_Nets; + end Order_All_Signals; + + -- Add SIG in active_chain. + procedure Add_Active_Chain (Sig : Ghdl_Signal_Ptr); + pragma Inline (Add_Active_Chain); + + procedure Add_Active_Chain (Sig : Ghdl_Signal_Ptr) + is + begin + if Sig.Link = null then + Sig.Link := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Sig; + end if; + end Add_Active_Chain; + + Clear_List : Ghdl_Signal_Ptr := null; + + -- Mark SIG as active and put it on Clear_List (if not already). + procedure Mark_Active (Sig : Ghdl_Signal_Ptr); + pragma Inline (Mark_Active); + + procedure Mark_Active (Sig : Ghdl_Signal_Ptr) + is + begin + if not Sig.Active then + Sig.Active := True; + Sig.Last_Active := Current_Time; + Sig.Alink := Clear_List; + Clear_List := Sig; + end if; + end Mark_Active; + + procedure Set_Guard_Activity (Sig : Ghdl_Signal_Ptr) is + begin + for I in 1 .. Sig.Nbr_Ports loop + if Sig.Ports (I - 1).Active then + Mark_Active (Sig); + return; + end if; + end loop; + end Set_Guard_Activity; + + procedure Set_Stable_Quiet_Activity + (Mode : Propagation_Kind_Type; Sig : Ghdl_Signal_Ptr) is + begin + case Mode is + when Imp_Stable => + for I in 0 .. Sig.Nbr_Ports - 1 loop + if Sig.Ports (I).Event then + Mark_Active (Sig); + return; + end if; + end loop; + when Imp_Quiet + | Imp_Transaction => + for I in 0 .. Sig.Nbr_Ports - 1 loop + if Sig.Ports (I).Active then + Mark_Active (Sig); + return; + end if; + end loop; + when others => + Internal_Error ("set_stable_quiet_activity"); + end case; + end Set_Stable_Quiet_Activity; + + function Get_Resolved_Activity (Sig : Ghdl_Signal_Ptr) return Boolean + is + Trans : Transaction_Acc; + Res : Boolean := False; + begin + for J in 1 .. Sig.S.Nbr_Drivers loop + Trans := Sig.S.Drivers (J - 1).First_Trans.Next; + if Trans /= null then + if Trans.Kind = Trans_Direct then + Direct_Assign (Sig.S.Drivers (J - 1).First_Trans.Val, + Trans.Val_Ptr, Sig.Mode); + -- In fact we knew the signal was active! + Res := True; + elsif Trans.Time = Current_Time then + Free (Sig.S.Drivers (J - 1).First_Trans); + Sig.S.Drivers (J - 1).First_Trans := Trans; + Res := True; + end if; + end if; + end loop; + if Res then + return True; + end if; + for J in 1 .. Sig.Nbr_Ports loop + if Sig.Ports (J - 1).Active then + return True; + end if; + end loop; + return False; + end Get_Resolved_Activity; + + procedure Set_Conversion_Activity (Conv : Sig_Conversion_Acc) + is + Active : Boolean := False; + begin + for I in Conv.Src.First .. Conv.Src.Last loop + Active := Active or Sig_Table.Table (I).Active; + end loop; + if Active then + Call_Conversion_Function (Conv); + end if; + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Active := Active; + end loop; + end Set_Conversion_Activity; + + procedure Delayed_Implicit_Process (Sig : Ghdl_Signal_Ptr) + is + Pfx : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + Last : Transaction_Acc; + Prev : Transaction_Acc; + begin + Pfx := Sig.Ports (0); + if Pfx.Event then + -- LRM 14.1 + -- P: process (S) + -- begin + -- R <= transport S after T; + -- end process; + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => Current_Time + Sig.S.Time, + Next => null, + Val => Pfx.Value); + -- Find the last transaction. + Last := Sig.S.Attr_Trans; + Prev := Last; + while Last.Next /= null loop + Prev := Last; + Last := Last.Next; + end loop; + -- Maybe, remove it. + if Last.Time > Trans.Time then + Internal_Error ("delayed time"); + elsif Last.Time = Trans.Time then + if Prev /= Last then + Free (Last); + else + -- No transaction. + if Last.Time /= 0 then + -- This can happen only at time = 0. + Internal_Error ("delayed"); + end if; + end if; + else + Prev := Last; + end if; + -- Append the transaction. + Prev.Next := Trans; + if Sig.S.Time = 0 then + Add_Active_Chain (Sig); + end if; + end if; + end Delayed_Implicit_Process; + + -- Set the effective value of signal SIG to VAL. + -- If the value is different from the previous one, resume processes. + procedure Set_Effective_Value (Sig : Ghdl_Signal_Ptr; Val : Value_Union) + is + El : Action_List_Acc; + begin + if not Value_Equal (Sig.Value, Val, Sig.Mode) then + Sig.Last_Value := Sig.Value; + Sig.Value := Val; + Sig.Event := True; + Sig.Last_Event := Current_Time; + Sig.Flags.Cyc_Event := True; + + El := Sig.Event_List; + while El /= null loop + Resume_Process (El.Proc); + El := El.Next; + end loop; + end if; + end Set_Effective_Value; + + procedure Run_Propagation (Start : Signal_Net_Type) + is + I : Signal_Net_Type; + Sig : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + First_Trans : Transaction_Acc; + begin + I := Start; + loop + -- First: the driving value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Eff_One_Driver => + Sig := Propagation.Table (I).Sig; + First_Trans := Sig.S.Drivers (0).First_Trans; + Trans := First_Trans.Next; + if Trans /= null then + if Trans.Kind = Trans_Direct then + -- Note: already or will be marked as active in + -- update_signals. + Mark_Active (Sig); + Direct_Assign (First_Trans.Val, + Trans.Val_Ptr, Sig.Mode); + Sig.Driving_Value := First_Trans.Val; + elsif Trans.Time = Current_Time then + Mark_Active (Sig); + Free (First_Trans); + Sig.S.Drivers (0).First_Trans := Trans; + case Trans.Kind is + when Trans_Value => + Sig.Driving_Value := Trans.Val; + when Trans_Direct => + Internal_Error ("run_propagation: trans_direct"); + when Trans_Null => + Error ("null transaction"); + when Trans_Error => + Error_Trans_Error (Trans); + end case; + end if; + end if; + when Drv_One_Resolved + | Eff_One_Resolved => + Sig := Propagation.Table (I).Sig; + if Get_Resolved_Activity (Sig) then + Mark_Active (Sig); + Compute_Resolved_Signal (Propagation.Table (I).Sig.S.Resolv); + end if; + when Drv_One_Port + | Eff_One_Port => + Sig := Propagation.Table (I).Sig; + if Sig.Ports (0).Active then + Mark_Active (Sig); + Sig.Driving_Value := Sig.Ports (0).Driving_Value; + end if; + when Eff_Actual => + Sig := Propagation.Table (I).Sig; + -- Note: the signal may have drivers (inout ports). + if Sig.S.Effective.Active and not Sig.Active then + Mark_Active (Sig); + end if; + when Drv_Multiple + | Eff_Multiple => + declare + Active : Boolean := False; + Resolv : Resolved_Signal_Acc; + begin + Resolv := Propagation.Table (I).Resolv; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop + Sig := Sig_Table.Table (I); + Active := Active or Get_Resolved_Activity (Sig); + end loop; + if Active then + -- Mark the first signal as active (since only this one + -- will be checked to set effective value). + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + Mark_Active (Sig_Table.Table (I)); + end loop; + Compute_Resolved_Signal (Resolv); + end if; + end; + when Imp_Guard + | Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Forward_Build => + null; + when Imp_Forward => + Sig := Propagation.Table (I).Sig; + if Sig.Link = null then + Sig.Link := Ghdl_Implicit_Signal_Active_Chain; + Ghdl_Implicit_Signal_Active_Chain := Sig; + end if; + when Imp_Delayed => + Sig := Propagation.Table (I).Sig; + Trans := Sig.S.Attr_Trans.Next; + if Trans /= null and then Trans.Time = Current_Time then + Mark_Active (Sig); + Free (Sig.S.Attr_Trans); + Sig.S.Attr_Trans := Trans; + Sig.Driving_Value := Trans.Val; + end if; + when In_Conversion => + null; + when Out_Conversion => + Set_Conversion_Activity (Propagation.Table (I).Conv); + when Prop_End => + return; + when Drv_Error => + Internal_Error ("update signals"); + end case; + + -- Second: the effective value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Drv_One_Port + | Drv_One_Resolved + | Drv_Multiple => + null; + when Eff_One_Driver + | Eff_One_Port + | Eff_One_Resolved => + Sig := Propagation.Table (I).Sig; + if Sig.Active then + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + when Eff_Multiple => + declare + Resolv : Resolved_Signal_Acc; + begin + Resolv := Propagation.Table (I).Resolv; + if Sig_Table.Table (Resolv.Sig_Range.First).Active then + -- If one signal is active, all are active. + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + Sig := Sig_Table.Table (I); + Set_Effective_Value (Sig, Sig.Driving_Value); + end loop; + end if; + end; + when Eff_Actual => + Sig := Propagation.Table (I).Sig; + if Sig.Active then + Set_Effective_Value (Sig, Sig.S.Effective.Value); + end if; + when Imp_Forward + | Imp_Forward_Build => + null; + when Imp_Guard => + -- Guard signal is active iff one of its dependence is active. + Sig := Propagation.Table (I).Sig; + Set_Guard_Activity (Sig); + if Sig.Active then + Sig.Driving_Value.B1 := + Sig.S.Guard_Func.all (Sig.S.Guard_Instance); + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + when Imp_Stable + | Imp_Quiet => + Sig := Propagation.Table (I).Sig; + Set_Stable_Quiet_Activity (Propagation.Table (I).Kind, Sig); + if Sig.Active then + Sig.Driving_Value := + Value_Union'(Mode => Mode_B1, B1 => False); + -- Set driver. + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => Current_Time + Sig.S.Time, + Next => null, + Val => Value_Union'(Mode => Mode_B1, B1 => True)); + if Sig.S.Attr_Trans.Next /= null then + Free (Sig.S.Attr_Trans.Next); + end if; + Sig.S.Attr_Trans.Next := Trans; + Set_Effective_Value (Sig, Sig.Driving_Value); + if Sig.S.Time = 0 then + Add_Active_Chain (Sig); + end if; + else + Trans := Sig.S.Attr_Trans.Next; + if Trans /= null and then Trans.Time = Current_Time then + Mark_Active (Sig); + Free (Sig.S.Attr_Trans); + Sig.S.Attr_Trans := Trans; + Sig.Driving_Value := Trans.Val; + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + end if; + when Imp_Transaction => + -- LRM 12.6.3 Updating Implicit Signals + -- Finally, for any implicit signal S'Transaction, the current + -- value of the signal is modified if and only if S is active. + -- If signal S is active, then S'Transaction is updated by + -- assigning the value of the expression (not S'Transaction) + -- to the variable representing the current value of + -- S'Transaction. + Sig := Propagation.Table (I).Sig; + for I in 0 .. Sig.Nbr_Ports - 1 loop + if Sig.Ports (I).Active then + Mark_Active (Sig); + Set_Effective_Value + (Sig, Value_Union'(Mode => Mode_B1, + B1 => not Sig.Value.B1)); + exit; + end if; + end loop; + when Imp_Delayed => + Sig := Propagation.Table (I).Sig; + if Sig.Active then + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + Delayed_Implicit_Process (Sig); + when In_Conversion => + Set_Conversion_Activity (Propagation.Table (I).Conv); + when Out_Conversion => + null; + when Prop_End => + null; + when Drv_Error => + Internal_Error ("run_propagation(2)"); + end case; + I := I + 1; + end loop; + end Run_Propagation; + + procedure Reset_Active_Flag + is + Sig : Ghdl_Signal_Ptr; + begin + -- 1) Reset active flag. + Sig := Clear_List; + Clear_List := null; + while Sig /= null loop + if Options.Flag_Stats then + if Sig.Active then + Nbr_Active := Nbr_Active + 1; + end if; + if Sig.Event then + Nbr_Events := Nbr_Events + 1; + end if; + end if; + Sig.Active := False; + Sig.Event := False; + + Sig := Sig.Alink; + end loop; + +-- for I in Sig_Table.First .. Sig_Table.Last loop +-- Sig := Sig_Table.Table (I); +-- if Sig.Active or Sig.Event then +-- Internal_Error ("reset_active_flag"); +-- end if; +-- end loop; + end Reset_Active_Flag; + + procedure Update_Signals + is + Sig : Ghdl_Signal_Ptr; + Next_Sig : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + begin + -- LRM93 12.6.2 + -- 1) Reset active flag. + Reset_Active_Flag; + + -- For each active signals + Sig := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Signal_End; + while Sig.S.Mode_Sig /= Mode_End loop + Next_Sig := Sig.Link; + Sig.Link := null; + + case Sig.Net is + when Net_One_Driver => + -- This signal is active. + Mark_Active (Sig); + + Trans := Sig.S.Drivers (0).First_Trans.Next; + Free (Sig.S.Drivers (0).First_Trans); + Sig.S.Drivers (0).First_Trans := Trans; + case Trans.Kind is + when Trans_Value => + Sig.Driving_Value := Trans.Val; + when Trans_Direct => + Internal_Error ("update_signals: trans_direct"); + when Trans_Null => + Error ("null transaction"); + when Trans_Error => + Error_Trans_Error (Trans); + end case; + Set_Effective_Value (Sig, Sig.Driving_Value); + + when Net_One_Direct => + Mark_Active (Sig); + Sig.Is_Direct_Active := False; + + Trans := Sig.S.Drivers (0).Last_Trans; + Direct_Assign (Sig.Driving_Value, Trans.Val_Ptr, Sig.Mode); + Sig.S.Drivers (0).First_Trans.Val := Sig.Driving_Value; + Set_Effective_Value (Sig, Sig.Driving_Value); + + when Net_One_Resolved => + -- This signal is active. + Mark_Active (Sig); + Sig.Is_Direct_Active := False; + + for J in 1 .. Sig.S.Nbr_Drivers loop + Trans := Sig.S.Drivers (J - 1).First_Trans.Next; + if Trans /= null then + if Trans.Kind = Trans_Direct then + Direct_Assign (Sig.S.Drivers (J - 1).First_Trans.Val, + Trans.Val_Ptr, Sig.Mode); + elsif Trans.Time = Current_Time then + Free (Sig.S.Drivers (J - 1).First_Trans); + Sig.S.Drivers (J - 1).First_Trans := Trans; + end if; + end if; + end loop; + Compute_Resolved_Signal (Sig.S.Resolv); + Set_Effective_Value (Sig, Sig.Driving_Value); + + when No_Signal_Net => + Internal_Error ("update_signals: no_signal_net"); + + when others => + Sig.Is_Direct_Active := False; + if not Propagation.Table (Sig.Net).Updated then + Propagation.Table (Sig.Net).Updated := True; + Run_Propagation (Sig.Net + 1); + + -- Put it on the list, so that updated flag will be cleared. + Add_Active_Chain (Sig); + end if; + end case; + + Sig := Next_Sig; + end loop; + + -- Implicit signals (forwarded). + loop + Sig := Ghdl_Implicit_Signal_Active_Chain; + exit when Sig.Link = null; + Ghdl_Implicit_Signal_Active_Chain := Sig.Link; + Sig.Link := null; + + if not Propagation.Table (Sig.Net).Updated then + Propagation.Table (Sig.Net).Updated := True; + Run_Propagation (Sig.Net + 1); + + -- Put it on the list, so that updated flag will be cleared. + Add_Active_Chain (Sig); + end if; + end loop; + + -- Un-mark updated. + Sig := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Signal_End; + while Sig.Link /= null loop + Propagation.Table (Sig.Net).Updated := False; + Next_Sig := Sig.Link; + Sig.Link := null; + + -- Maybe put SIG in the active list, if it will be active during + -- the next cycle. + -- This can happen only for 'quiet, 'stable or 'delayed. + case Sig.S.Mode_Sig is + when Mode_Stable + | Mode_Quiet + | Mode_Delayed => + declare + Trans : Transaction_Acc; + begin + Trans := Sig.S.Attr_Trans.Next; + if Trans /= null and then Trans.Time = Current_Time then + Sig.Link := Ghdl_Implicit_Signal_Active_Chain; + Ghdl_Implicit_Signal_Active_Chain := Sig; + end if; + end; + when others => + null; + end case; + + Sig := Next_Sig; + end loop; + end Update_Signals; + + procedure Run_Propagation_Init (Start : Signal_Net_Type) + is + I : Signal_Net_Type; + Sig : Ghdl_Signal_Ptr; + begin + I := Start; + loop + -- First: the driving value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Eff_One_Driver => + -- Nothing to do: drivers were already created. + null; + when Drv_One_Resolved + | Eff_One_Resolved => + -- Execute the resolution function. + Sig := Propagation.Table (I).Sig; + if Sig.Nbr_Ports > 0 then + Compute_Resolved_Signal (Sig.S.Resolv); + end if; + when Drv_One_Port + | Eff_One_Port => + -- Copy value. + Sig := Propagation.Table (I).Sig; + Sig.Driving_Value := Sig.Ports (0).Driving_Value; + when Eff_Actual => + null; + when Drv_Multiple + | Eff_Multiple => + Compute_Resolved_Signal (Propagation.Table (I).Resolv); + when Imp_Guard + | Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Forward + | Imp_Forward_Build => + null; + when Imp_Delayed => + -- LRM 14.1 + -- Assuming that the initial value of R is the same as the + -- initial value of S, [...] + Sig := Propagation.Table (I).Sig; + Sig.Driving_Value := Sig.Ports (0).Driving_Value; + when In_Conversion => + null; + when Out_Conversion => + Call_Conversion_Function (Propagation.Table (I).Conv); + when Prop_End => + return; + when Drv_Error => + Internal_Error ("init_signals"); + end case; + + -- Second: the effective value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Drv_One_Port + | Drv_One_Resolved + | Drv_Multiple => + null; + when Eff_One_Driver + | Eff_One_Port + | Eff_One_Resolved + | Imp_Delayed => + Sig := Propagation.Table (I).Sig; + Sig.Value := Sig.Driving_Value; + when Eff_Multiple => + declare + Resolv : Resolved_Signal_Acc; + begin + Resolv := Propagation.Table (I).Resolv; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop + Sig := Sig_Table.Table (I); + Sig.Value := Sig.Driving_Value; + end loop; + end; + when Eff_Actual => + Sig := Propagation.Table (I).Sig; + Sig.Value := Sig.S.Effective.Value; + when Imp_Guard => + -- Guard signal is active iff one of its dependence is active. + Sig := Propagation.Table (I).Sig; + Sig.Driving_Value.B1 := + Sig.S.Guard_Func.all (Sig.S.Guard_Instance); + Sig.Value := Sig.Driving_Value; + when Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Forward + | Imp_Forward_Build => + -- Already initialized during creation. + null; + when In_Conversion => + Call_Conversion_Function (Propagation.Table (I).Conv); + when Out_Conversion => + null; + when Prop_End => + null; + when Drv_Error => + Internal_Error ("init_signals(2)"); + end case; + + I := I + 1; + end loop; + end Run_Propagation_Init; + + procedure Init_Signals + is + Sig : Ghdl_Signal_Ptr; + begin + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + + case Sig.Net is + when Net_One_Driver + | Net_One_Direct => + -- Nothing to do: drivers were already created. + null; + + when Net_One_Resolved => + Sig.Has_Active := True; + if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 0 then + Compute_Resolved_Signal (Sig.S.Resolv); + Sig.Value := Sig.Driving_Value; + end if; + + when No_Signal_Net => + null; + + when others => + if Propagation.Table (Sig.Net).Updated then + Propagation.Table (Sig.Net).Updated := False; + Run_Propagation_Init (Sig.Net + 1); + end if; + end case; + end loop; + + end Init_Signals; + + procedure Init is + begin + Signal_End := new Ghdl_Signal'(Value => (Mode => Mode_B1, + B1 => False), + Driving_Value => (Mode => Mode_B1, + B1 => False), + Last_Value => (Mode => Mode_B1, + B1 => False), + Last_Event => 0, + Last_Active => 0, + Event => False, + Active => False, + Has_Active => False, + Is_Direct_Active => False, + Sig_Kind => Kind_Signal_No, + Mode => Mode_B1, + + Flags => (Propag => Propag_None, + Is_Dumped => False, + Cyc_Event => False, + Seen => False), + + Net => No_Signal_Net, + Link => null, + Alink => null, + Flink => null, + + Event_List => null, + Rti => null, + + Nbr_Ports => 0, + Ports => null, + + S => (Mode_Sig => Mode_End)); + + Ghdl_Signal_Active_Chain := Signal_End; + Ghdl_Implicit_Signal_Active_Chain := Signal_End; + Future_List := Signal_End; + + Boolean_Signal_Rti.Obj_Type := Std_Standard_Boolean_RTI_Ptr; + Bit_Signal_Rti.Obj_Type := Std_Standard_Bit_RTI_Ptr; + end Init; + +end Grt.Signals; diff --git a/src/translate/grt/grt-signals.ads b/src/translate/grt/grt-signals.ads new file mode 100644 index 0000000..d792f16 --- /dev/null +++ b/src/translate/grt/grt-signals.ads @@ -0,0 +1,919 @@ +-- GHDL Run Time (GRT) - signals management. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; +with Ada.Unchecked_Conversion; +with Grt.Table; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; +limited with Grt.Processes; +pragma Elaborate_All (Grt.Table); + +package Grt.Signals is + pragma Suppress (All_Checks); + + -- Kind of transaction. + type Transaction_Kind is + ( + -- Normal transaction, with a value. + Trans_Value, + -- Normal transaction, with a pointer to a value (direct assignment). + Trans_Direct, + -- Null transaction. + Trans_Null, + -- Like a normal transaction, but without a value due to check error. + Trans_Error + ); + + type Transaction; + type Transaction_Acc is access Transaction; + type Transaction (Kind : Transaction_Kind) is record + -- Line for error. Put here to compact the record. + Line : Ghdl_I32; + + Next : Transaction_Acc; + Time : Std_Time; + case Kind is + when Trans_Value => + Val : Value_Union; + when Trans_Direct => + Val_Ptr : Ghdl_Value_Ptr; + when Trans_Null => + null; + when Trans_Error => + -- Filename for error. + File : Ghdl_C_String; + end case; + end record; + + type Process_Acc is access Grt.Processes.Process_Type; + + -- A driver is bound to a process (PROC) and contains a list of + -- transactions. + type Driver_Type is record + First_Trans : Transaction_Acc; + Last_Trans : Transaction_Acc; + Proc : Process_Acc; + end record; + + type Driver_Acc is access all Driver_Type; + type Driver_Fat_Array is array (Ghdl_Index_Type) of aliased Driver_Type; + type Driver_Arr_Ptr is access Driver_Fat_Array; + + -- Function access type used to evaluate the guard expression. + type Guard_Func_Acc is access function (This : System.Address) + return Ghdl_B1; + pragma Convention (C, Guard_Func_Acc); + + -- Simply linked list of processes to be resumed in case of events. + + type Ghdl_Signal; + type Ghdl_Signal_Ptr is access Ghdl_Signal; + + function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Ghdl_Signal_Ptr); + + type Signal_Fat_Array is array (Ghdl_Index_Type) of Ghdl_Signal_Ptr; + type Signal_Arr_Ptr is access Signal_Fat_Array; + + function To_Signal_Arr_Ptr is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Signal_Arr_Ptr); + + -- List of processes to wake-up in case of event on the signal. + type Action_List; + type Action_List_Acc is access Action_List; + + type Action_List (Dynamic : Boolean) is record + -- Next action for the current signal. + Next : Action_List_Acc; + + -- Process to wake-up. + Proc : Process_Acc; + + case Dynamic is + when True => + -- For a non-sensitized process. + -- Previous action (to speed-up remove from the chain). + Prev : Action_List_Acc; + + Sig : Ghdl_Signal_Ptr; + + -- Chain of signals for the process. + Chain : Action_List_Acc; + when False => + null; + end case; + end record; + + -- Resolution function. + -- There is a wrapper around resolution functions to simplify the call + -- from GRT. + -- INSTANCE is the opaque parameter given when the resolver is + -- registers (RESOLV_INST). + -- VAL is the signal (which may be composite). + -- BOOL_VEC is an array of NBR_DRV booleans (bytes) and indicates + -- non-null drivers. There are VEC_LEN non-null drivers. So the number + -- of values is VEC_LEN + NBR_PORTS. This number of values is the length + -- of the array for the resolution function. + type Resolver_Acc is access procedure + (Instance : System.Address; + Val : System.Address; + Bool_Vec : System.Address; + Vec_Len : Ghdl_Index_Type; + Nbr_Drv : Ghdl_Index_Type; + Nbr_Ports : Ghdl_Index_Type); + + -- On some platforms, GNAT use a descriptor (instead of a trampoline) for + -- nested subprograms. This descriptor contains the address of the + -- subprogram and the address of the chain. An unaligned pointer to this + -- descriptor (address + 1) is then used for 'Access, and every indirect + -- call check for unaligned address. + -- + -- Disable this feature (as a resolver is never a nested subprogram), so + -- code generated by ghdl is compatible with ghdl runtimes built with + -- gnat. + pragma Convention (C, Resolver_Acc); + + -- How to compute resolved signal. + type Resolved_Signal_Type is record + Resolv_Proc : Resolver_Acc; + Resolv_Inst : System.Address; + Resolv_Ptr : System.Address; + Sig_Range : Sig_Table_Range; + Disconnect_Time : Std_Time; + end record; + + type Resolved_Signal_Acc is access Resolved_Signal_Type; + + type Conversion_Func_Acc is access procedure (Instance : System.Address); + pragma Convention (C, Conversion_Func_Acc); + + function To_Conversion_Func_Acc is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Conversion_Func_Acc); + + -- Signal conversion data. + type Sig_Conversion_Type is record + -- Function which performs the conversion. + Func : System.Address; + Instance : System.Address; + + Src : Sig_Table_Range; + Dest : Sig_Table_Range; + end record; + type Sig_Conversion_Acc is access Sig_Conversion_Type; + + type Forward_Build_Type is record + Src : Ghdl_Signal_Ptr; + Targ : Ghdl_Signal_Ptr; + end record; + type Forward_Build_Acc is access Forward_Build_Type; + + -- Used to order the signals for the propagation of signals values. + type Propag_Order_Flag is + ( + -- The signal was not yet ordered. + Propag_None, + -- The signal is being ordered for driving value. + -- This stage is used to catch loop (which can not occur). + Propag_Being_Driving, + -- The signal has been ordered for driving value. + Propag_Driving, + -- The signal is being ordered for effective value. + Propag_Being_Effective, + -- The signal has completly been ordered. + Propag_Done); + + -- Each signal belongs to a signal_net. + -- Signals on the same net must be updated in order. + -- Signals on different nets have no direct relation-ship, and thus may + -- be updated without order. + -- Net NO_SIGNAL_NET is special: it groups all lonely signals. + type Signal_Net_Type is new Integer; + No_Signal_Net : constant Signal_Net_Type := 0; + Net_One_Driver : constant Signal_Net_Type := -1; + Net_One_Direct : constant Signal_Net_Type := -2; + Net_One_Resolved : constant Signal_Net_Type := -3; + + -- Flush the list of active signals. + procedure Flush_Active_List; + + type Ghdl_Signal_Data (Mode_Sig : Mode_Signal_Type := Mode_Signal) + is record + case Mode_Sig is + when Mode_Signal_User => + Nbr_Drivers : Ghdl_Index_Type; + Drivers : Driver_Arr_Ptr; + + -- Signal which defines the effective value of this signal, + -- if any. + Effective : Ghdl_Signal_Ptr; + + -- Null if not resolved. + Resolv : Resolved_Signal_Acc; + + when Mode_Conv_In + | Mode_Conv_Out => + -- Conversion paramaters for conv_in, conv_out. + Conv : Sig_Conversion_Acc; + + when Mode_Stable + | Mode_Quiet + | Mode_Delayed => + -- Time parameter for 'stable, 'quiet or 'delayed + Time : Std_Time; + Attr_Trans : Transaction_Acc; + + when Mode_Guard => + -- Guard function and instance used to compute the + -- guard expression. + Guard_Func : Guard_Func_Acc; + Guard_Instance : System.Address; + + when Mode_Transaction + | Mode_End => + null; + end case; + end record; + pragma Suppress (Discriminant_Check, On => Ghdl_Signal_Data); + + type Ghdl_Signal_Flags is record + -- Status of the ordering. + Propag : Propag_Order_Flag; + + -- If set, the signal is dumped in a GHW file. + Is_Dumped : Boolean; + + -- 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); + + type Ghdl_Signal is record + -- Fields known by the compilers. + Value : Value_Union; + Driving_Value : Value_Union; + Last_Value : Value_Union; + Last_Event : Std_Time; + Last_Active : Std_Time; + + Event : Boolean; + Active : Boolean; + -- If set, the activity of the signal is required by the user. + Has_Active : Boolean; + + -- Internal fields. + -- NOTE: keep above fields (components) in sync with translation. + + -- If set, the signal has an active direct driver. + Is_Direct_Active : Boolean; + + -- Kind of the signal (none, bus or register). + Sig_Kind : Kind_Signal_Type; + + -- Values mode of this signal. + Mode : Mode_Type; + + -- Misc flags. + Flags : Ghdl_Signal_Flags; + + -- Net of the signal. + Net : Signal_Net_Type; + + -- Chain of signals that will be active in the next delta-cycle. + -- (Also used to build nets). + Link : Ghdl_Signal_Ptr; + + -- Chain of signals whose active flag was set. Used to clear the active + -- flag at the end of the delta cycle. + Alink : Ghdl_Signal_Ptr; + + -- Chain of signals that have a projected waveform in the real future. + Flink : Ghdl_Signal_Ptr; + + -- List of processes to resume when there is an event on + -- this signal. + Event_List : Action_List_Acc; + + -- Path of the signal (with its name) in the design hierarchy. + -- Used to get the type of the signal. + Rti : Ghdl_Rtin_Object_Acc; + + -- For user signals: the sources of a signals are drivers + -- and connected ports. + -- For implicit signals: PORTS is used as dependence list. + Nbr_Ports : Ghdl_Index_Type; + Ports : Signal_Arr_Ptr; + + -- Mode of the signal (in, out ...) + --Mode_Signal : Mode_Signal_Type; + S : Ghdl_Signal_Data; + end record; + + -- Each simple signal declared can be accessed by SIG_TABLE. + package Sig_Table is new Grt.Table + (Table_Component_Type => Ghdl_Signal_Ptr, + Table_Index_Type => Sig_Table_Index, + Table_Low_Bound => 0, + Table_Initial => 128); + + -- Return the next time at which a driver becomes active. + function Find_Next_Time return Std_Time; + + -- Elementary propagation computation. + -- See LRM 12.6.2 and 12.6.3 + type Propagation_Kind_Type is + ( + -- How to compute driving value: + -- Default value. + Drv_Error, + + -- One source, a driver and not resolved: + -- the driving value is the driver. + Drv_One_Driver, + + -- Same as previous, and the effective value is the driving value. + Eff_One_Driver, + + -- One source, a port and not resolved: + -- the driving value is the driving value of the port. + -- Dependence. + Drv_One_Port, + + -- Same as previous, and the effective value is the driving value. + Eff_One_Port, + + -- Several sources or resolved: + -- signal is not composite. + Drv_One_Resolved, + Eff_One_Resolved, + + -- Use the resolution function, signal is composite. + Drv_Multiple, + + -- Same as previous, but the effective value is the previous value. + Eff_Multiple, + + -- The effective value is the actual associated. + Eff_Actual, + + -- Sig must be updated but does not belong to the same net. + Imp_Forward, + Imp_Forward_Build, + + -- Implicit guard signal. + -- Its value must be evaluated after the effective value of its + -- dependences. + Imp_Guard, + + -- Implicit stable. + -- Its value must be evaluated after the effective value of its + -- dependences. + Imp_Stable, + + -- Implicit quiet. + -- Its value must be evaluated after the driving value of its + -- dependences. + Imp_Quiet, + + -- Implicit transaction. + -- Its value must be evaluated after the driving value of its + -- dependences. + Imp_Transaction, + + -- Implicit delayed + -- Its value must be evaluated after the driving value of its + -- dependences. + Imp_Delayed, + + -- in_conversion. + -- Pseudo-signal which is set by conversion function. + In_Conversion, + Out_Conversion, + + -- End of propagation. + Prop_End + ); + + type Propagation_Type (Kind : Propagation_Kind_Type := Drv_Error) is record + case Kind is + when Drv_Error => + null; + when Drv_One_Driver + | Eff_One_Driver + | Drv_One_Port + | Eff_One_Port + | Imp_Forward + | Imp_Guard + | Imp_Quiet + | Imp_Transaction + | Imp_Stable + | Imp_Delayed + | Eff_Actual + | Eff_One_Resolved + | Drv_One_Resolved => + Sig : Ghdl_Signal_Ptr; + when Drv_Multiple + | Eff_Multiple => + Resolv : Resolved_Signal_Acc; + when In_Conversion + | Out_Conversion => + Conv : Sig_Conversion_Acc; + when Imp_Forward_Build => + Forward : Forward_Build_Acc; + when Prop_End => + Updated : Boolean; + end case; + end record; + + package Propagation is new Grt.Table + (Table_Component_Type => Propagation_Type, + Table_Index_Type => Signal_Net_Type, + Table_Low_Bound => 1, + Table_Initial => 128); + + -- Get the signal index of PTR. + function Signal_Ptr_To_Index (Ptr : Ghdl_Signal_Ptr) return Sig_Table_Index; + + -- Compute propagation order of signals. + procedure Order_All_Signals; + + -- Initialize the package (mainly the lists). + procedure Init; + + -- Initialize all signals. + procedure Init_Signals; + + -- Update signals. + procedure Update_Signals; + + -- Set the effective value of signal SIG to VAL. + -- If the value is different from the previous one, resume processes. + procedure Set_Effective_Value (Sig : Ghdl_Signal_Ptr; Val : Value_Union); + + -- Add PROC in the list of processes to be resumed in case of event on + -- SIG. + procedure Resume_Process_If_Event + (Sig : Ghdl_Signal_Ptr; Proc : Process_Acc); + + -- Creating a signal: + -- 1a) call Ghdl_Signal_Name_Rti (CTXT and ADDR are unused) to register + -- the RTI for the whole signal (in particular the mode and the + -- has_active flag) + -- or + -- 1b) call Ghdl_Signal_Set_Mode to register the mode and the has_active + -- flag. In that case, the signal has no name. + -- + -- 2) call Ghdl_Create_Signal_XXX for each non-composite element + + procedure Ghdl_Signal_Name_Rti (Sig : Ghdl_Rti_Access; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + + procedure Ghdl_Signal_Set_Mode (Mode : Mode_Signal_Type; + Kind : Kind_Signal_Type; + Has_Active : Boolean); + + -- FIXME: document. + -- Merge RTI with SIG: adjust the has_active flag of SIG according to RTI. + procedure Ghdl_Signal_Merge_Rti (Sig : Ghdl_Signal_Ptr; + Rti : Ghdl_Rti_Access); + + -- Assigning a waveform to a signal: + -- + -- For simple waveform (sig <= val), the short form can be used: + -- Ghdl_Signal_Simple_Assign_XX (Sig, Val); + -- For all other forms + -- SIG <= reject R inertial V1 after T1, V2 after T2, ...: + -- Ghdl_Signal_Start_Assign_XX (SIG, R, V1, T1); + -- Ghdl_Signal_Next_Assign_XX (SIG, V2, T2); + -- ... + -- If the delay mechanism is transport, they R = 0, + -- if there is no rejection time, the mechanism is internal and R = T1. + + -- Performs some internal checks on signals (transaction order). + -- Internal_error is called in case of error. + procedure Ghdl_Signal_Internal_Checks; + + procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr; + File : Ghdl_C_String; + Line : Ghdl_I32); + procedure Ghdl_Signal_Start_Assign_Error (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32); + procedure Ghdl_Signal_Next_Assign_Error (Sign : Ghdl_Signal_Ptr; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32); + + procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr); + + procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr; + Time : Std_Time); + + procedure Ghdl_Signal_Disconnect (Sign : Ghdl_Signal_Ptr); + + procedure Ghdl_Signal_Start_Assign_Null (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time); + + function Ghdl_Signal_Driving (Sig : Ghdl_Signal_Ptr) return Ghdl_B1; + + function Ghdl_Create_Signal_B1 (Init_Val : Ghdl_B1; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_B1 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_B1); + procedure Ghdl_Signal_Associate_B1 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_B1); + procedure Ghdl_Signal_Simple_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1); + procedure Ghdl_Signal_Start_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_B1; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1; + After : Std_Time); + function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr) + return Ghdl_B1; + + function Ghdl_Create_Signal_E8 (Init_Val : Ghdl_E8; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_E8 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E8); + procedure Ghdl_Signal_Associate_E8 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E8); + procedure Ghdl_Signal_Simple_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8); + procedure Ghdl_Signal_Start_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E8; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8; + After : Std_Time); + function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E8; + + function Ghdl_Create_Signal_E32 (Init_Val : Ghdl_E32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_E32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E32); + procedure Ghdl_Signal_Associate_E32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E32); + procedure Ghdl_Signal_Simple_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32); + procedure Ghdl_Signal_Start_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E32; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32; + After : Std_Time); + function Ghdl_Signal_Driving_Value_E32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E32; + + function Ghdl_Create_Signal_I32 (Init_Val : Ghdl_I32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_I32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I32); + procedure Ghdl_Signal_Associate_I32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I32); + procedure Ghdl_Signal_Simple_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32); + procedure Ghdl_Signal_Start_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I32; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32; + After : Std_Time); + function Ghdl_Signal_Driving_Value_I32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I32; + + function Ghdl_Create_Signal_I64 (Init_Val : Ghdl_I64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_I64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I64); + procedure Ghdl_Signal_Associate_I64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I64); + procedure Ghdl_Signal_Simple_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64); + procedure Ghdl_Signal_Start_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I64; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64; + After : Std_Time); + function Ghdl_Signal_Driving_Value_I64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I64; + + function Ghdl_Create_Signal_F64 (Init_Val : Ghdl_F64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_F64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_F64); + procedure Ghdl_Signal_Associate_F64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_F64); + procedure Ghdl_Signal_Simple_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64); + procedure Ghdl_Signal_Start_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_F64; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64; + After : Std_Time); + function Ghdl_Signal_Driving_Value_F64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_F64; + + -- Add a driver to SIGN for the current process. + procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr); + + -- Add a direct driver for the current process. This is an optimization + -- that could be used when a driver has no projected waveforms. + -- + -- Assignment using direct driver: + -- * the driver value is set + -- * put the signal on the ghdl_signal_active_chain, if the signal will + -- be active and if not already on the chain. + procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr; + Drv : Ghdl_Value_Ptr); + + -- Used for connexions: + -- SRC is a source for TARG. + procedure Ghdl_Signal_Add_Source (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr); + + -- The effective value of TARG is the effective value of SRC. + procedure Ghdl_Signal_Effective_Value (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr); + + -- Conversions. In order to do conversion from A to B, an intermediate + -- signal T must be created. The flow is A -> T -> B. + -- The link from A -> T is a conversion, added by one of the two + -- following procedures. The type of A and T is different. + -- The link from T -> B is a normal connection: either an effective + -- one (for in conversion) or a source (for out conversion). + + -- Add an in conversion (from SRC to DEST using function FUNC). + -- The effective value can be read and writen directly. + procedure Ghdl_Signal_In_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type); + + -- Add an out conversion. + -- The driving value can be read and writen directly. + procedure Ghdl_Signal_Out_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type); + + -- Mark the next (and not yet created) NBR_SIG signals as resolved. + procedure Ghdl_Signal_Create_Resolution (Proc : Resolver_Acc; + Instance : System.Address; + Sig : System.Address; + Nbr_Sig : Ghdl_Index_Type); + + -- Create a new 'stable (VAL) signal. The prefixes are set by + -- ghdl_signal_attribute_register_prefix. + function Ghdl_Create_Stable_Signal (Val : Std_Time) return Ghdl_Signal_Ptr; + -- Create a new 'quiet (VAL) signal. The prefixes are set by + -- ghdl_signal_attribute_register_prefix. + function Ghdl_Create_Quiet_Signal (Val : Std_Time) return Ghdl_Signal_Ptr; + -- Create a new 'transaction signal. The prefixes are set by + -- ghdl_signal_attribute_register_prefix. + function Ghdl_Create_Transaction_Signal return Ghdl_Signal_Ptr; + + -- Create a new SIG'delayed (VAL) signal. + function Ghdl_Create_Delayed_Signal (Sig : Ghdl_Signal_Ptr; Val : Std_Time) + return Ghdl_Signal_Ptr; + + -- Add SIG in the set of prefix for the last created signal. + procedure Ghdl_Signal_Attribute_Register_Prefix (Sig : Ghdl_Signal_Ptr); + + -- Create a new implicitly defined GUARD signal. + function Ghdl_Signal_Create_Guard (This : System.Address; + Proc : Guard_Func_Acc) + return Ghdl_Signal_Ptr; + + -- Add SIG to the list of referenced signals that appear in the guard + -- expression. + procedure Ghdl_Signal_Guard_Dependence (Sig : Ghdl_Signal_Ptr); + + -- Return number of ports/drivers. + function Ghdl_Signal_Get_Nbr_Ports (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type; + function Ghdl_Signal_Get_Nbr_Drivers (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type; + + -- Read a source (port or driver) from a signal. This is used by + -- resolution functions. + function Ghdl_Signal_Read_Port + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr; + function Ghdl_Signal_Read_Driver + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr; + + Ghdl_Signal_Active_Chain : aliased Ghdl_Signal_Ptr; + + -- Statistics. + Nbr_Active : Ghdl_I32; + Nbr_Events: Ghdl_I32; + function Get_Nbr_Future return Ghdl_I32; +private + pragma Export (C, Ghdl_Signal_Name_Rti, + "__ghdl_signal_name_rti"); + pragma Export (C, Ghdl_Signal_Merge_Rti, + "__ghdl_signal_merge_rti"); + + pragma Export (C, Ghdl_Signal_Simple_Assign_Error, + "__ghdl_signal_simple_assign_error"); + pragma Export (C, Ghdl_Signal_Start_Assign_Error, + "__ghdl_signal_start_assign_error"); + pragma Export (C, Ghdl_Signal_Next_Assign_Error, + "__ghdl_signal_next_assign_error"); + + pragma Export (C, Ghdl_Signal_Start_Assign_Null, + "__ghdl_signal_start_assign_null"); + + pragma Export (C, Ghdl_Signal_Direct_Assign, + "__ghdl_signal_direct_assign"); + + pragma Export (C, Ghdl_Signal_Set_Disconnect, + "__ghdl_signal_set_disconnect"); + pragma Export (C, Ghdl_Signal_Disconnect, + "__ghdl_signal_disconnect"); + + pragma Export (Ada, Ghdl_Signal_Driving, + "__ghdl_signal_driving"); + + pragma Export (Ada, Ghdl_Create_Signal_B1, + "__ghdl_create_signal_b1"); + pragma Export (Ada, Ghdl_Signal_Init_B1, + "__ghdl_signal_init_b1"); + pragma Export (Ada, Ghdl_Signal_Associate_B1, + "__ghdl_signal_associate_b1"); + pragma Export (Ada, Ghdl_Signal_Simple_Assign_B1, + "__ghdl_signal_simple_assign_b1"); + pragma Export (Ada, Ghdl_Signal_Start_Assign_B1, + "__ghdl_signal_start_assign_b1"); + pragma Export (Ada, Ghdl_Signal_Next_Assign_B1, + "__ghdl_signal_next_assign_b1"); + pragma Export (Ada, Ghdl_Signal_Driving_Value_B1, + "__ghdl_signal_driving_value_b1"); + + pragma Export (C, Ghdl_Create_Signal_E8, + "__ghdl_create_signal_e8"); + pragma Export (C, Ghdl_Signal_Init_E8, + "__ghdl_signal_init_e8"); + pragma Export (C, Ghdl_Signal_Associate_E8, + "__ghdl_signal_associate_e8"); + pragma Export (C, Ghdl_Signal_Simple_Assign_E8, + "__ghdl_signal_simple_assign_e8"); + pragma Export (C, Ghdl_Signal_Start_Assign_E8, + "__ghdl_signal_start_assign_e8"); + pragma Export (C, Ghdl_Signal_Next_Assign_E8, + "__ghdl_signal_next_assign_e8"); + pragma Export (C, Ghdl_Signal_Driving_Value_E8, + "__ghdl_signal_driving_value_e8"); + + pragma Export (C, Ghdl_Create_Signal_E32, + "__ghdl_create_signal_e32"); + pragma Export (C, Ghdl_Signal_Init_E32, + "__ghdl_signal_init_e32"); + pragma Export (C, Ghdl_Signal_Associate_E32, + "__ghdl_signal_associate_e32"); + pragma Export (C, Ghdl_Signal_Simple_Assign_E32, + "__ghdl_signal_simple_assign_e32"); + pragma Export (C, Ghdl_Signal_Start_Assign_E32, + "__ghdl_signal_start_assign_e32"); + pragma Export (C, Ghdl_Signal_Next_Assign_E32, + "__ghdl_signal_next_assign_e32"); + pragma Export (C, Ghdl_Signal_Driving_Value_E32, + "__ghdl_signal_driving_value_e32"); + + pragma Export (C, Ghdl_Create_Signal_I32, + "__ghdl_create_signal_i32"); + pragma Export (C, Ghdl_Signal_Init_I32, + "__ghdl_signal_init_i32"); + pragma Export (C, Ghdl_Signal_Associate_I32, + "__ghdl_signal_associate_i32"); + pragma Export (C, Ghdl_Signal_Simple_Assign_I32, + "__ghdl_signal_simple_assign_i32"); + pragma Export (C, Ghdl_Signal_Start_Assign_I32, + "__ghdl_signal_start_assign_i32"); + pragma Export (C, Ghdl_Signal_Next_Assign_I32, + "__ghdl_signal_next_assign_i32"); + pragma Export (C, Ghdl_Signal_Driving_Value_I32, + "__ghdl_signal_driving_value_i32"); + + pragma Export (C, Ghdl_Create_Signal_I64, + "__ghdl_create_signal_i64"); + pragma Export (C, Ghdl_Signal_Init_I64, + "__ghdl_signal_init_i64"); + pragma Export (C, Ghdl_Signal_Associate_I64, + "__ghdl_signal_associate_i64"); + pragma Export (C, Ghdl_Signal_Simple_Assign_I64, + "__ghdl_signal_simple_assign_i64"); + pragma Export (C, Ghdl_Signal_Start_Assign_I64, + "__ghdl_signal_start_assign_i64"); + pragma Export (C, Ghdl_Signal_Next_Assign_I64, + "__ghdl_signal_next_assign_i64"); + pragma Export (C, Ghdl_Signal_Driving_Value_I64, + "__ghdl_signal_driving_value_i64"); + + pragma Export (C, Ghdl_Create_Signal_F64, + "__ghdl_create_signal_f64"); + pragma Export (C, Ghdl_Signal_Init_F64, + "__ghdl_signal_init_f64"); + pragma Export (C, Ghdl_Signal_Associate_F64, + "__ghdl_signal_associate_f64"); + pragma Export (C, Ghdl_Signal_Simple_Assign_F64, + "__ghdl_signal_simple_assign_f64"); + pragma Export (C, Ghdl_Signal_Start_Assign_F64, + "__ghdl_signal_start_assign_f64"); + pragma Export (C, Ghdl_Signal_Next_Assign_F64, + "__ghdl_signal_next_assign_f64"); + pragma Export (C, Ghdl_Signal_Driving_Value_F64, + "__ghdl_signal_driving_value_f64"); + + pragma Export (C, Ghdl_Process_Add_Driver, + "__ghdl_process_add_driver"); + pragma Export (C, Ghdl_Signal_Add_Direct_Driver, + "__ghdl_signal_add_direct_driver"); + + pragma Export (C, Ghdl_Signal_Add_Source, + "__ghdl_signal_add_source"); + pragma Export (C, Ghdl_Signal_Effective_Value, + "__ghdl_signal_effective_value"); + pragma Export (C, Ghdl_Signal_In_Conversion, + "__ghdl_signal_in_conversion"); + pragma Export (C, Ghdl_Signal_Out_Conversion, + "__ghdl_signal_out_conversion"); + + pragma Export (C, Ghdl_Signal_Create_Resolution, + "__ghdl_signal_create_resolution"); + + pragma Export (C, Ghdl_Create_Stable_Signal, + "__ghdl_create_stable_signal"); + pragma Export (C, Ghdl_Create_Quiet_Signal, + "__ghdl_create_quiet_signal"); + pragma Export (C, Ghdl_Create_Transaction_Signal, + "__ghdl_create_transaction_signal"); + pragma Export (C, Ghdl_Signal_Attribute_Register_Prefix, + "__ghdl_signal_attribute_register_prefix"); + pragma Export (C, Ghdl_Create_Delayed_Signal, + "__ghdl_create_delayed_signal"); + + pragma Export (Ada, Ghdl_Signal_Create_Guard, + "__ghdl_signal_create_guard"); + pragma Export (C, Ghdl_Signal_Guard_Dependence, + "__ghdl_signal_guard_dependence"); + + pragma Export (C, Ghdl_Signal_Get_Nbr_Ports, + "__ghdl_signal_get_nbr_ports"); + pragma Export (C, Ghdl_Signal_Get_Nbr_Drivers, + "__ghdl_signal_get_nbr_drivers"); + pragma Export (C, Ghdl_Signal_Read_Port, + "__ghdl_signal_read_port"); + pragma Export (C, Ghdl_Signal_Read_Driver, + "__ghdl_signal_read_driver"); + + pragma Export (C, Ghdl_Signal_Active_Chain, + "__ghdl_signal_active_chain"); + +end Grt.Signals; diff --git a/src/translate/grt/grt-stack2.adb b/src/translate/grt/grt-stack2.adb new file mode 100644 index 0000000..82341d0 --- /dev/null +++ b/src/translate/grt/grt-stack2.adb @@ -0,0 +1,205 @@ +-- GHDL Run Time (GRT) - secondary stack. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Grt.Errors; use Grt.Errors; +with Grt.Stdio; +with Grt.Astdio; + +package body Grt.Stack2 is + -- This should be storage_elements.storage_element, but I don't want to + -- use system.storage_elements package (not pure). Unfortunatly, this is + -- currently a failure (storage_elements is automagically used). + type Memory is array (Mark_Id range <>) of Character; + + type Chunk_Type (First, Last : Mark_Id); + type Chunk_Acc is access all Chunk_Type; + type Chunk_Type (First, Last : Mark_Id) is record + Next : Chunk_Acc; + Mem : Memory (First .. Last); + end record; + + type Stack2_Type is record + First_Chunk : Chunk_Acc; + Last_Chunk : Chunk_Acc; + Top : Mark_Id; + end record; + type Stack2_Acc is access all Stack2_Type; + + function To_Acc is new Ada.Unchecked_Conversion + (Source => Stack2_Ptr, Target => Stack2_Acc); + function To_Addr is new Ada.Unchecked_Conversion + (Source => Stack2_Acc, Target => Stack2_Ptr); + + procedure Free is new Ada.Unchecked_Deallocation + (Object => Chunk_Type, Name => Chunk_Acc); + + function Mark (S : Stack2_Ptr) return Mark_Id + is + S2 : Stack2_Acc; + begin + S2 := To_Acc (S); + return S2.Top; + end Mark; + + procedure Release (S : Stack2_Ptr; Mark : Mark_Id) + is + S2 : Stack2_Acc; + begin + S2 := To_Acc (S); + S2.Top := Mark; + end Release; + + function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type) + return System.Address + is + pragma Suppress (All_Checks); + + S2 : Stack2_Acc; + Chunk : Chunk_Acc; + N_Chunk : Chunk_Acc; + + Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment); + Max_Size : constant Mark_Id := + ((Mark_Id (Size) + Max_Align - 1) / Max_Align) * Max_Align; + + Res : System.Address; + begin + S2 := To_Acc (S); + + -- Find the chunk to which S2.TOP belong. + Chunk := S2.First_Chunk; + loop + exit when S2.Top >= Chunk.First and S2.Top <= Chunk.Last; + Chunk := Chunk.Next; + exit when Chunk = null; + end loop; + + if Chunk /= null then + -- If there is enough place in it, allocate from the chunk. + if S2.Top + Max_Size <= Chunk.Last then + Res := Chunk.Mem (S2.Top)'Address; + S2.Top := S2.Top + Max_Size; + return Res; + end if; + + -- If there is not enough place in it: + -- find a chunk which has enough room, deallocate skipped chunk. + loop + N_Chunk := Chunk.Next; + exit when N_Chunk = null; + if N_Chunk.Last - N_Chunk.First + 1 < Max_Size then + -- Not enough place in this chunk. + Chunk.Next := N_Chunk.Next; + Free (N_Chunk); + if Chunk.Next = null then + S2.Last_Chunk := Chunk; + exit; + end if; + else + Res := N_Chunk.Mem (N_Chunk.First)'Address; + S2.Top := N_Chunk.First + Max_Size; + return Res; + end if; + end loop; + end if; + + -- If not such chunk, allocate a chunk + S2.Top := S2.Last_Chunk.Last + 1; + Chunk := new Chunk_Type (First => S2.Top, + Last => S2.Top + Max_Size - 1); + Chunk.Next := null; + S2.Last_Chunk.Next := Chunk; + S2.Last_Chunk := Chunk; + S2.Top := Chunk.Last + 1; + return Chunk.Mem (Chunk.First)'Address; + end Allocate; + + function Create return Stack2_Ptr is + Res : Stack2_Acc; + Chunk : Chunk_Acc; + begin + Chunk := new Chunk_Type (First => 1, Last => 8 * 1024); + Chunk.Next := null; + Res := new Stack2_Type'(First_Chunk => Chunk, + Last_Chunk => Chunk, + Top => 1); + return To_Addr (Res); + end Create; + + procedure Check_Empty (S : Stack2_Ptr) + is + S2 : Stack2_Acc; + begin + S2 := To_Acc (S); + if S2 /= null and then S2.Top /= S2.First_Chunk.First then + Internal_Error ("stack2.check_empty: stack is not empty"); + end if; + end Check_Empty; + + -- May be used to debug. + procedure Dump_Stack2 (S : Stack2_Ptr); + pragma Unreferenced (Dump_Stack2); + + procedure Dump_Stack2 (S : Stack2_Ptr) + is + use Grt.Astdio; + use Grt.Stdio; + use System; + function To_Address is new Ada.Unchecked_Conversion + (Source => Chunk_Acc, Target => Address); + function To_Address is new Ada.Unchecked_Conversion + (Source => Mark_Id, Target => Address); + S2 : Stack2_Acc; + Chunk : Chunk_Acc; + begin + S2 := To_Acc (S); + Put ("Stack 2 at "); + Put (stdout, Address (S)); + New_Line; + Put ("First Chunk at "); + Put (stdout, To_Address (S2.First_Chunk)); + Put (", last chunk at "); + Put (stdout, To_Address (S2.Last_Chunk)); + Put (", top at "); + Put (stdout, To_Address (S2.Top)); + New_Line; + Chunk := S2.First_Chunk; + while Chunk /= null loop + Put ("Chunk "); + Put (stdout, To_Address (Chunk)); + Put (": first: "); + Put (stdout, To_Address (Chunk.First)); + Put (", last: "); + Put (stdout, To_Address (Chunk.Last)); + Put (", len: "); + Put (stdout, To_Address (Chunk.Last - Chunk.First + 1)); + Put (", next = "); + Put (stdout, To_Address (Chunk.Next)); + New_Line; + Chunk := Chunk.Next; + end loop; + end Dump_Stack2; +end Grt.Stack2; diff --git a/src/translate/grt/grt-stack2.ads b/src/translate/grt/grt-stack2.ads new file mode 100644 index 0000000..b3de6b7 --- /dev/null +++ b/src/translate/grt/grt-stack2.ads @@ -0,0 +1,43 @@ +-- GHDL Run Time (GRT) - secondary stack. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; +with Grt.Types; use Grt.Types; + +-- Secondary stack management. +package Grt.Stack2 is + type Stack2_Ptr is new System.Address; + Null_Stack2_Ptr : constant Stack2_Ptr := Stack2_Ptr (System.Null_Address); + + type Mark_Id is new Integer_Address; + + function Mark (S : Stack2_Ptr) return Mark_Id; + procedure Release (S : Stack2_Ptr; Mark : Mark_Id); + function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type) + return System.Address; + function Create return Stack2_Ptr; + + -- Check S is empty. + procedure Check_Empty (S : Stack2_Ptr); +end Grt.Stack2; diff --git a/src/translate/grt/grt-stacks.adb b/src/translate/grt/grt-stacks.adb new file mode 100644 index 0000000..adb008d --- /dev/null +++ b/src/translate/grt/grt-stacks.adb @@ -0,0 +1,43 @@ +-- GHDL Run Time (GRT) - process stacks. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; + +package body Grt.Stacks is + procedure Error_Grow_Failed is + begin + Error ("cannot grow the stack"); + end Error_Grow_Failed; + + procedure Error_Memory_Access is + begin + Error + ("invalid memory access (dangling accesses or stack size too small)"); + end Error_Memory_Access; + + procedure Error_Null_Access is + begin + Error ("NULL access dereferenced"); + end Error_Null_Access; +end Grt.Stacks; diff --git a/src/translate/grt/grt-stacks.ads b/src/translate/grt/grt-stacks.ads new file mode 100644 index 0000000..dd94340 --- /dev/null +++ b/src/translate/grt/grt-stacks.ads @@ -0,0 +1,87 @@ +-- GHDL Run Time (GRT) - process stacks. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Ada.Unchecked_Conversion; + +package Grt.Stacks is + -- Instance is the parameter of the process procedure. + -- This is in fact a fully opaque type whose content is private to the + -- process. + type Instance is limited private; + type Instance_Acc is access all Instance; + pragma Convention (C, Instance_Acc); + + -- A process is identified by a procedure having a single private + -- parameter (its instance). + type Proc_Acc is access procedure (Self : Instance_Acc); + pragma Convention (C, Proc_Acc); + + function To_Address is new Ada.Unchecked_Conversion + (Instance_Acc, System.Address); + + type Stack_Type is new Address; + Null_Stack : constant Stack_Type := Stack_Type (Null_Address); + + -- Initialize the stacks package. + -- This may adjust stack sizes. + -- Must be called after grt.options.decode. + procedure Stack_Init; + + -- Create a new stack, which on first execution will call FUNC with + -- an argument ARG. + function Stack_Create (Func : Proc_Acc; Arg : Instance_Acc) + return Stack_Type; + + -- Resume stack TO and save the current context to the stack pointed by + -- CUR. + procedure Stack_Switch (To : Stack_Type; From : Stack_Type); + + -- Delete stack STACK, which must not be currently executed. + procedure Stack_Delete (Stack : Stack_Type); + + -- Error during stack handling: + -- Cannot grow the stack. + procedure Error_Grow_Failed; + pragma No_Return (Error_Grow_Failed); + + -- Invalid memory access detected (other than dereferencing a NULL access). + procedure Error_Memory_Access; + pragma No_Return (Error_Memory_Access); + + -- A NULL access is dereferenced. + procedure Error_Null_Access; + pragma No_Return (Error_Null_Access); +private + type Instance is null record; + + pragma Import (C, Stack_Init, "grt_stack_init"); + pragma Import (C, Stack_Create, "grt_stack_create"); + pragma Import (C, Stack_Switch, "grt_stack_switch"); + pragma Import (C, Stack_Delete, "grt_stack_delete"); + + pragma Export (C, Error_Grow_Failed, "grt_stack_error_grow_failed"); + pragma Export (C, Error_Memory_Access, "grt_stack_error_memory_access"); + pragma Export (C, Error_Null_Access, "grt_stack_error_null_access"); +end Grt.Stacks; diff --git a/src/translate/grt/grt-stats.adb b/src/translate/grt/grt-stats.adb new file mode 100644 index 0000000..5bc046d --- /dev/null +++ b/src/translate/grt/grt-stats.adb @@ -0,0 +1,370 @@ +-- GHDL Run Time (GRT) - statistics. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Stdio; use Grt.Stdio; +with Grt.Astdio; use Grt.Astdio; +with Grt.Signals; +with Grt.Processes; +with Grt.Types; use Grt.Types; +with Grt.Disp; + +package body Grt.Stats is + type Clock_T is new Integer; + + type Time_Stats is record + Wall : Clock_T; + User : Clock_T; + Sys : Clock_T; + end record; + + -- Number of CLOCK_T per second. + One_Second : Clock_T; + + + -- Get number of seconds per CLOCK_T. + function Get_Clk_Tck return Clock_T; + pragma Import (C, Get_Clk_Tck, "grt_get_clk_tck"); + + -- Get wall, user and system times. + -- This is a binding to times(2). + procedure Get_Times (Wall : Address; User : Address; Sys : Address); + pragma Import (C, Get_Times, "grt_get_times"); + + procedure Get_Stats (Stats : out Time_Stats) + is + begin + Get_Times (Stats.Wall'Address, Stats.User'Address, Stats.Sys'Address); + end Get_Stats; + + function "-" (L : Time_Stats; R : Time_Stats) return Time_Stats + is + begin + return Time_Stats'(Wall => L.Wall - R.Wall, + User => L.User - R.User, + Sys => L.Sys - R.Sys); + end "-"; + + function "+" (L : Time_Stats; R : Time_Stats) return Time_Stats + is + begin + return Time_Stats'(Wall => L.Wall + R.Wall, + User => L.User + R.User, + Sys => L.Sys + R.Sys); + end "+"; + + procedure Put (Stream : FILEs; Val : Clock_T) + is + procedure Fprintf_Clock (Stream : FILEs; A, B : Clock_T); + pragma Import (C, Fprintf_Clock, "__ghdl_fprintf_clock"); + + Sec : Clock_T; + Ms : Clock_T; + begin + Sec := Val / One_Second; + + -- Avoid overflow. + Ms := ((Val mod One_Second) * 1000) / One_Second; + + Fprintf_Clock (Stream, Sec, Ms); + end Put; + + procedure Put (Stream : FILEs; T : Time_Stats) is + begin + Put (Stream, "wall: "); + Put (Stream, T.Wall); + Put (Stream, " user: "); + Put (Stream, T.User); + Put (Stream, " sys: "); + Put (Stream, T.Sys); + end Put; + + type Counter_Kind is (Counter_Elab, Counter_Order, + Counter_Process, Counter_Update, + Counter_Next, Counter_Resume); + + type Counter_Array is array (Counter_Kind) of Time_Stats; + Counters : Counter_Array := (others => (0, 0, 0)); + + Init_Time : Time_Stats; + Last_Counter : Counter_Kind; + Last_Time : Time_Stats; + +-- -- Stats at origin. +-- Start_Time : Time_Stats; +-- End_Elab_Time : Time_Stats; +-- End_Order_Time : Time_Stats; + +-- Start_Proc_Time : Time_Stats; +-- Proc_Times : Time_Stats; + +-- Start_Update_Time : Time_Stats; +-- Update_Times : Time_Stats; + +-- Start_Next_Time_Time : Time_Stats; +-- Next_Time_Times : Time_Stats; + +-- Start_Resume_Time : Time_Stats; +-- Resume_Times : Time_Stats; + +-- Running_Time : Time_Stats; +-- Simu_Time : Time_Stats; + + procedure Start_Elaboration is + begin + One_Second := Get_Clk_Tck; + + Get_Stats (Init_Time); + Last_Time := Init_Time; + Last_Counter := Counter_Elab; + end Start_Elaboration; + + procedure Change_Counter (Cnt : Counter_Kind) + is + New_Time : Time_Stats; + begin + Get_Stats (New_Time); + Counters (Last_Counter) := Counters (Last_Counter) + + (New_Time - Last_Time); + Last_Time := New_Time; + Last_Counter := Cnt; + end Change_Counter; + + procedure Start_Order is + begin + Change_Counter (Counter_Order); + end Start_Order; + + procedure Start_Processes is + begin + Change_Counter (Counter_Process); + end Start_Processes; + + procedure Start_Update is + begin + Change_Counter (Counter_Update); + end Start_Update; + + procedure Start_Next_Time is + begin + Change_Counter (Counter_Next); + end Start_Next_Time; + + procedure Start_Resume is + begin + Change_Counter (Counter_Resume); + end Start_Resume; + + procedure End_Simulation is + begin + Change_Counter (Last_Counter); + end End_Simulation; + + procedure Disp_Signals_Stats + is + use Grt.Signals; + Nbr_No_Drivers : Ghdl_I32; + Nbr_Resolv : Ghdl_I32; + Nbr_Multi_Src : Ghdl_I32; + Nbr_Active : Ghdl_I32; + Nbr_Drivers : Ghdl_I32; + Nbr_Direct_Drivers : Ghdl_I32; + + type Propagation_Kind_Array is array (Propagation_Kind_Type) of Ghdl_I32; + Propag_Count : Propagation_Kind_Array; + + type Mode_Array is array (Mode_Type) of Ghdl_I32; + Mode_Counts : Mode_Array; + + type Mode_Name_Type is array (Mode_Type) of String (1 .. 4); + Mode_Names : constant Mode_Name_Type := (Mode_B1 => "B1: ", + Mode_E8 => "E8: ", + Mode_E32 => "E32:", + Mode_I32 => "I32:", + Mode_I64 => "I64:", + Mode_F64 => "F64:"); + begin + Put (stdout, "Number of simple signals: "); + Put_I32 (stdout, Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1)); + New_Line; + Put (stdout, "Number of signals with projected wave: "); + Put_I32 (stdout, Get_Nbr_Future); + New_Line; + + Nbr_No_Drivers := 0; + Nbr_Resolv := 0; + Nbr_Multi_Src := 0; + Nbr_Active := 0; + Nbr_Drivers := 0; + Nbr_Direct_Drivers := 0; + Mode_Counts := (others => 0); + for I in Sig_Table.First .. Sig_Table.Last loop + declare + Sig : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + begin + Sig := Sig_Table.Table (I); + if Sig.S.Mode_Sig in Mode_Signal_User then + if Sig.S.Nbr_Drivers = 0 then + Nbr_No_Drivers := Nbr_No_Drivers + 1; + end if; + if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 1 then + Nbr_Multi_Src := Nbr_Multi_Src + 1; + end if; + if Sig.S.Resolv /= null then + Nbr_Resolv := Nbr_Resolv + 1; + end if; + Nbr_Drivers := Nbr_Drivers + Ghdl_I32 (Sig.S.Nbr_Drivers); + for J in 1 .. Sig.S.Nbr_Drivers loop + Trans := Sig.S.Drivers (J - 1).Last_Trans; + if Trans /= null and then Trans.Kind = Trans_Direct then + Nbr_Direct_Drivers := Nbr_Direct_Drivers + 1; + end if; + end loop; + end if; + Mode_Counts (Sig.Mode) := Mode_Counts (Sig.Mode) + 1; + if Sig.Has_Active then + Nbr_Active := Nbr_Active + 1; + end if; + end; + end loop; + Put (stdout, "Number of non-driven simple signals: "); + Put_I32 (stdout, Nbr_No_Drivers); + New_Line; + Put (stdout, "Number of resolved simple signals: "); + Put_I32 (stdout, Nbr_Resolv); + New_Line; + Put (stdout, "Number of multi-sourced signals: "); + Put_I32 (stdout, Nbr_Multi_Src); + New_Line; + Put (stdout, "Number of signals whose activity is managed: "); + Put_I32 (stdout, Nbr_Active); + New_Line; + Put (stdout, "Number of drivers: "); + Put_I32 (stdout, Nbr_Drivers); + New_Line; + Put (stdout, "Number of direct drivers: "); + Put_I32 (stdout, Nbr_Direct_Drivers); + New_Line; + Put (stdout, "Number of signals per mode:"); + New_Line; + for I in Mode_Type loop + Put (stdout, " "); + Put (stdout, Mode_Names (I)); + Put (stdout, " "); + Put_I32 (stdout, Mode_Counts (I)); + New_Line; + end loop; + New_Line; + + Propag_Count := (others => 0); + for I in Propagation.First .. Propagation.Last loop + Propag_Count (Propagation.Table (I).Kind) := + Propag_Count (Propagation.Table (I).Kind) + 1; + end loop; + + Put (stdout, "Propagation table length: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Signals.Propagation.Last)); + New_Line; + Put (stdout, "Propagation table count:"); + New_Line; + for I in Propagation_Kind_Type loop + if Propag_Count (I) /= 0 then + Put (stdout, " "); + Grt.Disp.Disp_Propagation_Kind (I); + Put (stdout, ": "); + Put_I32 (stdout, Propag_Count (I)); + New_Line; + end if; + end loop; + end Disp_Signals_Stats; + + -- Disp all statistics. + procedure Disp_Stats + is + N : Natural; + begin + Put (stdout, "total: "); + Put (stdout, Last_Time - Init_Time); + New_Line (stdout); + Put (stdout, " elab: "); + Put (stdout, Counters (Counter_Elab)); + New_Line (stdout); + Put (stdout, " internal elab: "); + Put (stdout, Counters (Counter_Order)); + New_Line (stdout); + Put (stdout, " cycle (sum): "); + Put (stdout, Counters (Counter_Process) + Counters (Counter_Resume) + + Counters (Counter_Update) + Counters (Counter_Next)); + New_Line (stdout); + Put (stdout, " processes: "); + Put (stdout, Counters (Counter_Process)); + New_Line (stdout); + Put (stdout, " resume: "); + Put (stdout, Counters (Counter_Resume)); + New_Line (stdout); + Put (stdout, " update: "); + Put (stdout, Counters (Counter_Update)); + New_Line (stdout); + Put (stdout, " next compute: "); + Put (stdout, Counters (Counter_Next)); + New_Line (stdout); + + Disp_Signals_Stats; + + Put (stdout, "Number of delta cycles: "); + Put_I32 (stdout, Ghdl_I32 (Processes.Nbr_Delta_Cycles)); + New_Line; + Put (stdout, "Number of non-delta cycles: "); + Put_I32 (stdout, Ghdl_I32 (Processes.Nbr_Cycles)); + New_Line; + + Put (stdout, "Nbr of events: "); + Put_I32 (stdout, Signals.Nbr_Events); + New_Line; + Put (stdout, "Nbr of active: "); + Put_I32 (stdout, Signals.Nbr_Active); + New_Line; + + Put (stdout, "Number of processes: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Processes)); + New_Line; + Put (stdout, "Number of sensitized processes: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Sensitized_Processes)); + New_Line; + Put (stdout, "Number of resumed processes: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Resumed_Processes)); + New_Line; + Put (stdout, "Average number of resumed processes per cycle: "); + N := Processes.Nbr_Delta_Cycles + Processes.Nbr_Cycles; + if N = 0 then + Put (stdout, "-"); + else + Put_I32 (stdout, Ghdl_I32 (Processes.Get_Nbr_Resumed_Processes / N)); + end if; + New_Line; + end Disp_Stats; +end Grt.Stats; diff --git a/src/translate/grt/grt-stats.ads b/src/translate/grt/grt-stats.ads new file mode 100644 index 0000000..6f60261 --- /dev/null +++ b/src/translate/grt/grt-stats.ads @@ -0,0 +1,54 @@ +-- GHDL Run Time (GRT) - statistics. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package Grt.Stats is + -- Entry points to gather statistics. + procedure Start_Elaboration; + procedure Start_Order; + + -- Time in user processes. + procedure Start_Processes; + + + -- Time in next time computation. + procedure Start_Next_Time; + + + -- Time in signals update. + procedure Start_Update; + + + -- Time in process resume + procedure Start_Resume; + + + procedure End_Simulation; + + -- Disp all statistics. + procedure Disp_Stats; +end Grt.Stats; + + + diff --git a/src/translate/grt/grt-std_logic_1164.adb b/src/translate/grt/grt-std_logic_1164.adb new file mode 100644 index 0000000..5be308b --- /dev/null +++ b/src/translate/grt/grt-std_logic_1164.adb @@ -0,0 +1,146 @@ +-- GHDL Run Time (GRT) std_logic_1664 subprograms. +-- Copyright (C) 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with Grt.Lib; + +package body Grt.Std_Logic_1164 is + Assert_DC_Msg : constant String := + "STD_LOGIC_1164: '-' operand for matching ordering operator"; + + Assert_DC_Msg_Bound : constant Std_String_Bound := + (Dim_1 => (Left => 1, Right => Assert_DC_Msg'Length, Dir => Dir_To, + Length => Assert_DC_Msg'Length)); + + Assert_DC_Msg_Str : aliased constant Std_String := + (Base => To_Std_String_Basep (Assert_DC_Msg'Address), + Bounds => To_Std_String_Boundp (Assert_DC_Msg_Bound'Address)); + + Filename : constant String := "std_logic_1164.vhdl" & NUL; + Loc : aliased constant Ghdl_Location := + (Filename => To_Ghdl_C_String (Filename'Address), + Line => 58, + Col => 3); + + procedure Assert_Not_Match (V : Std_Ulogic) + is + use Grt.Lib; + begin + if V = '-' then + Ghdl_Ieee_Assert_Failed + (To_Std_String_Ptr (Assert_DC_Msg_Str'Address), Error_Severity, + To_Ghdl_Location_Ptr (Loc'Address)); + end if; + end Assert_Not_Match; + + function Ghdl_Std_Ulogic_Match_Eq (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Match_Eq_Table (Left, Right)); + end Ghdl_Std_Ulogic_Match_Eq; + + function Ghdl_Std_Ulogic_Match_Ne (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Not_Table (Match_Eq_Table (Left, Right))); + end Ghdl_Std_Ulogic_Match_Ne; + + function Ghdl_Std_Ulogic_Match_Lt (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Match_Lt_Table (Left, Right)); + end Ghdl_Std_Ulogic_Match_Lt; + + function Ghdl_Std_Ulogic_Match_Le (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Or_Table (Match_Lt_Table (Left, Right), + Match_Eq_Table (Left, Right))); + end Ghdl_Std_Ulogic_Match_Le; + + Assert_Arr_Msg : constant String := + "parameters of '?=' array operator are not of the same length"; + + Assert_Arr_Msg_Bound : constant Std_String_Bound := + (Dim_1 => (Left => 1, Right => Assert_Arr_Msg'Length, Dir => Dir_To, + Length => Assert_Arr_Msg'Length)); + + Assert_Arr_Msg_Str : aliased constant Std_String := + (Base => To_Std_String_Basep (Assert_Arr_Msg'Address), + Bounds => To_Std_String_Boundp (Assert_Arr_Msg_Bound'Address)); + + + function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32 + is + use Grt.Lib; + L_Arr : constant Ghdl_E8_Array_Base_Ptr := + To_Ghdl_E8_Array_Base_Ptr (L); + R_Arr : constant Ghdl_E8_Array_Base_Ptr := + To_Ghdl_E8_Array_Base_Ptr (R); + Res : Std_Ulogic := '1'; + begin + if L_Len /= R_Len then + Ghdl_Ieee_Assert_Failed + (To_Std_String_Ptr (Assert_Arr_Msg_Str'Address), Error_Severity, + To_Ghdl_Location_Ptr (Loc'Address)); + end if; + for I in 1 .. L_Len loop + Res := And_Table + (Res, Std_Ulogic'Val (Ghdl_Std_Ulogic_Match_Eq (L_Arr (I - 1), + R_Arr (I - 1)))); + end loop; + return Std_Ulogic'Pos (Res); + end Ghdl_Std_Ulogic_Array_Match_Eq; + + function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32 is + begin + return Std_Ulogic'Pos + (Not_Table (Std_Ulogic'Val + (Ghdl_Std_Ulogic_Array_Match_Eq (L, L_Len, R, R_Len)))); + end Ghdl_Std_Ulogic_Array_Match_Ne; +end Grt.Std_Logic_1164; diff --git a/src/translate/grt/grt-std_logic_1164.ads b/src/translate/grt/grt-std_logic_1164.ads new file mode 100644 index 0000000..4d15695 --- /dev/null +++ b/src/translate/grt/grt-std_logic_1164.ads @@ -0,0 +1,124 @@ +-- GHDL Run Time (GRT) std_logic_1664 subprograms. +-- Copyright (C) 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with Grt.Types; use Grt.Types; + +package Grt.Std_Logic_1164 is + type Std_Ulogic is ('U', 'X', '0', '1', 'Z', 'W','L', 'H', '-'); + + type Stdlogic_Table_2d is array (Std_Ulogic, Std_Ulogic) of Std_Ulogic; + type Stdlogic_Table_1d is array (Std_Ulogic) of Std_Ulogic; + + -- LRM08 9.2.3 Relational operators + Match_Eq_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUUUUUUU1", + "UXXXXXXX1", + "UX10XX101", + "UX01XX011", + "UXXXXXXX1", + "UXXXXXXX1", + "UX10XX101", + "UX01XX011", + "111111111"); + + Match_Lt_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUUUUUUUX", + "UXXXXXXXX", + "UX01XX01X", + "UX00XX00X", + "UXXXXXXXX", + "UXXXXXXXX", + "UX01XX01X", + "UX00XX00X", + "XXXXXXXXX"); + + And_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UU0UUU0UX", -- U + "UX0XXX0XX", -- X + "000000000", -- 0 + "UX01XX01X", -- 1 + "UX0XXX0XX", -- Z + "UX0XXX0XX", -- W + "000000000", -- L + "UX01XX01X", -- H + "UX0XXX0XX"); -- - + + Or_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUU1UUU1U", -- U + "UXX1XXX1X", -- X + "UX01XX01X", -- 0 + "111111111", -- 1 + "UXX1XXX1X", -- Z + "UXX1XXX1X", -- W + "UX01XX01X", -- L + "111111111", -- H + "UXX1XXX1X"); -- - + + Xor_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUUUUUUUU", -- U + "UXXXXXXXX", -- X + "UX01XX01X", -- 0 + "UX10XX10X", -- 1 + "UXXXXXXXX", -- Z + "UXXXXXXXX", -- W + "UX01XX01X", -- L + "UX10XX10X", -- H + "UXXXXXXXX"); -- - + + Not_Table : constant Stdlogic_Table_1d := "UX10XX10X"; + + function Ghdl_Std_Ulogic_Match_Eq (L, R : Ghdl_E8) return Ghdl_E8; + function Ghdl_Std_Ulogic_Match_Ne (L, R : Ghdl_E8) return Ghdl_E8; + function Ghdl_Std_Ulogic_Match_Lt (L, R : Ghdl_E8) return Ghdl_E8; + function Ghdl_Std_Ulogic_Match_Le (L, R : Ghdl_E8) return Ghdl_E8; + -- For Gt and Ge, use Lt and Le with swapped parameters. + + function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32; + function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32; + +private + pragma Export (C, Ghdl_Std_Ulogic_Match_Eq, "__ghdl_std_ulogic_match_eq"); + pragma Export (C, Ghdl_Std_Ulogic_Match_Ne, "__ghdl_std_ulogic_match_ne"); + pragma Export (C, Ghdl_Std_Ulogic_Match_Lt, "__ghdl_std_ulogic_match_lt"); + pragma Export (C, Ghdl_Std_Ulogic_Match_Le, "__ghdl_std_ulogic_match_le"); + + pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Eq, + "__ghdl_std_ulogic_array_match_eq"); + pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Ne, + "__ghdl_std_ulogic_array_match_ne"); +end Grt.Std_Logic_1164; diff --git a/src/translate/grt/grt-stdio.ads b/src/translate/grt/grt-stdio.ads new file mode 100644 index 0000000..229249a --- /dev/null +++ b/src/translate/grt/grt-stdio.ads @@ -0,0 +1,107 @@ +-- GHDL Run Time (GRT) - stdio binding. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; +with Grt.C; use Grt.C; + +-- This package provides a thin binding to the stdio.h of the C library. +-- It mimics GNAT package Interfaces.C_Streams. +-- The purpose of this package is to remove dependencies on the GNAT run time. + +package Grt.Stdio is + pragma Preelaborate (Grt.Stdio); + + -- Type FILE *. + type FILEs is new System.Address; + + -- NULL for a stream. + NULL_Stream : constant FILEs; + + -- Predefined streams. + function stdout return FILEs; + function stderr return FILEs; + function stdin return FILEs; + + -- The following subprograms are translation of the C prototypes. + + function fopen (path: chars; mode : chars) return FILEs; + + function fwrite (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + + function fread (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + + function fputc (c : int; stream : FILEs) return int; + procedure fputc (c : int; stream : FILEs); + + function fputs (s : chars; stream : FILEs) return int; + + function fgetc (stream : FILEs) return int; + function fgets (s : chars; size : int; stream : FILEs) return chars; + function ungetc (c : int; stream : FILEs) return int; + + function fflush (stream : FILEs) return int; + procedure fflush (stream : FILEs); + + function feof (stream : FILEs) return int; + + function ftell (stream : FILEs) return long; + + function fclose (stream : FILEs) return int; + procedure fclose (Stream : FILEs); +private + -- This is a little bit dubious, but this package should be preelaborated, + -- and Null_Address is not static (since defined in the private part + -- of System). + -- I am pretty sure the C definition of NULL is 0. + NULL_Stream : constant FILEs := FILEs (System'To_Address (0)); + + pragma Import (C, fopen); + + pragma Import (C, fwrite); + pragma Import (C, fread); + + pragma Import (C, fputs); + pragma Import (C, fputc); + + pragma Import (C, fgetc); + pragma Import (C, fgets); + pragma Import (C, ungetc); + + pragma Import (C, fflush); + pragma Import (C, feof); + pragma Import (C, ftell); + pragma Import (C, fclose); + + pragma Import (C, stdout, "__ghdl_get_stdout"); + pragma Import (C, stderr, "__ghdl_get_stderr"); + pragma Import (C, stdin, "__ghdl_get_stdin"); +end Grt.Stdio; diff --git a/src/translate/grt/grt-table.adb b/src/translate/grt/grt-table.adb new file mode 100644 index 0000000..36aa999 --- /dev/null +++ b/src/translate/grt/grt-table.adb @@ -0,0 +1,120 @@ +-- GHDL Run Time (GRT) - Resizable array +-- Copyright (C) 2008 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with System; use System; +with Grt.C; use Grt.C; + +package body Grt.Table is + + -- Maximum index of table before resizing. + Max : Table_Index_Type := Table_Index_Type'Pred (Table_Low_Bound); + + -- Current value of Last + Last_Val : Table_Index_Type; + + function Malloc (Size : size_t) return Table_Ptr; + pragma Import (C, Malloc); + + procedure Free (T : Table_Ptr); + pragma Import (C, Free); + + -- Resize and reallocate the table according to LAST_VAL. + procedure Resize is + function Realloc (T : Table_Ptr; Size : size_t) return Table_Ptr; + pragma Import (C, Realloc); + + New_Size : size_t; + begin + while Max < Last_Val loop + Max := Max + (Max - Table_Low_Bound + 1); + end loop; + + New_Size := size_t ((Max - Table_Low_Bound + 1) * + (Table_Type'Component_Size / Storage_Unit)); + + Table := Realloc (Table, New_Size); + + if Table = null then + raise Storage_Error; + end if; + end Resize; + + procedure Append (New_Val : Table_Component_Type) is + begin + Increment_Last; + Table (Last_Val) := New_Val; + end Append; + + procedure Decrement_Last is + begin + Last_Val := Table_Index_Type'Pred (Last_Val); + end Decrement_Last; + + procedure Free is + begin + Free (Table); + Table := null; + end Free; + + procedure Increment_Last is + begin + Last_Val := Table_Index_Type'Succ (Last_Val); + + if Last_Val > Max then + Resize; + end if; + end Increment_Last; + + function Last return Table_Index_Type is + begin + return Last_Val; + end Last; + + procedure Release is + begin + Max := Last_Val; + Resize; + end Release; + + procedure Set_Last (New_Val : Table_Index_Type) is + begin + if New_Val < Last_Val then + Last_Val := New_Val; + else + Last_Val := New_Val; + + if Last_Val > Max then + Resize; + end if; + end if; + end Set_Last; + +begin + 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 * + (Table_Type'Component_Size / Storage_Unit))); +end Grt.Table; diff --git a/src/translate/grt/grt-table.ads b/src/translate/grt/grt-table.ads new file mode 100644 index 0000000..f814eff --- /dev/null +++ b/src/translate/grt/grt-table.ads @@ -0,0 +1,75 @@ +-- GHDL Run Time (GRT) - Resizable array +-- Copyright (C) 2008 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type; + Table_Initial : Positive; + +package Grt.Table is + pragma Elaborate_Body; + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + subtype Fat_Table_Type is + Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + + -- Thin pointer. + type Table_Ptr is access all Fat_Table_Type; + + -- The table itself. + Table : aliased Table_Ptr := null; + + -- Get the high bound. + function Last return Table_Index_Type; + pragma Inline (Last); + + -- Get the low bound. + First : constant Table_Index_Type := Table_Low_Bound; + + -- Increase the length by 1. + procedure Increment_Last; + pragma Inline (Increment_Last); + + -- Decrease the length by 1. + procedure Decrement_Last; + pragma Inline (Decrement_Last); + + -- Set the last bound. + procedure Set_Last (New_Val : Table_Index_Type); + + -- Release extra memory. + procedure Release; + + -- Free all the memory used by the table. + -- The table won't be useable anymore. + procedure Free; + + -- Append a new element. + procedure Append (New_Val : Table_Component_Type); + pragma Inline (Append); +end Grt.Table; diff --git a/src/translate/grt/grt-threads.ads b/src/translate/grt/grt-threads.ads new file mode 100644 index 0000000..248f2c4 --- /dev/null +++ b/src/translate/grt/grt-threads.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - threading. +-- Copyright (C) 2005 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Unithread; + +package Grt.Threads renames Grt.Unithread; diff --git a/src/translate/grt/grt-types.ads b/src/translate/grt/grt-types.ads new file mode 100644 index 0000000..fed8225 --- /dev/null +++ b/src/translate/grt/grt-types.ads @@ -0,0 +1,327 @@ +-- GHDL Run Time (GRT) - common types. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Interfaces; use Interfaces; + +package Grt.Types is + pragma Preelaborate (Grt.Types); + + type Ghdl_B1 is new Boolean; + type Ghdl_E8 is new Unsigned_8; + type Ghdl_U32 is new Unsigned_32; + subtype Ghdl_E32 is Ghdl_U32; + type Ghdl_I32 is new Integer_32; + type Ghdl_I64 is new Integer_64; + type Ghdl_U64 is new Unsigned_64; + type Ghdl_F64 is new IEEE_Float_64; + + type Ghdl_Ptr is new Address; + type Ghdl_Index_Type is mod 2 ** 32; + subtype Ghdl_Real is Ghdl_F64; + + type Ghdl_Dir_Type is (Dir_To, Dir_Downto); + for Ghdl_Dir_Type use (Dir_To => 0, Dir_Downto => 1); + for Ghdl_Dir_Type'Size use 8; + + -- Access to an unconstrained string. + type String_Access is access String; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => String_Access, Object => String); + + subtype Std_Integer is Ghdl_I32; + + type Std_Time is new Ghdl_I64; + Bad_Time : constant Std_Time := Std_Time'First; + + type Std_Integer_Trt is record + Left : Std_Integer; + Right : Std_Integer; + Dir : Ghdl_Dir_Type; + Length : Ghdl_Index_Type; + end record; + + subtype Std_Character is Character; + type Std_String_Uncons is array (Ghdl_Index_Type range <>) of Std_Character; + subtype Std_String_Base is Std_String_Uncons (Ghdl_Index_Type); + type Std_String_Basep is access all Std_String_Base; + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => Address, Target => Std_String_Basep); + + type Std_String_Bound is record + Dim_1 : Std_Integer_Trt; + end record; + type Std_String_Boundp is access all Std_String_Bound; + function To_Std_String_Boundp is new Ada.Unchecked_Conversion + (Source => Address, Target => Std_String_Boundp); + + type Std_String is record + Base : Std_String_Basep; + Bounds : Std_String_Boundp; + end record; + type Std_String_Ptr is access all Std_String; + function To_Std_String_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Std_String_Ptr); + + type Std_Bit is ('0', '1'); + type Std_Bit_Vector_Uncons is array (Ghdl_Index_Type range <>) of Std_Bit; + subtype Std_Bit_Vector_Base is Std_Bit_Vector_Uncons (Ghdl_Index_Type); + type Std_Bit_Vector_Basep is access all Std_Bit_Vector_Base; + + -- An unconstrained array. + -- It is in fact a fat pointer to the base and the bounds. + type Ghdl_Uc_Array is record + Base : Address; + Bounds : Address; + end record; + type Ghdl_Uc_Array_Acc is access Ghdl_Uc_Array; + function To_Ghdl_Uc_Array_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Uc_Array_Acc); + + -- Verilog types. + + type Ghdl_Logic32 is record + Val : Ghdl_U32; + Xz : Ghdl_U32; + end record; + type Ghdl_Logic32_Ptr is access Ghdl_Logic32; + type Ghdl_Logic32_Vec is array (Ghdl_U32) of Ghdl_Logic32; + type Ghdl_Logic32_Vptr is access Ghdl_Logic32_Vec; + + function To_Ghdl_Logic32_Vptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Logic32_Vptr); + + function To_Ghdl_Logic32_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Logic32_Ptr); + + -- Mimics C strings (NUL ended). + -- Note: this is 1 based. + type Ghdl_C_String is access String (Positive); + NUL : constant Character := Character'Val (0); + + Nl : constant Character := Character'Val (10); -- LF, nl or '\n'. + + function strlen (Str : Ghdl_C_String) return Natural; + pragma Import (C, strlen); + + function Strcmp (L , R : Ghdl_C_String) return Integer; + pragma Import (C, Strcmp); + + function To_Ghdl_C_String is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_C_String); + + -- Str_len. + type String_Ptr is access String (1 .. Natural'Last); + type Ghdl_Str_Len_Type is record + Len : Natural; + Str : String_Ptr; + end record; + -- Same as previous one, but using 'address. + type Ghdl_Str_Len_Address_Type is record + Len : Natural; + Str : Address; + end record; + type Ghdl_Str_Len_Ptr is access constant Ghdl_Str_Len_Type; + type Ghdl_Str_Len_Array is array (Natural) of Ghdl_Str_Len_Type; + type Ghdl_Str_Len_Array_Ptr is access all Ghdl_Str_Len_Array; + + -- Location is used for errors/messages. + type Ghdl_Location is record + Filename : Ghdl_C_String; + Line : Integer; + Col : Integer; + end record; + type Ghdl_Location_Ptr is access Ghdl_Location; + function To_Ghdl_Location_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Location_Ptr); + + -- Signal index. + type Sig_Table_Index is new Integer; + + -- A range of signals. + type Sig_Table_Range is record + First, Last : Sig_Table_Index; + end record; + + -- Simple values, used for signals. + type Mode_Type is + (Mode_B1, Mode_E8, Mode_E32, Mode_I32, Mode_I64, Mode_F64); + + type Ghdl_B1_Array is array (Ghdl_Index_Type range <>) of Ghdl_B1; + subtype Ghdl_B1_Array_Base is Ghdl_B1_Array (Ghdl_Index_Type); + type Ghdl_B1_Array_Base_Ptr is access Ghdl_B1_Array_Base; + function To_Ghdl_B1_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_B1_Array_Base_Ptr); + + type Ghdl_E8_Array is array (Ghdl_Index_Type range <>) of Ghdl_E8; + subtype Ghdl_E8_Array_Base is Ghdl_E8_Array (Ghdl_Index_Type); + type Ghdl_E8_Array_Base_Ptr is access Ghdl_E8_Array_Base; + function To_Ghdl_E8_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_E8_Array_Base_Ptr); + + type Ghdl_E32_Array is array (Ghdl_Index_Type range <>) of Ghdl_E32; + subtype Ghdl_E32_Array_Base is Ghdl_E32_Array (Ghdl_Index_Type); + type Ghdl_E32_Array_Base_Ptr is access Ghdl_E32_Array_Base; + function To_Ghdl_E32_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_E32_Array_Base_Ptr); + + type Ghdl_I32_Array is array (Ghdl_Index_Type range <>) of Ghdl_I32; + + type Value_Union (Mode : Mode_Type := Mode_B1) is record + case Mode is + when Mode_B1 => + B1 : Ghdl_B1; + when Mode_E8 => + E8 : Ghdl_E8; + when Mode_E32 => + E32 : Ghdl_E32; + when Mode_I32 => + I32 : Ghdl_I32; + when Mode_I64 => + I64 : Ghdl_I64; + when Mode_F64 => + F64 : Ghdl_F64; + end case; + end record; + pragma Unchecked_Union (Value_Union); + + type Ghdl_Value_Ptr is access Value_Union; + function To_Ghdl_Value_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Value_Ptr); + + -- Ranges. + type Ghdl_Range_B1 is record + Left : Ghdl_B1; + Right : Ghdl_B1; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_E8 is record + Left : Ghdl_E8; + Right : Ghdl_E8; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_E32 is record + Left : Ghdl_E32; + Right : Ghdl_E32; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_I32 is record + Left : Ghdl_I32; + Right : Ghdl_I32; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_I64 is record + Left : Ghdl_I64; + Right : Ghdl_I64; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_F64 is record + Left : Ghdl_F64; + Right : Ghdl_F64; + Dir : Ghdl_Dir_Type; + end record; + + type Ghdl_Range_Type (K : Mode_Type := Mode_B1) is record + case K is + when Mode_B1 => + B1 : Ghdl_Range_B1; + when Mode_E8 => + E8 : Ghdl_Range_E8; + when Mode_E32 => + E32 : Ghdl_Range_E32; + when Mode_I32 => + I32 : Ghdl_Range_I32; + when Mode_I64 => + P64 : Ghdl_Range_I64; + when Mode_F64 => + F64 : Ghdl_Range_F64; + end case; + end record; + pragma Unchecked_Union (Ghdl_Range_Type); + + type Ghdl_Range_Ptr is access all Ghdl_Range_Type; + + function To_Ghdl_Range_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Range_Ptr); + + type Ghdl_Range_Array is array (Ghdl_Index_Type range <>) of Ghdl_Range_Ptr; + + -- Mode of a signal. + type Mode_Signal_Type is + (Mode_Signal, + Mode_Linkage, Mode_Buffer, Mode_Out, Mode_Inout, Mode_In, + Mode_Stable, Mode_Quiet, Mode_Delayed, Mode_Transaction, Mode_Guard, + Mode_Conv_In, Mode_Conv_Out, + Mode_End); + + subtype Mode_Signal_Port is + Mode_Signal_Type range Mode_Linkage .. Mode_In; + + -- Not implicit signals. + subtype Mode_Signal_User is + Mode_Signal_Type range Mode_Signal .. Mode_In; + + -- Implicit signals. + subtype Mode_Signal_Implicit is + Mode_Signal_Type range Mode_Stable .. Mode_Guard; + + subtype Mode_Signal_Forward is + Mode_Signal_Type range Mode_Stable .. Mode_Delayed; + + -- Kind of a signal. + type Kind_Signal_Type is + (Kind_Signal_No, Kind_Signal_Register, Kind_Signal_Bus); + + -- Note: we could use system.storage_elements, but unfortunatly, + -- this doesn't work with pragma no_run_time (gnat 3.15p). + type Integer_Address is mod Memory_Size; + + function To_Address is new Ada.Unchecked_Conversion + (Source => Integer_Address, Target => Address); + + function To_Integer is new Ada.Unchecked_Conversion + (Source => Address, Target => Integer_Address); + + -- The NOW value. + Current_Time : Std_Time; + -- Copy of Current_Time before updating it. + -- To be used by hooks. + Cycle_Time : Std_Time; + -- The current delta cycle number. + Current_Delta : Integer; +private + pragma Export (C, Current_Time, "__ghdl_now"); +end Grt.Types; diff --git a/src/translate/grt/grt-unithread.adb b/src/translate/grt/grt-unithread.adb new file mode 100644 index 0000000..6acb521 --- /dev/null +++ b/src/translate/grt/grt-unithread.adb @@ -0,0 +1,106 @@ +-- GHDL Run Time (GRT) - mono-thread version. +-- Copyright (C) 2005 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package body Grt.Unithread is + procedure Init is + begin + null; + end Init; + + procedure Finish is + begin + null; + end Finish; + + procedure Run_Parallel (Subprg : Parallel_Subprg_Acc) is + begin + Subprg.all; + end Run_Parallel; + + function Atomic_Insert (List : access Ghdl_Signal_Ptr; El : Ghdl_Signal_Ptr) + return Ghdl_Signal_Ptr + is + Prev : Ghdl_Signal_Ptr; + begin + Prev := List.all; + List.all := El; + return Prev; + end Atomic_Insert; + + function Atomic_Inc (Val : access Natural) return Natural + is + Res : Natural; + begin + Res := Val.all; + Val.all := Val.all + 1; + return Res; + end Atomic_Inc; + + Current_Process : Process_Acc; + + -- Called by linux.c + function Grt_Get_Current_Process return Process_Acc; + pragma Export (C, Grt_Get_Current_Process); + + function Grt_Get_Current_Process return Process_Acc is + begin + return Current_Process; + end Grt_Get_Current_Process; + + + procedure Set_Current_Process (Proc : Process_Acc) is + begin + Current_Process := Proc; + end Set_Current_Process; + + function Get_Current_Process return Process_Acc is + begin + return Current_Process; + end Get_Current_Process; + + Stack2 : Stack2_Ptr; + + function Get_Stack2 return Stack2_Ptr is + begin + return Stack2; + end Get_Stack2; + + procedure Set_Stack2 (St : Stack2_Ptr) is + begin + Stack2 := St; + end Set_Stack2; + + Main_Stack : Stack_Type; + + function Get_Main_Stack return Stack_Type is + begin + return Main_Stack; + end Get_Main_Stack; + + procedure Set_Main_Stack (St : Stack_Type) is + begin + Main_Stack := St; + end Set_Main_Stack; +end Grt.Unithread; diff --git a/src/translate/grt/grt-unithread.ads b/src/translate/grt/grt-unithread.ads new file mode 100644 index 0000000..b35b7be --- /dev/null +++ b/src/translate/grt/grt-unithread.ads @@ -0,0 +1,73 @@ +-- GHDL Run Time (GRT) - mono-thread version. +-- Copyright (C) 2005 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Signals; use Grt.Signals; +with Grt.Stack2; use Grt.Stack2; +with Grt.Stacks; use Grt.Stacks; + +package Grt.Unithread is + procedure Init; + procedure Finish; + + type Parallel_Subprg_Acc is access procedure; + procedure Run_Parallel (Subprg : Parallel_Subprg_Acc); + + -- Return the old value of LIST.all and store EL into LIST.all. + function Atomic_Insert (List : access Ghdl_Signal_Ptr; El : Ghdl_Signal_Ptr) + return Ghdl_Signal_Ptr; + + -- Return the old value. + function Atomic_Inc (Val : access Natural) return Natural; + + -- Set and get the current process being executed by the thread. + procedure Set_Current_Process (Proc : Process_Acc); + function Get_Current_Process return Process_Acc; + + -- The secondary stack for the thread. In this implementation, there is + -- only one secondary stack, shared by all processes. This is allowed, + -- because a wait statement cannot appear within a function. So at a wait + -- statement, the secondary stack must be empty. + function Get_Stack2 return Stack2_Ptr; + procedure Set_Stack2 (St : Stack2_Ptr); + + -- The main stack. This is initialized by STACK_INIT. + -- The return point. + function Get_Main_Stack return Stack_Type; + procedure Set_Main_Stack (St : Stack_Type); +private + pragma Inline (Run_Parallel); + pragma Inline (Atomic_Insert); + pragma Inline (Atomic_Inc); + pragma Inline (Get_Stack2); + pragma Inline (Set_Stack2); + + pragma Inline (Get_Main_Stack); + pragma Export (C, Set_Main_Stack, "grt_set_main_stack"); + + pragma Inline (Set_Current_Process); + pragma Inline (Get_Current_Process); + +end Grt.Unithread; diff --git a/src/translate/grt/grt-values.adb b/src/translate/grt/grt-values.adb new file mode 100644 index 0000000..3d703bc --- /dev/null +++ b/src/translate/grt/grt-values.adb @@ -0,0 +1,639 @@ +-- GHDL Run Time (GRT) - 'value subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; +with Grt.Rtis_Utils; + +package body Grt.Values is + + NBSP : constant Character := Character'Val (160); + HT : constant Character := Character'Val (9); + + -- Return True IFF C is a whitespace character (as defined in LRM93 14.3) + function Is_Whitespace (C : in Character) return Boolean is + begin + return C = ' ' or C = NBSP or C = HT; + end Is_Whitespace; + + -- Increase POS to skip leading whitespace characters, decrease LEN to + -- skip trailing whitespaces in string S. + procedure Remove_Whitespaces (S : Std_String_Basep; + Len : in out Ghdl_Index_Type; + Pos : in out Ghdl_Index_Type) is + begin + -- GHDL: allow several leading whitespace. + while Pos < Len loop + exit when not Is_Whitespace (S (Pos)); + Pos := Pos + 1; + end loop; + + -- GHDL: allow several leading whitespace. + while Len > Pos loop + exit when not Is_Whitespace (S (Len - 1)); + Len := Len - 1; + end loop; + if Pos = Len then + Error_E ("'value: empty string"); + end if; + end Remove_Whitespaces; + + -- Convert C to lowercase. + function To_LC (C : in Character) return Character is + begin + if C >= 'A' and then C <= 'Z' then + return Character'Val + (Character'Pos (C) + Character'Pos ('a') - Character'Pos ('A')); + else + return C; + end if; + end To_LC; + + -- Return TRUE iff user string S (POS .. LEN - 1) is equal to REF. + -- Comparaison is case insensitive, but REF must be lowercase (REF is + -- supposed to come from an RTI). + function String_Match (S : Std_String_Basep; + Pos : Ghdl_Index_Type; + Len : Ghdl_Index_Type; + Ref : Ghdl_C_String) return Boolean + is + P : Ghdl_Index_Type; + C : Character; + begin + P := 0; + loop + C := Ref (Natural (P + 1)); + if Pos + P = Len then + -- End of string. + return C = ASCII.NUL; + end if; + if To_LC (S (Pos + P)) /= C or else C = ASCII.NUL then + return False; + end if; + P := P + 1; + end loop; + end String_Match; + + -- Return the value of STR for enumerated type RTI. + function Ghdl_Value_Enum (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_Index_Type + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + begin + Remove_Whitespaces (S, Len, Pos); + + for I in 0 .. Enum_Rti.Nbr - 1 loop + if String_Match (S, Pos, Len, Enum_Rti.Names (I)) then + return I; + end if; + end loop; + Error_C ("'value: '"); + Error_C_Std (S (Pos .. Len)); + Error_C ("' not in enumeration '"); + Error_C (Enum_Rti.Name); + Error_E ("'"); + end Ghdl_Value_Enum; + + function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_B1 + is + begin + return Ghdl_B1'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_B1; + + function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E8 + is + begin + return Ghdl_E8'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_E8; + + function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E32 + is + begin + return Ghdl_E32'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_E32; + + -- Convert S (INIT_POS .. LEN) to a signed integer. + function Ghdl_Value_I64 (S : Std_String_Basep; + Len : Ghdl_Index_Type; + Init_Pos : Ghdl_Index_Type) + return Ghdl_I64 + is + Pos : Ghdl_Index_Type := Init_Pos; + C : Character; + Sep : Character; + Val, D, Base : Ghdl_I64; + Exp : Integer; + begin + C := S (Pos); + + -- Be user friendly. + -- FIXME: reference. + if C = '-' or C = '+' then + Error_E ("'value: leading sign +/- not allowed"); + end if; + + Val := 0; + loop + if C in '0' .. '9' then + Val := Val * 10 + Character'Pos (C) - Character'Pos ('0'); + Pos := Pos + 1; + exit when Pos >= Len; + C := S (Pos); + else + Error_E ("'value: decimal digit expected"); + end if; + case C is + when '_' => + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: trailing underscore"); + end if; + C := S (Pos); + when '#' + | ':' + | 'E' + | 'e' => + exit; + when ' ' + | NBSP + | HT => + Pos := Pos + 1; + exit; + when others => + null; + end case; + end loop; + + if Pos >= Len then + return Val; + end if; + + if C = '#' or C = ':' then + Base := Val; + Val := 0; + Sep := C; + Pos := Pos + 1; + if Base < 2 or Base > 16 then + Error_E ("'value: bad base"); + end if; + if Pos >= Len then + Error_E ("'value: missing based integer"); + end if; + C := S (Pos); + loop + case C is + when '0' .. '9' => + D := Character'Pos (C) - Character'Pos ('0'); + when 'a' .. 'f' => + D := Character'Pos (C) - Character'Pos ('a') + 10; + when 'A' .. 'F' => + D := Character'Pos (C) - Character'Pos ('A') + 10; + when others => + Error_E ("'value: digit expected"); + end case; + if D >= Base then + Error_E ("'value: digit >= base"); + end if; + Val := Val * Base + D; + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: missing end sign number"); + end if; + C := S (Pos); + if C = '#' or C = ':' then + if C /= Sep then + Error_E ("'value: sign number mismatch"); + end if; + Pos := Pos + 1; + exit; + elsif C = '_' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after underscore"); + end if; + C := S (Pos); + end if; + end loop; + else + Base := 10; + end if; + + -- Handle exponent. + if C = 'e' or C = 'E' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after exponent"); + end if; + C := S (Pos); + if C = '+' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after sign"); + end if; + C := S (Pos); + elsif C = '-' then + Error_E ("'value: negativ exponent not allowed"); + end if; + Exp := 0; + loop + if C in '0' .. '9' then + Exp := Exp * 10 + Character'Pos (C) - Character'Pos ('0'); + Pos := Pos + 1; + exit when Pos >= Len; + C := S (Pos); + else + Error_E ("'value: decimal digit expected"); + end if; + case C is + when '_' => + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: trailing underscore"); + end if; + C := S (Pos); + when ' ' + | NBSP + | HT => + Pos := Pos + 1; + exit; + when others => + null; + end case; + end loop; + while Exp > 0 loop + if Exp mod 2 = 1 then + Val := Val * Base; + end if; + Exp := Exp / 2; + Base := Base * Base; + end loop; + end if; + + if Pos /= Len then + Error_E ("'value: trailing characters after blank"); + end if; + + return Val; + end Ghdl_Value_I64; + + function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64 + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + begin + -- LRM 14.1 + -- Leading [and trailing] whitespace is allowed and ignored. + -- + -- GHDL: allow several leading whitespace. + Remove_Whitespaces (S, Len, Pos); + + return Ghdl_Value_I64 (S, Len, Pos); + end Ghdl_Value_I64; + + function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32 + is + begin + return Ghdl_I32 (Ghdl_Value_I64 (Str)); + end Ghdl_Value_I32; + + -- From patch attached to https://gna.org/bugs/index.php?18352 + -- thanks to Christophe Curis https://gna.org/users/lobotomy + function Ghdl_Value_F64 (S : Std_String_Basep; + Len : Ghdl_Index_Type; + Init_Pos : Ghdl_Index_Type) + return Ghdl_F64 + is + Pos : Ghdl_Index_Type := Init_Pos; + C : Character; + Is_Negative, Is_Neg_Exp : Boolean := False; + Base : Ghdl_F64; + Intg : Ghdl_I32; + Val, Df : Ghdl_F64; + Sep : Character; + FrcExp : Ghdl_F64; + begin + C := S (Pos); + if C = '-' then + Is_Negative := True; + Pos := Pos + 1; + elsif C = '+' then + Pos := Pos + 1; + end if; + + if Pos >= Len then + Error_E ("'value: decimal digit expected"); + end if; + + -- Read Integer-or-Base part (may be optional) + Intg := 0; + while Pos < Len loop + C := S (Pos); + if C in '0' .. '9' then + Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0'); + elsif C /= '_' then + exit; + end if; + Pos := Pos + 1; + end loop; + + if Pos = Len then + return Ghdl_F64 (Intg); + end if; + + -- Special case: base was specified + if C = '#' or C = ':' then + if Intg < 2 or Intg > 16 then + Error_E ("'value: bad base"); + end if; + Base := Ghdl_F64 (Intg); + Val := 0.0; + Sep := C; + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: missing based decimal"); + end if; + + -- Get the Integer part of the Value + while Pos < Len loop + C := S (Pos); + case C is + when '0' .. '9' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0') ); + when 'A' .. 'F' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10); + when 'a' .. 'f' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10); + when others => + exit; + end case; + if C /= '_' then + if Df >= Base then + Error_E ("'value: digit greater than base"); + end if; + Val := Val * Base + Df; + end if; + Pos := Pos + 1; + end loop; + if Pos >= Len then + Error_E ("'value: missing end sign number"); + end if; + else + Base := 10.0; + Sep := ' '; + Val := Ghdl_F64 (Intg); + end if; + + -- Handle the Fractional part + if C = '.' then + Pos := Pos + 1; + FrcExp := 1.0; + while Pos < Len loop + C := S (Pos); + case C is + when '0' .. '9' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0')); + when 'A' .. 'F' => + exit when Sep = ' '; + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10); + when 'a' .. 'f' => + exit when Sep = ' '; + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10); + when others => + exit; + end case; + if C /= '_' then + FrcExp := FrcExp / Base; + if Df > Base then + Error_E ("'value: digit greater than base"); + end if; + Val := Val + Df * FrcExp; + end if; + Pos := Pos + 1; + end loop; + end if; + + -- If base was specified, we must find here the end marker + if Sep /= ' ' then + if Pos >= Len then + Error_E ("'value: missing end sign number"); + end if; + if C /= Sep then + Error_E ("'value: sign number mismatch"); + end if; + Pos := Pos + 1; + end if; + + -- Handle exponent + if Pos < Len then + C := S (Pos); + if C = 'e' or C = 'E' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after exponent"); + end if; + C := S (Pos); + if C = '-' then + Is_Neg_Exp := True; + Pos := Pos + 1; + elsif C = '+' then + Pos := Pos + 1; + end if; + Intg := 0; + while Pos < Len loop + C := S (Pos); + if C in '0' .. '9' then + Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0'); + else + exit; + end if; + Pos := Pos + 1; + end loop; + -- This Exponentiation method is sub-optimal, + -- but it does not depend on any library + FrcExp := 1.0; + if Is_Neg_Exp then + while Intg > 0 loop + FrcExp := FrcExp / 10.0; + Intg := Intg - 1; + end loop; + else + while Intg > 0 loop + FrcExp := FrcExp * 10.0; + Intg := Intg - 1; + end loop; + end if; + Val := Val * FrcExp; + end if; + end if; + + if Pos /= Len then + Error_E ("'value: trailing characters after blank"); + end if; + + if Is_Negative then + Val := -Val; + end if; + + return Val; + end Ghdl_Value_F64; + + -- From patch attached to https://gna.org/bugs/index.php?18352 + -- thanks to Christophe Curis https://gna.org/users/lobotomy + function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64 + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + begin + -- LRM 14.1 + -- Leading and trailing whitespace is allowed and ignored. + -- + -- GHDL: allow several leading whitespace. + Remove_Whitespaces (S, Len, Pos); + + return Ghdl_Value_F64 (S, Len, Pos); + end Ghdl_Value_F64; + + procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr; + Is_Real : out Boolean; + Lit_Pos : out Ghdl_Index_Type; + Lit_End : out Ghdl_Index_Type; + Unit_Pos : out Ghdl_Index_Type) + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + begin + -- LRM 14.1 + -- Leading and trailing whitespace is allowed and ignored. + Lit_Pos := 0; + Remove_Whitespaces (S, Len, Lit_Pos); + + -- Split between abstract literal (optionnal) and unit name. + Lit_End := Lit_Pos; + Is_Real := False; + while Lit_End < Len loop + exit when Is_Whitespace (S (Lit_End)); + if S (Lit_End) = '.' then + Is_Real := True; + end if; + Lit_End := Lit_End + 1; + end loop; + if Lit_End = Len then + -- No literal + Unit_Pos := Lit_Pos; + Lit_End := 0; + else + Unit_Pos := Lit_End + 1; + while Unit_Pos < Len loop + exit when not Is_Whitespace (S (Unit_Pos)); + Unit_Pos := Unit_Pos + 1; + end loop; + end if; + end Ghdl_Value_Physical_Split; + + function Ghdl_Value_Physical_Type (Str : Std_String_Ptr; + Rti : Ghdl_Rti_Access) + return Ghdl_I64 + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Unit_Pos : Ghdl_Index_Type; + Lit_Pos : Ghdl_Index_Type; + Lit_End : Ghdl_Index_Type; + + Found_Real : Boolean; + + Phys_Rti : constant Ghdl_Rtin_Type_Physical_Acc := + To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Multiple : Ghdl_Rti_Access; + Mult : Ghdl_I64; + begin + -- Remove trailing whitespaces. FIXME: also called in physical_split. + Lit_Pos := 0; + Remove_Whitespaces (S, Len, Lit_Pos); + + -- Extract literal and unit + Ghdl_Value_Physical_Split (Str, Found_Real, Lit_Pos, Lit_End, Unit_Pos); + + -- Find unit value + Multiple := null; + for i in 0 .. Phys_Rti.Nbr - 1 loop + Unit_Name := + Rtis_Utils.Get_Physical_Unit_Name (Phys_Rti.Units (i)); + if String_Match (S, Unit_Pos, Len, Unit_Name) then + Multiple := Phys_Rti.Units (i); + exit; + end if; + end loop; + if Multiple = null then + Error_C ("'value: unit '"); + Error_C_Std (S (Unit_Pos .. Len - 1)); + Error_C ("' not in physical type '"); + Error_C (Phys_Rti.Name); + Error_E ("'"); + end if; + + Mult := Grt.Rtis_Utils.Get_Physical_Unit_Value (Multiple, Rti); + + if Lit_End = 0 then + return Mult; + else + if Found_Real then + return Ghdl_I64 + (Ghdl_Value_F64 (S, Lit_End, Lit_Pos) * Ghdl_F64 (Mult)); + else + return Ghdl_Value_I64 (S, Lit_End, Lit_Pos) * Mult; + end if; + end if; + end Ghdl_Value_Physical_Type; + + function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I64 + is + begin + if Rti.Kind /= Ghdl_Rtik_Type_P64 then + Error_E ("Physical_Type_64'value: incorrect RTI"); + end if; + return Ghdl_Value_Physical_Type (Str, Rti); + end Ghdl_Value_P64; + + function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I32 + is + begin + if Rti.Kind /= Ghdl_Rtik_Type_P32 then + Error_E ("Physical_Type_32'value: incorrect RTI"); + end if; + return Ghdl_I32 (Ghdl_Value_Physical_Type (Str, Rti)); + end Ghdl_Value_P32; + +end Grt.Values; diff --git a/src/translate/grt/grt-values.ads b/src/translate/grt/grt-values.ads new file mode 100644 index 0000000..8df8c3f --- /dev/null +++ b/src/translate/grt/grt-values.ads @@ -0,0 +1,69 @@ +-- GHDL Run Time (GRT) - 'value subprograms. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Values is + -- Return True IFF C is a whitespace character (as defined in LRM93 14.3) + function Is_Whitespace (C : in Character) return Boolean; + + -- Convert C to lowercase. + function To_LC (C : in Character) return Character; + + -- Extract position of numeric literal and unit in string STR. + -- Set IS_REAL if the unit is a real number (presence of '.'). + -- Set UNIT_POS to the position of the first character of the unit name. + -- Set LIT_POS to the position of the first character of the numeric + -- literal (after whitespaces are skipped). + -- Set LIT_END to the position of the next character of the numeric lit. + procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr; + Is_Real : out Boolean; + Lit_Pos : out Ghdl_Index_Type; + Lit_End : out Ghdl_Index_Type; + Unit_Pos : out Ghdl_Index_Type); + + function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_B1; + function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E8; + function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E32; + function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32; + function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64; + function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64; + function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I64; + function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I32; +private + pragma Export (Ada, Ghdl_Value_B1, "__ghdl_value_b1"); + pragma Export (C, Ghdl_Value_E8, "__ghdl_value_e8"); + pragma Export (C, Ghdl_Value_E32, "__ghdl_value_e32"); + pragma Export (C, Ghdl_Value_I32, "__ghdl_value_i32"); + pragma Export (C, Ghdl_Value_I64, "__ghdl_value_i64"); + pragma Export (C, Ghdl_Value_F64, "__ghdl_value_f64"); + pragma Export (C, Ghdl_Value_P64, "__ghdl_value_p64"); + pragma Export (C, Ghdl_Value_P32, "__ghdl_value_p32"); +end Grt.Values; diff --git a/src/translate/grt/grt-vcd.adb b/src/translate/grt/grt-vcd.adb new file mode 100644 index 0000000..d4a9ea0 --- /dev/null +++ b/src/translate/grt/grt-vcd.adb @@ -0,0 +1,845 @@ +-- GHDL Run Time (GRT) - VCD generator. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Interfaces; +with Grt.Stdio; use Grt.Stdio; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Errors; use Grt.Errors; +with Grt.Signals; use Grt.Signals; +with Grt.Table; +with Grt.Astdio; use Grt.Astdio; +with Grt.C; use Grt.C; +with Grt.Hooks; use Grt.Hooks; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Types; use Grt.Rtis_Types; +with Grt.Vstrings; +pragma Elaborate_All (Grt.Table); + +package body Grt.Vcd is + -- If TRUE, put $date in vcd file. + -- Can be set to FALSE to make vcd comparaison easier. + Flag_Vcd_Date : Boolean := True; + + Stream : FILEs; + + procedure My_Vcd_Put (Str : String) + is + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (Str'Address, Str'Length, 1, Stream); + end My_Vcd_Put; + + procedure My_Vcd_Putc (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), Stream); + end My_Vcd_Putc; + + procedure My_Vcd_Close is + begin + fclose (Stream); + Stream := NULL_Stream; + end My_Vcd_Close; + + -- VCD filename. + -- Stream corresponding to the VCD filename. + --Vcd_Stream : FILEs; + + -- Index type of the table of vcd variables to dump. + type Vcd_Index_Type is new Integer; + + -- Return TRUE if OPT is an option for VCD. + function Vcd_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + Mode : constant String := "wt" & NUL; + Vcd_Filename : String_Access; + begin + if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vcd" then + return False; + end if; + if Opt'Length = 12 and then Opt (F + 5 .. F + 11) = "-nodate" then + Flag_Vcd_Date := False; + return True; + end if; + if Opt'Length > 6 and then Opt (F + 5) = '=' then + if Vcd_Close /= null then + Error ("--vcd: file already set"); + return True; + end if; + + -- Add an extra NUL character. + Vcd_Filename := new String (1 .. Opt'Length - 6 + 1); + Vcd_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last); + Vcd_Filename (Vcd_Filename'Last) := NUL; + + if Vcd_Filename.all = "-" & NUL then + Stream := stdout; + else + Stream := fopen (Vcd_Filename.all'Address, Mode'Address); + if Stream = NULL_Stream then + Error_C ("cannot open "); + Error_E (Vcd_Filename (Vcd_Filename'First + .. Vcd_Filename'Last - 1)); + return True; + end if; + end if; + Vcd_Putc := My_Vcd_Putc'Access; + Vcd_Put := My_Vcd_Put'Access; + Vcd_Close := My_Vcd_Close'Access; + return True; + else + return False; + end if; + end Vcd_Option; + + procedure Vcd_Help is + begin + Put_Line (" --vcd=FILENAME dump signal values into a VCD file"); + Put_Line (" --vcd-nodate do not write date in VCD file"); + end Vcd_Help; + + procedure Vcd_Newline is + begin + Vcd_Putc (Nl); + end Vcd_Newline; + + procedure Vcd_Putline (Str : String) is + begin + Vcd_Put (Str); + Vcd_Newline; + end Vcd_Putline; + +-- procedure Vcd_Put (Str : Ghdl_Str_Len_Type) +-- is +-- begin +-- Put_Str_Len (Vcd_Stream, Str); +-- end Vcd_Put; + + procedure Vcd_Put_I32 (V : Ghdl_I32) + is + Str : String (1 .. 11); + First : Natural; + begin + Vstrings.To_String (Str, First, V); + Vcd_Put (Str (First .. Str'Last)); + end Vcd_Put_I32; + + procedure Vcd_Put_Idcode (N : Vcd_Index_Type) + is + Str : String (1 .. 8); + V, R : Vcd_Index_Type; + L : Natural; + begin + L := 0; + V := N; + loop + R := V mod 93; + V := V / 93; + L := L + 1; + Str (L) := Character'Val (33 + R); + exit when V = 0; + end loop; + Vcd_Put (Str (1 .. L)); + end Vcd_Put_Idcode; + + procedure Vcd_Put_Name (Obj : VhpiHandleT) + is + Name : String (1 .. 128); + Name_Len : Integer; + begin + Vhpi_Get_Str (VhpiNameP, Obj, Name, Name_Len); + if Name_Len <= Name'Last then + Vcd_Put (Name (1 .. Name_Len)); + else + -- Truncate. + Vcd_Put (Name); + end if; + end Vcd_Put_Name; + + procedure Vcd_Put_End is + begin + Vcd_Putline ("$end"); + end Vcd_Put_End; + + -- Called before elaboration. + procedure Vcd_Init + is + begin + if Vcd_Close = null then + return; + end if; + if Flag_Vcd_Date then + Vcd_Putline ("$date"); + Vcd_Put (" "); + declare + type time_t is new Interfaces.Integer_64; + Cur_Time : time_t; + + function time (Addr : Address) return time_t; + pragma Import (C, time); + + function ctime (Timep: Address) return Ghdl_C_String; + pragma Import (C, ctime); + + Ct : Ghdl_C_String; + begin + Cur_Time := time (Null_Address); + Ct := ctime (Cur_Time'Address); + for I in Positive loop + exit when Ct (I) = NUL; + Vcd_Putc (Ct (I)); + end loop; + -- Note: ctime already append a LF. + end; + Vcd_Put_End; + end if; + Vcd_Putline ("$version"); + Vcd_Putline (" GHDL v0"); + Vcd_Put_End; + Vcd_Putline ("$timescale"); + Vcd_Putline (" 1 fs"); + Vcd_Put_End; + end Vcd_Init; + + package Vcd_Table is new Grt.Table + (Table_Component_Type => Verilog_Wire_Info, + Table_Index_Type => Vcd_Index_Type, + Table_Low_Bound => 0, + Table_Initial => 32); + + procedure Avhpi_Error (Err : AvhpiErrorT) + is + pragma Unreferenced (Err); + begin + Put_Line ("Vcd.Avhpi_Error!"); + null; + end Avhpi_Error; + + function Rti_To_Vcd_Kind (Rti : Ghdl_Rti_Access) return Vcd_Var_Kind + is + Rti1 : Ghdl_Rti_Access; + begin + if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then + Rti1 := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype; + else + Rti1 := Rti; + end if; + + if Rti1 = Std_Standard_Boolean_RTI_Ptr then + return Vcd_Bool; + end if; + if Rti1 = Std_Standard_Bit_RTI_Ptr then + return Vcd_Bit; + end if; + if Rti1 = Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr then + return Vcd_Stdlogic; + end if; + if Rti1.Kind = Ghdl_Rtik_Type_I32 then + return Vcd_Integer32; + end if; + if Rti1.Kind = Ghdl_Rtik_Type_F64 then + return Vcd_Float64; + end if; + return Vcd_Bad; + end Rti_To_Vcd_Kind; + + function Rti_To_Vcd_Kind (Rti : Ghdl_Rtin_Type_Array_Acc) + return Vcd_Var_Kind + is + It : Ghdl_Rti_Access; + begin + if Rti.Nbr_Dim /= 1 then + return Vcd_Bad; + end if; + It := Rti.Indexes (0); + if It.Kind /= Ghdl_Rtik_Subtype_Scalar then + return Vcd_Bad; + end if; + if To_Ghdl_Rtin_Subtype_Scalar_Acc (It).Basetype.Kind + /= Ghdl_Rtik_Type_I32 + then + return Vcd_Bad; + end if; + case Rti_To_Vcd_Kind (Rti.Element) is + when Vcd_Bit => + return Vcd_Bitvector; + when Vcd_Stdlogic => + return Vcd_Stdlogic_Vector; + when others => + return Vcd_Bad; + end case; + end Rti_To_Vcd_Kind; + + procedure Get_Verilog_Wire (Sig : VhpiHandleT; Info : out Verilog_Wire_Info) + is + Sig_Type : VhpiHandleT; + Rti : Ghdl_Rti_Access; + Error : AvhpiErrorT; + Sig_Addr : Address; + begin + -- Extract type of the signal. + Vhpi_Handle (VhpiSubtype, Sig, Sig_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Rti := Avhpi_Get_Rti (Sig_Type); + Sig_Addr := Avhpi_Get_Address (Sig); + Info.Kind := Vcd_Bad; + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Subtype_Scalar => + Info.Kind := Rti_To_Vcd_Kind (Rti); + Info.Addr := Sig_Addr; + Info.Irange := null; + when Ghdl_Rtik_Subtype_Array => + declare + St : Ghdl_Rtin_Subtype_Array_Acc; + begin + St := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Info.Kind := Rti_To_Vcd_Kind (St.Basetype); + Info.Addr := Sig_Addr; + Info.Irange := To_Ghdl_Range_Ptr + (Loc_To_Addr (St.Common.Depth, St.Bounds, + Avhpi_Get_Context (Sig))); + end; + when Ghdl_Rtik_Type_Array => + declare + Uc : Ghdl_Uc_Array_Acc; + begin + Info.Kind := Rti_To_Vcd_Kind + (To_Ghdl_Rtin_Type_Array_Acc (Rti)); + Uc := To_Ghdl_Uc_Array_Acc (Sig_Addr); + Info.Addr := Uc.Base; + Info.Irange := To_Ghdl_Range_Ptr (Uc.Bounds); + end; + when others => + Info.Irange := null; + end case; + + -- Do not allow null-array. + if Info.Irange /= null and then Info.Irange.I32.Len = 0 then + Info.Kind := Vcd_Bad; + Info.Irange := null; + return; + end if; + + if Vhpi_Get_Kind (Sig) = VhpiPortDeclK then + case Vhpi_Get_Mode (Sig) is + when VhpiInMode + | VhpiInoutMode + | VhpiBufferMode + | VhpiLinkageMode => + Info.Val := Vcd_Effective; + when VhpiOutMode => + Info.Val := Vcd_Driving; + when VhpiErrorMode => + Info.Kind := Vcd_Bad; + end case; + else + Info.Val := Vcd_Effective; + end if; + end Get_Verilog_Wire; + + procedure Add_Signal (Sig : VhpiHandleT) + is + N : Vcd_Index_Type; + Vcd_El : Verilog_Wire_Info; + begin + Get_Verilog_Wire (Sig, Vcd_El); + + if Vcd_El.Kind = Vcd_Bad then + Vcd_Put ("$comment "); + Vcd_Put_Name (Sig); + Vcd_Put (" is not handled"); + --Vcd_Put (Ghdl_Type_Kind'Image (Desc.Kind)); + Vcd_Putc (' '); + Vcd_Put_End; + return; + else + Vcd_Table.Increment_Last; + N := Vcd_Table.Last; + + Vcd_Table.Table (N) := Vcd_El; + Vcd_Put ("$var "); + case Vcd_El.Kind is + when Vcd_Integer32 => + Vcd_Put ("integer 32"); + when Vcd_Float64 => + Vcd_Put ("real 64"); + when Vcd_Bool + | Vcd_Bit + | Vcd_Stdlogic => + Vcd_Put ("reg 1"); + when Vcd_Bitvector + | Vcd_Stdlogic_Vector => + Vcd_Put ("reg "); + Vcd_Put_I32 (Ghdl_I32 (Vcd_El.Irange.I32.Len)); + when Vcd_Bad => + null; + end case; + Vcd_Putc (' '); + Vcd_Put_Idcode (N); + Vcd_Putc (' '); + Vcd_Put_Name (Sig); + if Vcd_El.Irange /= null then + Vcd_Putc ('['); + Vcd_Put_I32 (Vcd_El.Irange.I32.Left); + Vcd_Putc (':'); + Vcd_Put_I32 (Vcd_El.Irange.I32.Right); + Vcd_Putc (']'); + end if; + Vcd_Putc (' '); + Vcd_Put_End; + if Boolean'(False) then + Vcd_Put ("$comment "); + Vcd_Put_Name (Sig); + Vcd_Put (" is "); + case Vcd_El.Val is + when Vcd_Effective => + Vcd_Put ("effective "); + when Vcd_Driving => + Vcd_Put ("driving "); + end case; + Vcd_Put_End; + end if; + end if; + end Add_Signal; + + procedure Vcd_Put_Hierarchy (Inst : VhpiHandleT) + is + Decl_It : VhpiHandleT; + Decl : VhpiHandleT; + Error : AvhpiErrorT; + begin + Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + -- Extract signals. + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK + | VhpiSigDeclK => + Add_Signal (Decl); + when others => + null; + end case; + end loop; + + -- Extract sub-scopes. + Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + case Vhpi_Get_Kind (Decl) is + when VhpiIfGenerateK + | VhpiForGenerateK + | VhpiBlockStmtK + | VhpiCompInstStmtK => + Vcd_Put ("$scope module "); + Vcd_Put_Name (Decl); + Vcd_Putc (' '); + Vcd_Put_End; + Vcd_Put_Hierarchy (Decl); + Vcd_Put ("$upscope "); + Vcd_Put_End; + when others => + null; + end case; + end loop; + + end Vcd_Put_Hierarchy; + + procedure Vcd_Put_Bit (V : Ghdl_B1) + is + C : Character; + begin + if V then + C := '1'; + else + C := '0'; + end if; + Vcd_Putc (C); + end Vcd_Put_Bit; + + procedure Vcd_Put_Stdlogic (V : Ghdl_E8) + is + type Map_Type is array (Ghdl_E8 range 0 .. 8) of Character; + -- "UX01ZWLH-" + -- Map_Vlg : constant Map_Type := "xx01zz01x"; + Map_Std : constant Map_Type := "UX01ZWLH-"; + begin + if V not in Map_Type'Range then + Vcd_Putc ('?'); + else + Vcd_Putc (Map_Std (V)); + end if; + end Vcd_Put_Stdlogic; + + procedure Vcd_Put_Integer32 (V : Ghdl_U32) + is + Val : Ghdl_U32; + N : Natural; + begin + Val := V; + N := 32; + while N > 1 loop + exit when (Val and 16#8000_0000#) /= 0; + Val := Val * 2; + N := N - 1; + end loop; + + while N > 0 loop + if (Val and 16#8000_0000#) /= 0 then + Vcd_Putc ('1'); + else + Vcd_Putc ('0'); + end if; + Val := Val * 2; + N := N - 1; + end loop; + end Vcd_Put_Integer32; + + -- Using the floor attribute of Ghdl_F64 will result on a link error while + -- trying to simulate a design. So it was needed to create a floor function + function Digit_Floor (V : Ghdl_F64) return Ghdl_I32 + is + Var : Ghdl_I32; + begin + -- V is always positive here and only of interest when it is a digit + if V > 10.0 then + return -1; + else + Var := Ghdl_I32(V-0.5); --Ghdl_I32 rounds to the nearest integer + -- The rounding made by Ghdl_I32 is asymetric : + -- 0.5 will be rounded to 1, but -0.5 to -1 instead of 0 + if Var > 0 then + return Var; + else + return 0; + end if; + end if; + end Digit_Floor; + + procedure Vcd_Put_Float64 (V : Ghdl_F64) + is + Val_tmp, Fact : Ghdl_F64; + Digit, Exp, Delta_Exp, N_Exp : Ghdl_I32; + -- + begin + Exp := 0; + if V /= V then + Vcd_Put("NaN"); + return; + end if; + if V < 0.0 then + Vcd_Putc ('-'); + Val_tmp := -V; + elsif V = 0.0 then + Vcd_Put("0.0"); + return; + else + Val_tmp := V; + end if; + if Val_tmp > Ghdl_F64'Last then + Vcd_Put("Inf"); + return; + elsif Val_tmp < 1.0 then + Fact := 10.0; + Delta_Exp := -1; + else + Fact := 0.1; + Delta_Exp := 1; + end if; + + -- Seek the first digit + loop + Digit := Digit_Floor(Val_tmp); + if Digit > 0 then + exit; + end if; + Exp := Exp + Delta_Exp; + Val_tmp := Val_tmp * Fact; + end loop; + Vcd_Putc(Character'Val(Digit + 48)); + Vcd_Putc('.'); + for i in 0..4 loop -- 5 digits displayed after the point + Val_tmp := abs(Val_tmp - Ghdl_F64(Digit))*10.0; + Digit := Digit_Floor(Val_tmp); + Vcd_Putc(Character'Val(Digit + 48)); + end loop; + Vcd_Putc('E'); + if Exp < 0 then + Vcd_Putc('-'); + Exp := -Exp; + end if; + N_Exp := 100; + while N_Exp > 0 loop + Vcd_Putc(Character'Val(Exp/N_Exp + 48)); + Exp := Exp mod N_Exp; + N_Exp := N_Exp/10; + end loop; + end Vcd_Put_Float64; + + procedure Vcd_Put_Var (I : Vcd_Index_Type) + is + Addr : Address; + V : Verilog_Wire_Info renames Vcd_Table.Table (I); + Len : Ghdl_Index_Type; + begin + Addr := V.Addr; + if V.Irange = null then + Len := 1; + else + Len := V.Irange.I32.Len; + end if; + case V.Val is + when Vcd_Effective => + case V.Kind is + when Vcd_Bit + | Vcd_Bool => + Vcd_Put_Bit (To_Signal_Arr_Ptr (Addr)(0).Value.B1); + when Vcd_Stdlogic => + Vcd_Put_Stdlogic (To_Signal_Arr_Ptr (Addr)(0).Value.E8); + when Vcd_Integer32 => + Vcd_Putc ('b'); + Vcd_Put_Integer32 (To_Signal_Arr_Ptr (Addr)(0).Value.E32); + Vcd_Putc (' '); + when Vcd_Float64 => + Vcd_Putc ('r'); + Vcd_Put_Float64 (To_Signal_Arr_Ptr (Addr)(0).Value.F64); + Vcd_Putc (' '); + when Vcd_Bitvector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Bit (To_Signal_Arr_Ptr (Addr)(J).Value.B1); + end loop; + Vcd_Putc (' '); + when Vcd_Stdlogic_Vector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Stdlogic (To_Signal_Arr_Ptr (Addr)(J).Value.E8); + end loop; + Vcd_Putc (' '); + when Vcd_Bad => + null; + end case; + when Vcd_Driving => + case V.Kind is + when Vcd_Bit + | Vcd_Bool => + Vcd_Put_Bit + (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.B1); + when Vcd_Stdlogic => + Vcd_Put_Stdlogic + (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.E8); + when Vcd_Integer32 => + Vcd_Putc ('b'); + Vcd_Put_Integer32 + (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.E32); + Vcd_Putc (' '); + when Vcd_Float64 => + Vcd_Putc ('r'); + Vcd_Put_Float64 (To_Signal_Arr_Ptr (Addr)(0) + .Driving_Value.F64); + Vcd_Putc (' '); + when Vcd_Bitvector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Bit + (To_Signal_Arr_Ptr (Addr)(J).Driving_Value.B1); + end loop; + Vcd_Putc (' '); + when Vcd_Stdlogic_Vector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Stdlogic + (To_Signal_Arr_Ptr (Addr)(J).Driving_Value.E8); + end loop; + Vcd_Putc (' '); + when Vcd_Bad => + null; + end case; + end case; + Vcd_Put_Idcode (I); + Vcd_Newline; + end Vcd_Put_Var; + + function Verilog_Wire_Changed (Info : Verilog_Wire_Info; + Last : Std_Time) + return Boolean + is + Len : Ghdl_Index_Type; + begin + if Info.Irange = null then + Len := 1; + else + Len := Info.Irange.I32.Len; + end if; + + case Info.Val is + when Vcd_Effective => + case Info.Kind is + when Vcd_Bit + | Vcd_Bool + | Vcd_Stdlogic + | Vcd_Bitvector + | Vcd_Stdlogic_Vector + | Vcd_Integer32 + | Vcd_Float64 => + for J in 0 .. Len - 1 loop + if To_Signal_Arr_Ptr (Info.Addr)(J).Last_Event = Last then + return True; + end if; + end loop; + when Vcd_Bad => + null; + end case; + when Vcd_Driving => + case Info.Kind is + when Vcd_Bit + | Vcd_Bool + | Vcd_Stdlogic + | Vcd_Bitvector + | Vcd_Stdlogic_Vector + | Vcd_Integer32 + | Vcd_Float64 => + for J in 0 .. Len - 1 loop + if To_Signal_Arr_Ptr (Info.Addr)(J).Last_Active = Last + then + return True; + end if; + end loop; + when Vcd_Bad => + null; + end case; + end case; + return False; + end Verilog_Wire_Changed; + + procedure Vcd_Put_Time + is + Str : String (1 .. 21); + First : Natural; + begin + Vcd_Putc ('#'); + Vstrings.To_String (Str, First, Ghdl_I64 (Cycle_Time)); + Vcd_Put (Str (First .. Str'Last)); + Vcd_Newline; + end Vcd_Put_Time; + + procedure Vcd_Cycle; + + -- Called after elaboration. + procedure Vcd_Start + is + Root : VhpiHandleT; + begin + -- Do nothing if there is no VCD file to generate. + if Vcd_Close = null then + return; + end if; + + -- Be sure the RTI of std_ulogic is set. + Search_Types_RTI; + + -- Put hierarchy. + Get_Root_Inst (Root); + Vcd_Put_Hierarchy (Root); + + -- End of header. + Vcd_Put ("$enddefinitions "); + Vcd_Put_End; + + Register_Cycle_Hook (Vcd_Cycle'Access); + end Vcd_Start; + + -- Called before each non delta cycle. + procedure Vcd_Cycle is + begin + -- Disp values. + Vcd_Put_Time; + if Cycle_Time = 0 then + -- Disp all values. + for I in Vcd_Table.First .. Vcd_Table.Last loop + Vcd_Put_Var (I); + end loop; + else + -- Disp only values changed. + for I in Vcd_Table.First .. Vcd_Table.Last loop + if Verilog_Wire_Changed (Vcd_Table.Table (I), Cycle_Time) then + Vcd_Put_Var (I); + end if; + end loop; + end if; + end Vcd_Cycle; + + -- Called at the end of the simulation. + procedure Vcd_End is + begin + if Vcd_Close /= null then + Vcd_Close.all; + end if; + end Vcd_End; + + Vcd_Hooks : aliased constant Hooks_Type := + (Option => Vcd_Option'Access, + Help => Vcd_Help'Access, + Init => Vcd_Init'Access, + Start => Vcd_Start'Access, + Finish => Vcd_End'Access); + + procedure Register is + begin + Register_Hooks (Vcd_Hooks'Access); + end Register; +end Grt.Vcd; diff --git a/src/translate/grt/grt-vcd.ads b/src/translate/grt/grt-vcd.ads new file mode 100644 index 0000000..ed015af --- /dev/null +++ b/src/translate/grt/grt-vcd.ads @@ -0,0 +1,65 @@ +-- GHDL Run Time (GRT) - VCD generator. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Types; use Grt.Types; +with Grt.Avhpi; use Grt.Avhpi; + +package Grt.Vcd is + -- Abstract type for IO. + type Vcd_Put_Acc is access procedure (Str : String); + type Vcd_Putc_Acc is access procedure (C : Character); + type Vcd_Close_Acc is access procedure; + + Vcd_Put : Vcd_Put_Acc; + Vcd_Putc : Vcd_Putc_Acc; + Vcd_Close : Vcd_Close_Acc; + + type Vcd_Var_Kind is (Vcd_Bad, + Vcd_Bool, + Vcd_Integer32, + Vcd_Float64, + Vcd_Bit, Vcd_Stdlogic, + Vcd_Bitvector, Vcd_Stdlogic_Vector); + + -- Which value to be displayed: effective or driving (for out signals). + type Vcd_Value_Kind is (Vcd_Effective, Vcd_Driving); + + type Verilog_Wire_Info is record + Addr : Address; + Irange : Ghdl_Range_Ptr; + Kind : Vcd_Var_Kind; + Val : Vcd_Value_Kind; + end record; + + procedure Get_Verilog_Wire (Sig : VhpiHandleT; + Info : out Verilog_Wire_Info); + + -- Return TRUE if last change time of the wire described by INFO is LAST. + function Verilog_Wire_Changed (Info : Verilog_Wire_Info; + Last : Std_Time) + return Boolean; + + procedure Register; +end Grt.Vcd; diff --git a/src/translate/grt/grt-vcdz.adb b/src/translate/grt/grt-vcdz.adb new file mode 100644 index 0000000..8e1ceb6 --- /dev/null +++ b/src/translate/grt/grt-vcdz.adb @@ -0,0 +1,116 @@ +-- GHDL Run Time (GRT) - VCD .gz module. +-- Copyright (C) 2005 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Vcd; use Grt.Vcd; +with Grt.Errors; use Grt.Errors; +with Grt.Types; use Grt.Types; +with Grt.Astdio; use Grt.Astdio; +with Grt.Hooks; use Grt.Hooks; +with Grt.Zlib; use Grt.Zlib; +with Grt.C; use Grt.C; + +package body Grt.Vcdz is + Stream : gzFile; + + procedure My_Vcd_Put (Str : String) + is + R : int; + pragma Unreferenced (R); + begin + R := gzwrite (Stream, Str'Address, Str'Length); + end My_Vcd_Put; + + procedure My_Vcd_Putc (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := gzputc (Stream, Character'Pos (C)); + end My_Vcd_Putc; + + procedure My_Vcd_Close is + begin + gzclose (Stream); + Stream := NULL_gzFile; + end My_Vcd_Close; + + -- VCD filename. + + -- Return TRUE if OPT is an option for VCD. + function Vcdz_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + Vcd_Filename : String_Access := null; + Mode : constant String := "wb" & NUL; + begin + if Opt'Length < 7 or else Opt (F .. F + 6) /= "--vcdgz" then + return False; + end if; + if Opt'Length > 7 and then Opt (F + 7) = '=' then + if Vcd_Close /= null then + Error ("--vcdgz: file already set"); + return True; + end if; + + -- Add an extra NUL character. + Vcd_Filename := new String (1 .. Opt'Length - 8 + 1); + Vcd_Filename (1 .. Opt'Length - 8) := Opt (F + 8 .. Opt'Last); + Vcd_Filename (Vcd_Filename'Last) := NUL; + + Stream := gzopen (Vcd_Filename.all'Address, Mode'Address); + if Stream = NULL_gzFile then + Error_C ("cannot open "); + Error_E (Vcd_Filename (Vcd_Filename'First + .. Vcd_Filename'Last - 1)); + return True; + end if; + Vcd_Putc := My_Vcd_Putc'Access; + Vcd_Put := My_Vcd_Put'Access; + Vcd_Close := My_Vcd_Close'Access; + return True; + else + return False; + end if; + end Vcdz_Option; + + procedure Vcdz_Help is + begin + Put_Line + (" --vcdgz=FILENAME dump signal values into a VCD gzip'ed file"); + end Vcdz_Help; + + Vcdz_Hooks : aliased constant Hooks_Type := + (Option => Vcdz_Option'Access, + Help => Vcdz_Help'Access, + Init => Proc_Hook_Nil'Access, + Start => Proc_Hook_Nil'Access, + Finish => Proc_Hook_Nil'Access); + + procedure Register is + begin + Register_Hooks (Vcdz_Hooks'Access); + end Register; +end Grt.Vcdz; diff --git a/src/translate/grt/grt-vcdz.ads b/src/translate/grt/grt-vcdz.ads new file mode 100644 index 0000000..aba61c2 --- /dev/null +++ b/src/translate/grt/grt-vcdz.ads @@ -0,0 +1,28 @@ +-- GHDL Run Time (GRT) - VCD .gz module. +-- Copyright (C) 2005 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package Grt.Vcdz is + procedure Register; +end Grt.Vcdz; diff --git a/src/translate/grt/grt-vital_annotate.adb b/src/translate/grt/grt-vital_annotate.adb new file mode 100644 index 0000000..93ecb81 --- /dev/null +++ b/src/translate/grt/grt-vital_annotate.adb @@ -0,0 +1,688 @@ +-- GHDL Run Time (GRT) - VITAL annotator. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Hooks; use Grt.Hooks; +with Grt.Astdio; use Grt.Astdio; +with Grt.Stdio; use Grt.Stdio; +with Grt.Options; +with Grt.Avhpi; use Grt.Avhpi; +with Grt.Errors; use Grt.Errors; + +package body Grt.Vital_Annotate is + -- Point of the annotation. + Sdf_Top : VhpiHandleT; + + -- Instance being annotated. + Sdf_Inst : VhpiHandleT; + + Flag_Dump : Boolean := False; + Flag_Verbose : constant Boolean := False; + + function Name_Compare (Handle : VhpiHandleT; + Name : String; + Property : VhpiStrPropertyT := VhpiNameP) + return Boolean + is + Obj_Name : String (1 .. Name'Length); + Len : Natural; + begin + Vhpi_Get_Str (Property, Handle, Obj_Name, Len); + if Len = Name'Length and then Obj_Name = Name then + return True; + else + return False; + end if; + end Name_Compare; + + -- Note: RES may alias CUR. + procedure Find_Instance (Cur : VhpiHandleT; + Res : out VhpiHandleT; + Name : String; + Ok : out Boolean) + is + Error : AvhpiErrorT; + It : VhpiHandleT; + begin + Ok := False; + Vhpi_Iterator (VhpiInternalRegions, Cur, It, Error); + if Error /= AvhpiErrorOk then + return; + end if; + loop + Vhpi_Scan (It, Res, Error); + exit when Error /= AvhpiErrorOk; + if Name_Compare (Res, Name) then + Ok := True; + return; + end if; + end loop; + return; +-- Put ("find instance: "); +-- Put (Name); +-- New_Line; + end Find_Instance; + + procedure Find_Generic (Gen_Name : String; + Gen_Handle : out VhpiHandleT; + Port1_Name : String; + Port1_Handle : out VhpiHandleT; + Port2_Name : String; + Port2_Handle : out VhpiHandleT) + is + Error : AvhpiErrorT; + It : VhpiHandleT; + Decl : VhpiHandleT; + begin + Gen_Handle := Null_Handle; + Port1_Handle := Null_Handle; + Port2_Handle := Null_Handle; + + Vhpi_Iterator (VhpiDecls, Sdf_Inst, It, Error); + if Error /= AvhpiErrorOk then + return; + end if; + + -- Look for the generic. + loop + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then + return; + end if; + exit when Vhpi_Get_Kind (Decl) /= VhpiGenericDeclK; + if Name_Compare (Decl, Gen_Name) then + Gen_Handle := Decl; + exit; + end if; + end loop; + + -- Skip generics. + while Vhpi_Get_Kind (Decl) = VhpiGenericDeclK loop + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then + return; + end if; + end loop; + + -- Look for ports. + loop + exit when Vhpi_Get_Kind (Decl) /= VhpiPortDeclK; + if Name_Compare (Decl, Port1_Name) then + Port1_Handle := Decl; + exit when Port2_Name'Length = 0; + end if; + if Port2_Name'Length > 0 + and then Name_Compare (Decl, Port2_Name) + then + Port2_Handle := Decl; + exit when Vhpi_Get_Kind (Port1_Handle) /= VhpiUndefined; + end if; + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then + return; + end if; + end loop; + + end Find_Generic; + + procedure Sdf_Header (Context : Sdf_Context_Type) + is + begin + if Flag_Dump then + case Context.Version is + when Sdf_2_1 => + Put ("found SDF file version 2.1"); + when Sdf_Version_Unknown => + Put ("found SDF file without version"); + when Sdf_Version_Bad => + Put ("found SDF file with unknown version"); + end case; + New_Line; + end if; + end Sdf_Header; + + procedure Sdf_Celltype (Context : Sdf_Context_Type) + is + begin + if Flag_Dump then + Put ("celltype: "); + Put (Context.Celltype (1 .. Context.Celltype_Len)); + New_Line; + Put ("instance:"); + return; + end if; + Sdf_Inst := Sdf_Top; + end Sdf_Celltype; + + procedure Sdf_Instance (Context : in out Sdf_Context_Type; + Instance : String; + Status : out Boolean) + is + pragma Unreferenced (Context); + begin + if Flag_Dump then + Put (' '); + Put (Instance); + Status := True; + return; + end if; + + Find_Instance (Sdf_Inst, Sdf_Inst, Instance, Status); + end Sdf_Instance; + + procedure Sdf_Instance_End (Context : Sdf_Context_Type; + Status : out Boolean) + is + begin + if Flag_Dump then + Status := True; + New_Line; + return; + end if; + case Vhpi_Get_Kind (Sdf_Inst) is + when VhpiRootInstK => + declare + Hdl : VhpiHandleT; + Error : AvhpiErrorT; + begin + Status := False; + Vhpi_Handle (VhpiDesignUnit, Sdf_Inst, Hdl, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("VhpiDesignUnit"); + return; + end if; + case Vhpi_Get_Kind (Hdl) is + when VhpiArchBodyK => + Vhpi_Handle (VhpiPrimaryUnit, Hdl, Hdl, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("VhpiPrimaryUnit"); + return; + end if; + when others => + Internal_Error ("sdf_instance_end"); + end case; + Status := Name_Compare + (Hdl, Context.Celltype (1 .. Context.Celltype_Len)); + end; + when VhpiCompInstStmtK => + Status := Name_Compare + (Sdf_Inst, + Context.Celltype (1 .. Context.Celltype_Len), + VhpiCompNameP); + when others => + Status := False; + end case; + end Sdf_Instance_End; + + VitalDelayType01 : VhpiHandleT; + VitalDelayType01Z : VhpiHandleT; + VitalDelayType01ZX : VhpiHandleT; + VitalDelayArrayType01 : VhpiHandleT; + VitalDelayType : VhpiHandleT; + VitalDelayArrayType : VhpiHandleT; + + 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_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; + Gen : VhpiHandleT; + Nbr : Natural; + Map : Map_Type) + return Boolean + is + It : VhpiHandleT; + El : VhpiHandleT; + Error : AvhpiErrorT; + N : Natural; + begin + Vhpi_Iterator (VhpiIndexedNames, Gen, It, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIndexedNames"); + return False; + end if; + for I in 1 .. Nbr loop + Vhpi_Scan (It, El, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("scan on vhpiIndexedNames"); + return False; + end if; + N := Map (I); + if Context.Timing_Set (N) then + if Vhpi_Put_Value (El, Context.Timing (N) * 1000) /= AvhpiErrorOk + then + Internal_Error ("vhpi_put_value"); + return False; + end if; + end if; + end loop; + return True; + end Write_Td_Delay_Generic; + + function Write_Td_Delay_Generic (Context : Sdf_Context_Type; + Gen : VhpiHandleT) + return Boolean + is + Gen_Basetype : VhpiHandleT; + Error : AvhpiErrorT; + begin + Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("write_td_delay_generic: vhpiBaseType"); + return False; + end if; + if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) then + case Context.Timing_Nbr is + when 1 => + return Write_Td_Delay_Generic (Context, Gen, 2, Map_1); + when 2 => + return Write_Td_Delay_Generic (Context, Gen, 2, Map_2); + when others => + 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 + Internal_Error ("vhpi_put_value (vitaldelaytype)"); + else + return True; + end if; + else + Internal_Error ("write_td_delay_generic: unhandled generic type"); + end if; + end Write_Td_Delay_Generic; + + procedure Generic_Get_Bounds (Port : VhpiHandleT; + Left : out Ghdl_I32; + Len : out Ghdl_Index_Type; + Up : out Boolean) + is + Port_Type, Port_Range : VhpiHandleT; + Error : AvhpiErrorT; + Right : VhpiIntT; + begin + Vhpi_Handle (VhpiSubtype, Port, Port_Type, Error); + Left := 0; + Len := 0; + Up := True; + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiSubtype - port"); + return; + end if; + Vhpi_Handle_By_Index (VhpiConstraints, Port_Type, 1, Port_Range, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIndexConstraints - port"); + return; + end if; + Vhpi_Get (VhpiLeftBoundP, Port_Range, Left, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiLeftBoundP - port"); + return; + end if; + Vhpi_Get (VhpiRightBoundP, Port_Range, Right, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiRightBoundP - port"); + return; + end if; + Vhpi_Get (VhpiIsUpP, Port_Range, Up, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIsUpP - port"); + return; + end if; + if Up then + Len := Ghdl_Index_Type (Right - Left) + 1; + else + Len := Ghdl_Index_Type (Left - Right) + 1; + end if; + end Generic_Get_Bounds; + + procedure Sdf_Generic (Context : in out Sdf_Context_Type; + Name : String; + Ok : out Boolean) + is + Gen : VhpiHandleT; + Gen_Basetype : VhpiHandleT; + Port1, Port2 : VhpiHandleT; + Error : AvhpiErrorT; + begin + if Flag_Dump then + Put ("generic: "); + Put (Name); + if Context.Timing_Nbr = 0 then + Put (' '); + Put_I64 (stdout, Context.Timing (1)); + else + for I in 1 .. 12 loop + Put (' '); + if Context.Timing_Set (I) then + Put_I64 (stdout, Context.Timing (I)); + else + Put ('?'); + end if; + end loop; + end if; + + New_Line; + Ok := True; + return; + end if; + + Ok := False; + + if Context.Port_Num = 1 then + Context.Ports (2).Name_Len := 0; + end if; + Find_Generic + (Name, Gen, + Context.Ports (1).Name (1 .. Context.Ports (1).Name_Len), Port1, + Context.Ports (2).Name (1 .. Context.Ports (2).Name_Len), Port2); + if Vhpi_Get_Kind (Gen) = VhpiUndefined + or else Vhpi_Get_Kind (Port1) = VhpiUndefined + or else (Context.Port_Num = 2 + and then Vhpi_Get_Kind (Port2) = VhpiUndefined) + then + return; + end if; + + -- Extract subtype. + Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiBaseType"); + return; + end if; + 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) + then + declare + Left_Gen, Left1, Left2 : Ghdl_I32; + Len_Gen, Len1, Len2 : Ghdl_Index_Type; + Up_Gen, Up1, Up2 : Boolean; + Pos : Ghdl_Index_Type; + Gen_El : VhpiHandleT; + begin + Generic_Get_Bounds (Gen, Left_Gen, Len_Gen, Up_Gen); + if Context.Port_Num >= 1 + and then Context.Ports (1).L /= Invalid_Dnumber + then + Generic_Get_Bounds (Port1, Left1, Len1, Up1); + if Up1 then + Pos := Ghdl_Index_Type (Context.Ports (1).L - Left1); + else + Pos := Ghdl_Index_Type (Left1 - Context.Ports (1).L); + end if; + else + Pos := 0; + end if; + if Context.Port_Num >= 2 + and then Context.Ports (2).L /= Invalid_Dnumber + then + Generic_Get_Bounds (Port2, Left2, Len2, Up2); + Pos := Pos * Len2; + if Up2 then + Pos := Pos + Ghdl_Index_Type (Context.Ports (2).L - Left2); + else + Pos := Pos + Ghdl_Index_Type (Left2 - Context.Ports (2).L); + end if; + end if; + Vhpi_Handle_By_Index + (VhpiIndexedNames, Gen, Integer (Pos), Gen_El, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIndexedNames - gen_el"); + return; + end if; + Ok := Write_Td_Delay_Generic (Context, Gen_El); + end; + else + Errors.Error_C ("vital: unhandled generic type for generic "); + Errors.Error_E (Name); + end if; + end Sdf_Generic; + + + procedure Annotate (Arg : String) + is + S, E : Natural; + Ok : Boolean; + begin + if Flag_Verbose then + Put ("sdf annotate: "); + Put (Arg); + New_Line; + end if; + + -- Find scope by name. + Get_Root_Inst (Sdf_Top); + E := Arg'First; + S := E; + L1: loop + -- Skip path separator. + while Arg (E) = '/' or Arg (E) = '.' loop + E := E + 1; + exit L1 when E > Arg'Last; + end loop; + + exit L1 when E > Arg'Last or else Arg (E) = '='; + + -- Instance element. + S := E; + while Arg (E) /= '=' and Arg (E) /= '.' and Arg (E) /= '/' loop + E := E + 1; + exit L1 when E > Arg'Last; + end loop; + + -- Path element. + if E - 1 >= S then + Find_Instance (Sdf_Top, Sdf_Top, Arg (S .. E - 1), Ok); + if not Ok then + Error_C ("cannot find instance '"); + Error_C (Arg (S .. E - 1)); + Error_E ("' for sdf annotation"); + return; + end if; + end if; + end loop L1; + + -- start annotation. + if E >= Arg'Last or else Arg (E) /= '=' then + Error_C ("no filename in sdf option '"); + Error_C (Arg); + Error_E ("'"); + return; + end if; + if not Sdf.Parse_Sdf_File (Arg (E + 1 .. Arg'Last)) then + null; + end if; + end Annotate; + + procedure Extract_Vital_Delay_Type + is + It : VhpiHandleT; + Pkg : VhpiHandleT; + Decl : VhpiHandleT; + Basetype : VhpiHandleT; + Status : AvhpiErrorT; + begin + Get_Package_Inst (It); + loop + Vhpi_Scan (It, Pkg, Status); + exit when Status /= AvhpiErrorOk; + exit when Name_Compare (Pkg, "vital_timing") + and then Name_Compare (Pkg, "ieee", VhpiLibLogicalNameP); + end loop; + if Status /= AvhpiErrorOk then + Error ("package ieee.vital_timing not found, SDF annotation aborted"); + return; + end if; + Vhpi_Iterator (VhpiDecls, Pkg, It, Status); + if Status /= AvhpiErrorOk then + Error ("cannot iterate on vital_timing"); + return; + end if; + loop + Vhpi_Scan (It, Decl, Status); + exit when Status /= AvhpiErrorOk; + if Vhpi_Get_Kind (Decl) = VhpiSubtypeDeclK + or else Vhpi_Get_Kind (Decl) = VhpiArrayTypeDeclK + then + Vhpi_Handle (VhpiBaseType, Decl, Basetype, Status); + 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 + VitalDelayType := Basetype; + elsif Name_Compare (Decl, "vitaldelayarraytype") then + VitalDelayArrayType := Basetype; + end if; + end if; + end if; + end loop; + if Vhpi_Get_Kind (VitalDelayType01) = VhpiUndefined then + 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; + end if; + if Vhpi_Get_Kind (VitalDelayType) = VhpiUndefined then + Error ("cannot find VitalDelayType in ieee.vital_timing"); + return; + end if; + end Extract_Vital_Delay_Type; + + Has_Sdf_Option : Boolean := False; + + procedure Sdf_Start + is + use Grt.Options; + Len : Integer; + Beg : Integer; + Arg : Ghdl_C_String; + begin + if not Has_Sdf_Option then + -- Nothing to do. + return; + end if; + Flag_Dump := False; + + -- Extract VitalDelayType(s) from VITAL_Timing package. + Extract_Vital_Delay_Type; + + -- Annotate. + for I in 1 .. Last_Opt loop + Arg := Argv (I); + Len := strlen (Arg); + if Len > 5 and then Arg (1 .. 6) = "--sdf=" then + Sdf_Mtm := Typical; + Beg := 7; + if Len > 10 then + if Arg (7 .. 10) = "typ=" then + Beg := 11; + elsif Arg (7 .. 10) = "min=" then + Sdf_Mtm := Minimum; + Beg := 11; + elsif Arg (7 .. 10) = "max=" then + Sdf_Mtm := Maximum; + Beg := 11; + end if; + end if; + Annotate (Arg (Beg .. Len)); + end if; + end loop; + end Sdf_Start; + + function Sdf_Option (Option : String) return Boolean + is + Opt : constant String (1 .. Option'Length) := Option; + begin + if Opt'Length > 11 and then Opt (1 .. 11) = "--sdf-dump=" then + Flag_Dump := True; + if Sdf.Parse_Sdf_File (Opt (12 .. Opt'Last)) then + null; + end if; + return True; + end if; + if Opt'Length > 5 and then Opt (1 .. 6) = "--sdf=" then + Has_Sdf_Option := True; + return True; + else + return False; + end if; + end Sdf_Option; + + procedure Sdf_Help is + begin + Put_Line (" --sdf=[min=|typ=|max=]TOP=FILENAME"); + Put_Line (" annotate TOP with SDF delay file FILENAME"); + end Sdf_Help; + + Sdf_Hooks : aliased constant Hooks_Type := + (Option => Sdf_Option'Access, + Help => Sdf_Help'Access, + Init => Proc_Hook_Nil'Access, + Start => Sdf_Start'Access, + Finish => Proc_Hook_Nil'Access); + + procedure Register is + begin + Register_Hooks (Sdf_Hooks'Access); + end Register; +end Grt.Vital_Annotate; diff --git a/src/translate/grt/grt-vital_annotate.ads b/src/translate/grt/grt-vital_annotate.ads new file mode 100644 index 0000000..acf82bb --- /dev/null +++ b/src/translate/grt/grt-vital_annotate.ads @@ -0,0 +1,42 @@ +-- GHDL Run Time (GRT) - VITAL annotator. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Sdf; use Grt.Sdf; + +package Grt.Vital_Annotate is + pragma Elaborate_Body (Grt.Vital_Annotate); + + procedure Sdf_Header (Context : Sdf_Context_Type); + procedure Sdf_Celltype (Context : Sdf_Context_Type); + procedure Sdf_Instance (Context : in out Sdf_Context_Type; + Instance : String; + Status : out Boolean); + procedure Sdf_Instance_End (Context : Sdf_Context_Type; + Status : out Boolean); + procedure Sdf_Generic (Context : in out Sdf_Context_Type; + Name : String; + Ok : out Boolean); + + procedure Register; +end Grt.Vital_Annotate; diff --git a/src/translate/grt/grt-vpi.adb b/src/translate/grt/grt-vpi.adb new file mode 100644 index 0000000..9b77319 --- /dev/null +++ b/src/translate/grt/grt-vpi.adb @@ -0,0 +1,988 @@ +-- GHDL Run Time (GRT) - VPI interface. +-- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram +-- +-- 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. + +-- Description: VPI interface for GRT runtime +-- the main purpose of this code is to interface with the +-- Icarus Verilog Interactive (IVI) simulator GUI + +------------------------------------------------------------------------------- +-- TODO: +------------------------------------------------------------------------------- +-- DONE: +-- * The GHDL VPI implementation doesn't support time +-- callbacks (cbReadOnlySynch). This is needed to support +-- IVI run. Currently, the GHDL simulation runs until +-- complete once a single 'run' is performed... +-- * You are loading '_'-prefixed symbols when you +-- load the vpi plugin. On Linux, there is no leading +-- '_'. I just added code to try both '_'-prefixed and +-- non-'_'-prefixed symbols. I have placed the changed +-- file in the same download dir as the snapshot +-- * I did find out why restart doesn't work for GHDL. +-- You are passing back the leaf name of signals when the +-- FullName is requested. +------------------------------------------------------------------------------- + +with Ada.Unchecked_Deallocation; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Signals; use Grt.Signals; +with Grt.Table; +with Grt.Astdio; use Grt.Astdio; +with Grt.Hooks; use Grt.Hooks; +with Grt.Vcd; use Grt.Vcd; +with Grt.Errors; use Grt.Errors; +with Grt.Rtis_Types; +pragma Elaborate_All (Grt.Table); + +package body Grt.Vpi is + -- The VPI interface requires libdl (dlopen, dlsym) to be linked in. + -- This is now set in Makefile, since this is target dependent. + -- pragma Linker_Options ("-ldl"); + + --errAnyString: constant String := "grt-vcd.adb: any string" & NUL; + --errNoString: constant String := "grt-vcd.adb: no string" & NUL; + + type Vpi_Index_Type is new Integer; + +------------------------------------------------------------------------------- +-- * * * h e l p e r s * * * * * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + ------------------------------------------------------------------------ + -- debugging helpers + procedure dbgPut (Str : String) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Str'Address, Str'Length, 1, stderr); + end dbgPut; + + procedure dbgPut (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), stderr); + end dbgPut; + + procedure dbgNew_Line is + begin + dbgPut (Nl); + end dbgNew_Line; + + procedure dbgPut_Line (Str : String) + is + begin + dbgPut (Str); + dbgNew_Line; + end dbgPut_Line; + +-- procedure dbgPut_Line (Str : Ghdl_Str_Len_Type) +-- is +-- begin +-- Put_Str_Len(stderr, Str); +-- dbgNew_Line; +-- end dbgPut_Line; + + procedure Free is new Ada.Unchecked_Deallocation + (Name => vpiHandle, Object => struct_vpiHandle); + + ------------------------------------------------------------------------ + -- NUL-terminate strings. + -- note: there are several buffers + -- see IEEE 1364-2001 +-- tmpstring1: string(1..1024); +-- function NulTerminate1 (Str : Ghdl_Str_Len_Type) return Ghdl_C_String +-- is +-- begin +-- for i in 1..Str.Len loop +-- tmpstring1(i):= Str.Str(i); +-- end loop; +-- tmpstring1(Str.Len+1):= NUL; +-- return To_Ghdl_C_String (tmpstring1'Address); +-- end NulTerminate1; + +------------------------------------------------------------------------------- +-- * * * V P I f u n c t i o n s * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + ------------------------------------------------------------------------ + -- vpiHandle vpi_iterate(int type, vpiHandle ref) + -- Obtain an iterator handle to objects with a one-to-many relationship. + -- see IEEE 1364-2001, page 685 + function vpi_iterate (aType: integer; Ref: vpiHandle) return vpiHandle + is + Res : vpiHandle; + Rel : VhpiOneToManyT; + Error : AvhpiErrorT; + begin + --dbgPut_Line ("vpi_iterate"); + + case aType is + when vpiNet => + Rel := VhpiDecls; + when vpiModule => + if Ref = null then + Res := new struct_vpiHandle (vpiModule); + Get_Root_Inst (Res.Ref); + return Res; + else + Rel := VhpiInternalRegions; + end if; + when vpiInternalScope => + Rel := VhpiInternalRegions; + when others => + return null; + end case; + + -- find the proper start object for our scan + if Ref = null then + return null; + end if; + + Res := new struct_vpiHandle (aType); + Vhpi_Iterator (Rel, Ref.Ref, Res.Ref, Error); + + if Error /= AvhpiErrorOk then + Free (Res); + end if; + return Res; + end vpi_iterate; + + ------------------------------------------------------------------------ + -- int vpi_get(int property, vpiHandle ref) + -- Get the value of an integer or boolean property of an object. + -- see IEEE 1364-2001, chapter 27.6, page 667 +-- function ii_vpi_get_type (aRef: Ghdl_Instance_Name_Acc) return Integer +-- is +-- begin +-- case aRef.Kind is +-- when Ghdl_Name_Entity +-- | Ghdl_Name_Architecture +-- | Ghdl_Name_Block +-- | Ghdl_Name_Generate_Iterative +-- | Ghdl_Name_Generate_Conditional +-- | Ghdl_Name_Instance => +-- return vpiModule; +-- when Ghdl_Name_Signal => +-- return vpiNet; +-- when others => +-- return vpiUndefined; +-- end case; +-- end ii_vpi_get_type; + + function vpi_get (Property: integer; Ref: vpiHandle) return Integer + is + begin + case Property is + when vpiType=> + return Ref.mType; + when vpiTimePrecision=> + return -9; -- is this nano-seconds? + when others=> + dbgPut_Line ("vpi_get: unknown property"); + return 0; + end case; + end vpi_get; + + ------------------------------------------------------------------------ + -- vpiHandle vpi_scan(vpiHandle iter) + -- Scan the Verilog HDL hierarchy for objects with a one-to-many + -- relationship. + -- see IEEE 1364-2001, chapter 27.36, page 709 + function vpi_scan (Iter: vpiHandle) return vpiHandle + is + Res : VhpiHandleT; + Error : AvhpiErrorT; + R : vpiHandle; + begin + --dbgPut_Line ("vpi_scan"); + if Iter = null then + return null; + end if; + + -- There is only one top-level module. + if Iter.mType = vpiModule then + case Vhpi_Get_Kind (Iter.Ref) is + when VhpiRootInstK => + R := new struct_vpiHandle (Iter.mType); + R.Ref := Iter.Ref; + Iter.Ref := Null_Handle; + return R; + when VhpiUndefined => + return null; + when others => + -- Fall through. + null; + end case; + end if; + + loop + Vhpi_Scan (Iter.Ref, Res, Error); + exit when Error /= AvhpiErrorOk; + + case Vhpi_Get_Kind (Res) is + when VhpiEntityDeclK + | VhpiArchBodyK + | VhpiBlockStmtK + | VhpiIfGenerateK + | VhpiForGenerateK + | VhpiCompInstStmtK => + case Iter.mType is + when vpiInternalScope + | vpiModule => + return new struct_vpiHandle'(mType => vpiModule, + Ref => Res); + when others => + null; + end case; + when VhpiPortDeclK + | VhpiSigDeclK => + if Iter.mType = vpiNet then + declare + Info : Verilog_Wire_Info; + begin + Get_Verilog_Wire (Res, Info); + if Info.Kind /= Vcd_Bad then + return new struct_vpiHandle'(mType => vpiNet, + Ref => Res); + end if; + end; + end if; + when others => + null; + end case; + end loop; + return null; + end vpi_scan; + + ------------------------------------------------------------------------ + -- char *vpi_get_str(int property, vpiHandle ref) + -- see IEEE 1364-2001, page xxx + Tmpstring2 : String (1 .. 1024); + function vpi_get_str (Property : Integer; Ref : vpiHandle) + return Ghdl_C_String + is + Prop : VhpiStrPropertyT; + Len : Natural; + begin + --dbgPut_Line ("vpiGetStr"); + + if Ref = null then + return null; + end if; + + case Property is + when vpiFullName=> + Prop := VhpiFullNameP; + when vpiName=> + Prop := VhpiNameP; + when others=> + dbgPut_Line ("vpi_get_str: undefined property"); + return null; + end case; + Vhpi_Get_Str (Prop, Ref.Ref, Tmpstring2, Len); + Tmpstring2 (Len + 1) := NUL; + if Property = vpiFullName then + for I in Tmpstring2'First .. Len loop + if Tmpstring2 (I) = ':' then + Tmpstring2 (I) := '.'; + end if; + end loop; + -- Remove the initial '.'. + return To_Ghdl_C_String (Tmpstring2 (2)'Address); + else + return To_Ghdl_C_String (Tmpstring2'Address); + end if; + end vpi_get_str; + + ------------------------------------------------------------------------ + -- vpiHandle vpi_handle(int type, vpiHandle ref) + -- Obtain a handle to an object with a one-to-one relationship. + -- see IEEE 1364-2001, chapter 27.16, page 682 + function vpi_handle (aType : Integer; Ref : vpiHandle) return vpiHandle + is + Res : vpiHandle; + begin + --dbgPut_Line ("vpi_handle"); + + if Ref = null then + return null; + end if; + + case aType is + when vpiScope => + case Ref.mType is + when vpiModule => + Res := new struct_vpiHandle (vpiScope); + Res.Ref := Ref.Ref; + return Res; + when others => + return null; + end case; + when vpiRightRange + | vpiLeftRange => + case Ref.mType is + when vpiNet => + Res := new struct_vpiHandle (aType); + Res.Ref := Ref.Ref; + return Res; + when others => + return null; + end case; + when others => + return null; + end case; + end vpi_handle; + + ------------------------------------------------------------------------ + -- void vpi_get_value(vpiHandle expr, p_vpi_value value); + -- Retrieve the simulation value of an object. + -- see IEEE 1364-2001, chapter 27.14, page 675 + Tmpstring3idx : integer; + Tmpstring3 : String (1 .. 1024); + procedure ii_vpi_get_value_bin_str_B1 (Val : Ghdl_B1) + is + begin + case Val is + when True => + Tmpstring3 (Tmpstring3idx) := '1'; + when False => + Tmpstring3 (Tmpstring3idx) := '0'; + end case; + Tmpstring3idx := Tmpstring3idx + 1; + end ii_vpi_get_value_bin_str_B1; + + procedure ii_vpi_get_value_bin_str_E8 (Val : Ghdl_E8) + is + type Map_Type_E8 is array (Ghdl_E8 range 0..8) of character; + Map_Std_E8: constant Map_Type_E8 := "UX01ZWLH-"; + begin + if Val not in Map_Type_E8'range then + Tmpstring3 (Tmpstring3idx) := '?'; + else + Tmpstring3 (Tmpstring3idx) := Map_Std_E8(Val); + end if; + Tmpstring3idx := Tmpstring3idx + 1; + end ii_vpi_get_value_bin_str_E8; + + function ii_vpi_get_value_bin_str (Obj : VhpiHandleT) + return Ghdl_C_String + is + Info : Verilog_Wire_Info; + Len : Ghdl_Index_Type; + begin + case Vhpi_Get_Kind (Obj) is + when VhpiPortDeclK + | VhpiSigDeclK => + null; + when others => + return null; + end case; + + -- Get verilog compat info. + Get_Verilog_Wire (Obj, Info); + if Info.Kind = Vcd_Bad then + return null; + end if; + + if Info.Irange = null then + Len := 1; + else + Len := Info.Irange.I32.Len; + end if; + + Tmpstring3idx := 1; -- reset string buffer + + case Info.Val is + when Vcd_Effective => + case Info.Kind is + when Vcd_Bad + | Vcd_Integer32 + | Vcd_Float64 => + return null; + when Vcd_Bit + | Vcd_Bool + | Vcd_Bitvector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_B1 + (To_Signal_Arr_Ptr (Info.Addr)(J).Value.B1); + end loop; + when Vcd_Stdlogic + | Vcd_Stdlogic_Vector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_E8 + (To_Signal_Arr_Ptr (Info.Addr)(J).Value.E8); + end loop; + end case; + when Vcd_Driving => + case Info.Kind is + when Vcd_Bad + | Vcd_Integer32 + | Vcd_Float64 => + return null; + when Vcd_Bit + | Vcd_Bool + | Vcd_Bitvector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_B1 + (To_Signal_Arr_Ptr (Info.Addr)(J).Driving_Value.B1); + end loop; + when Vcd_Stdlogic + | Vcd_Stdlogic_Vector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_E8 + (To_Signal_Arr_Ptr (Info.Addr)(J).Driving_Value.E8); + end loop; + end case; + end case; + Tmpstring3 (Tmpstring3idx) := NUL; + return To_Ghdl_C_String (Tmpstring3'Address); + end ii_vpi_get_value_bin_str; + + procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value) + is + begin + case Value.Format is + when vpiObjTypeVal=> + -- fill in the object type and value: + -- For an integer, vpiIntVal + -- For a real, vpiRealVal + -- For a scalar, either vpiScalar or vpiStrength + -- For a time variable, vpiTimeVal with vpiSimTime + -- For a vector, vpiVectorVal + dbgPut_Line ("vpi_get_value: vpiObjTypeVal"); + when vpiBinStrVal=> + Value.Str := ii_vpi_get_value_bin_str (Expr.Ref); + --aValue.mStr := NulTerminate2(aExpr.mRef.Name.all); + when vpiOctStrVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiOctStrVal"); + when vpiDecStrVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiDecStrVal"); + when vpiHexStrVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiHexStrVal"); + when vpiScalarVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiScalarVal"); + when vpiIntVal=> + case Expr.mType is + when vpiLeftRange + | vpiRightRange=> + declare + Info : Verilog_Wire_Info; + begin + Get_Verilog_Wire (Expr.Ref, Info); + if Info.Irange /= null then + if Expr.mType = vpiLeftRange then + Value.Integer_m := Integer (Info.Irange.I32.Left); + else + Value.Integer_m := Integer (Info.Irange.I32.Right); + end if; + else + Value.Integer_m := 0; + end if; + end; + when others=> + dbgPut_Line ("vpi_get_value: vpiIntVal, unknown mType"); + end case; + when vpiRealVal=> dbgPut_Line("vpi_get_value: vpiRealVal"); + when vpiStringVal=> dbgPut_Line("vpi_get_value: vpiStringVal"); + when vpiTimeVal=> dbgPut_Line("vpi_get_value: vpiTimeVal"); + when vpiVectorVal=> dbgPut_Line("vpi_get_value: vpiVectorVal"); + when vpiStrengthVal=> dbgPut_Line("vpi_get_value: vpiStrengthVal"); + when others=> dbgPut_Line("vpi_get_value: unknown mFormat"); + end case; + end vpi_get_value; + + ------------------------------------------------------------------------ + -- void vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, + -- p_vpi_time when, int flags) + -- Alter the simulation value of an object. + -- see IEEE 1364-2001, chapter 27.14, page 675 + -- FIXME + + procedure ii_vpi_put_value_bin_str_B1 (SigPtr : Ghdl_Signal_Ptr; + Value : Character) + is + Tempval : Value_Union; + begin + -- use the Set_Effective_Value procedure to update the signal + case Value is + when '0' => + Tempval.B1 := false; + when '1' => + Tempval.B1 := true; + when others => + dbgPut_Line("ii_vpi_put_value_bin_str_B1: " + & "wrong character - signal wont be set"); + return; + end case; + SigPtr.Driving_Value := Tempval; + Set_Effective_Value (SigPtr, Tempval); + end ii_vpi_put_value_bin_str_B1; + + procedure ii_vpi_put_value_bin_str_E8 (SigPtr : Ghdl_Signal_Ptr; + Value : Character) + is + Tempval : Value_Union; + begin + case Value is + when 'U' => + Tempval.E8 := 0; + when 'X' => + Tempval.E8 := 1; + when '0' => + Tempval.E8 := 2; + when '1' => + Tempval.E8 := 3; + when 'Z' => + Tempval.E8 := 4; + when 'W' => + Tempval.E8 := 5; + when 'L' => + Tempval.E8 := 6; + when 'H' => + Tempval.E8 := 7; + when '-' => + Tempval.E8 := 8; + when others => + dbgPut_Line("ii_vpi_put_value_bin_str_B8: " + & "wrong character - signal wont be set"); + return; + end case; + SigPtr.Driving_Value := Tempval; + Set_Effective_Value (SigPtr, Tempval); + end ii_vpi_put_value_bin_str_E8; + + + procedure ii_vpi_put_value_bin_str(Obj : VhpiHandleT; + ValueStr : Ghdl_C_String) + is + Info : Verilog_Wire_Info; + Len : Ghdl_Index_Type; + begin + -- Check the Obj type. + -- * The vpiHandle has a reference (field Ref) to a VhpiHandleT + -- when it doesnt come from a callback. + case Vhpi_Get_Kind(Obj) is + when VhpiPortDeclK + | VhpiSigDeclK => + null; + when others => + return; + end case; + + -- The following code segment was copied from the + -- ii_vpi_get_value function. + -- Get verilog compat info. + Get_Verilog_Wire (Obj, Info); + if Info.Kind = Vcd_Bad then + return; + end if; + + if Info.Irange = null then + Len := 1; + else + Len := Info.Irange.I32.Len; + end if; + + -- Step 1: convert vpi object to internal format. + -- p_vpi_handle -> Ghdl_Signal_Ptr + -- To_Signal_Arr_Ptr (Info.Addr) does part of the magic + + -- Step 2: convert datum to appropriate type. + -- Ghdl_C_String -> Value_Union + + -- Step 3: assigns value to object using Set_Effective_Value + -- call (from grt-signals) + -- Set_Effective_Value(sig_ptr, conv_value); + + + -- Took the skeleton from ii_vpi_get_value function + -- This point of the function must convert the string value to the + -- native ghdl format. + case Info.Kind is + when Vcd_Bad => + return; + when Vcd_Bit + | Vcd_Bool + | Vcd_Bitvector => + for J in 0 .. Len - 1 loop + ii_vpi_put_value_bin_str_B1( + To_Signal_Arr_Ptr(Info.Addr)(J), ValueStr(Integer(J+1))); + end loop; + when Vcd_Stdlogic + | Vcd_Stdlogic_Vector => + for J in 0 .. Len - 1 loop + ii_vpi_put_value_bin_str_E8( + To_Signal_Arr_Ptr(Info.Addr)(J), ValueStr(Integer(J+1))); + end loop; + when Vcd_Integer32 + | Vcd_Float64 => + null; + end case; + + -- Always return null, because this simulation kernel cannot send + -- a handle to the event back. + return; + end ii_vpi_put_value_bin_str; + + + -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, + -- p_vpi_time when, int flags) + function vpi_put_value (aObj: vpiHandle; + aValue: p_vpi_value; + aWhen: p_vpi_time; + aFlags: integer) + return vpiHandle + is + pragma Unreferenced (aWhen); + pragma Unreferenced (aFlags); + begin + -- A very simple write procedure for VPI. + -- Basically, it accepts bin_str values and converts to appropriate + -- types (only std_logic and bit values and vectors). + + -- It'll use Set_Effective_Value procedure to update signals + + -- Ignoring aWhen and aFlags, for now. + + -- Checks the format of aValue. Only vpiBinStrVal will be accepted + -- for now. + case aValue.Format is + when vpiObjTypeVal => + dbgPut_Line ("vpi_put_value: vpiObjTypeVal"); + when vpiBinStrVal => + ii_vpi_put_value_bin_str(aObj.Ref, aValue.Str); + -- dbgPut_Line ("vpi_put_value: vpiBinStrVal"); + when vpiOctStrVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiOctStrVal"); + when vpiDecStrVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiDecStrVal"); + when vpiHexStrVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiHexStrVal"); + when vpiScalarVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiScalarVal"); + when vpiIntVal => + dbgPut_Line ("vpi_put_value: vpiIntVal"); + when vpiRealVal => + dbgPut_Line("vpi_put_value: vpiRealVal"); + when vpiStringVal => + dbgPut_Line("vpi_put_value: vpiStringVal"); + when vpiTimeVal => + dbgPut_Line("vpi_put_value: vpiTimeVal"); + when vpiVectorVal => + dbgPut_Line("vpi_put_value: vpiVectorVal"); + when vpiStrengthVal => + dbgPut_Line("vpi_put_value: vpiStrengthVal"); + when others => + dbgPut_Line("vpi_put_value: unknown mFormat"); + end case; + + -- Must return a scheduled event caused by vpi_put_value() + -- Still dont know how to do it. + return null; + end vpi_put_value; + + ------------------------------------------------------------------------ + -- void vpi_get_time(vpiHandle obj, s_vpi_time*t); + -- see IEEE 1364-2001, page xxx + Sim_Time : Std_Time; + procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time) + is + pragma Unreferenced (Obj); + begin + --dbgPut_Line ("vpi_get_time"); + Time.mType := vpiSimTime; + Time.mHigh := 0; + Time.mLow := Integer (Sim_Time / 1000000); + Time.mReal := 0.0; + end vpi_get_time; + + ------------------------------------------------------------------------ + -- vpiHandle vpi_register_cb(p_cb_data data) + g_cbEndOfCompile : p_cb_data; + g_cbEndOfSimulation: p_cb_data; + --g_cbValueChange: s_cb_data; + g_cbReadOnlySync: p_cb_data; + + type Vpi_Var_Type is record + Info : Verilog_Wire_Info; + Cb : s_cb_data; + end record; + + package Vpi_Table is new Grt.Table + (Table_Component_Type => Vpi_Var_Type, + Table_Index_Type => Vpi_Index_Type, + Table_Low_Bound => 0, + Table_Initial => 32); + + function vpi_register_cb (Data : p_cb_data) return vpiHandle + is + Res : p_cb_data := null; + begin + --dbgPut_Line ("vpi_register_cb"); + case Data.Reason is + when cbEndOfCompile => + Res := new s_cb_data'(Data.all); + g_cbEndOfCompile := Res; + Sim_Time:= 0; + when cbEndOfSimulation => + Res := new s_cb_data'(Data.all); + g_cbEndOfSimulation := Res; + when cbValueChange => + declare + N : Vpi_Index_Type; + begin + --g_cbValueChange:= aData.all; + Vpi_Table.Increment_Last; + N := Vpi_Table.Last; + Vpi_Table.Table (N).Cb := Data.all; + Get_Verilog_Wire (Data.Obj.Ref, Vpi_Table.Table (N).Info); + end; + when cbReadOnlySynch=> + Res := new s_cb_data'(Data.all); + g_cbReadOnlySync := Res; + when others=> + dbgPut_Line ("vpi_register_cb: unknwon reason"); + end case; + if Res /= null then + return new struct_vpiHandle'(mType => vpiCallback, + Cb => Res); + else + return null; + end if; + end vpi_register_cb; + +------------------------------------------------------------------------------- +-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + -- int vpi_free_object(vpiHandle ref) + function vpi_free_object (aRef: vpiHandle) return integer + is + pragma Unreferenced (aRef); + begin + return 0; + end vpi_free_object; + + -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) + function vpi_get_vlog_info (aVlog_info_p: System.Address) return integer + is + pragma Unreferenced (aVlog_info_p); + begin + return 0; + end vpi_get_vlog_info; + + -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index) + function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer) + return vpiHandle + is + pragma Unreferenced (aRef); + pragma Unreferenced (aIndex); + begin + return null; + end vpi_handle_by_index; + + -- unsigned int vpi_mcd_close(unsigned int mcd) + function vpi_mcd_close (Mcd: integer) return integer + is + pragma Unreferenced (Mcd); + begin + return 0; + end vpi_mcd_close; + + -- char *vpi_mcd_name(unsigned int mcd) + function vpi_mcd_name (Mcd: integer) return integer + is + pragma Unreferenced (Mcd); + begin + return 0; + end vpi_mcd_name; + + -- unsigned int vpi_mcd_open(char *name) + function vpi_mcd_open (Name : Ghdl_C_String) return Integer + is + pragma Unreferenced (Name); + begin + return 0; + end vpi_mcd_open; + + -- void vpi_register_systf(const struct t_vpi_systf_data*ss) + procedure vpi_register_systf(aSs: System.Address) + is + pragma Unreferenced (aSs); + begin + null; + end vpi_register_systf; + + -- int vpi_remove_cb(vpiHandle ref) + function vpi_remove_cb (Ref : vpiHandle) return Integer + is + pragma Unreferenced (Ref); + begin + return 0; + end vpi_remove_cb; + + -- void vpi_vprintf(const char*fmt, va_list ap) + procedure vpi_vprintf (Fmt : Address; Ap : Address) + is + pragma Unreferenced (Fmt); + pragma Unreferenced (Ap); + begin + null; + end vpi_vprintf; + + -- missing here, see grt-cvpi.c: + -- vpi_mcd_open_x + -- vpi_mcd_vprintf + -- vpi_mcd_fputc + -- vpi_mcd_fgetc + -- vpi_sim_vcontrol + -- vpi_chk_error + -- pi_handle_by_name + +------------------------------------------------------------------------------ +-- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------ + + -- VCD filename. + Vpi_Filename : String_Access := null; + + ------------------------------------------------------------------------ + -- Return TRUE if OPT is an option for VPI. + function Vpi_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + begin + if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vpi" then + return False; + end if; + if Opt'Length > 6 and then Opt (F + 5) = '=' then + -- Add an extra NUL character. + Vpi_Filename := new String (1 .. Opt'Length - 6 + 1); + Vpi_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last); + Vpi_Filename (Vpi_Filename'Last) := NUL; + return True; + else + return False; + end if; + end Vpi_Option; + + ------------------------------------------------------------------------ + procedure Vpi_Help is + begin + Put_Line (" --vpi=FILENAME load VPI module"); + end Vpi_Help; + + ------------------------------------------------------------------------ + -- Called before elaboration. + + -- void loadVpiModule(const char* modulename) + function LoadVpiModule (Filename: Address) return Integer; + pragma Import (C, LoadVpiModule, "loadVpiModule"); + + + procedure Vpi_Init + is + begin + Sim_Time:= 0; + + --g_cbEndOfCompile.mCb_rtn:= null; + --g_cbEndOfSimulation.mCb_rtn:= null; + --g_cbValueChange.mCb_rtn:= null; + + if Vpi_Filename /= null then + if LoadVpiModule (Vpi_Filename.all'Address) /= 0 then + Error ("cannot load VPI module"); + end if; + end if; + end Vpi_Init; + + procedure Vpi_Cycle; + + ------------------------------------------------------------------------ + -- Called after elaboration. + procedure Vpi_Start + is + Res : Integer; + pragma Unreferenced (Res); + begin + if Vpi_Filename = null then + return; + end if; + + Grt.Rtis_Types.Search_Types_RTI; + Register_Cycle_Hook (Vpi_Cycle'Access); + if g_cbEndOfCompile /= null then + Res := g_cbEndOfCompile.Cb_Rtn.all (g_cbEndOfCompile); + end if; + end Vpi_Start; + + ------------------------------------------------------------------------ + -- Called before each non delta cycle. + procedure Vpi_Cycle + is + Res : Integer; + pragma Unreferenced (Res); + begin + if g_cbReadOnlySync /= null + and then g_cbReadOnlySync.Time.mLow < Integer (Sim_Time / 1_000_000) + then + Res := g_cbReadOnlySync.Cb_Rtn.all (g_cbReadOnlySync); + end if; + + for I in Vpi_Table.First .. Vpi_Table.Last loop + if Verilog_Wire_Changed (Vpi_Table.Table (I).Info, Sim_Time) then + Res := Vpi_Table.Table (I).Cb.Cb_Rtn.all + (To_p_cb_data (Vpi_Table.Table (I).Cb'Address)); + end if; + end loop; + + if Current_Time /= Std_Time'last then + Sim_Time:= Current_Time; + end if; + end Vpi_Cycle; + + ------------------------------------------------------------------------ + -- Called at the end of the simulation. + procedure Vpi_End + is + Res : Integer; + pragma Unreferenced (Res); + begin + if g_cbEndOfSimulation /= null then + Res := g_cbEndOfSimulation.Cb_Rtn.all (g_cbEndOfSimulation); + end if; + end Vpi_End; + + Vpi_Hooks : aliased constant Hooks_Type := + (Option => Vpi_Option'Access, + Help => Vpi_Help'Access, + Init => Vpi_Init'Access, + Start => Vpi_Start'Access, + Finish => Vpi_End'Access); + + procedure Register is + begin + Register_Hooks (Vpi_Hooks'Access); + end Register; +end Grt.Vpi; diff --git a/src/translate/grt/grt-vpi.ads b/src/translate/grt/grt-vpi.ads new file mode 100644 index 0000000..86fb073 --- /dev/null +++ b/src/translate/grt/grt-vpi.ads @@ -0,0 +1,252 @@ +-- GHDL Run Time (GRT) - VPI interface. +-- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram +-- +-- 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. + +-- Description: VPI interface for GRT runtime +-- the main purpose of this code is to interface with the +-- Icarus Verilog Interactive (IVI) simulator GUI + +with System; use System; +with Ada.Unchecked_Conversion; +with Grt.Types; use Grt.Types; +with Grt.Avhpi; use Grt.Avhpi; + +package Grt.Vpi is + + -- properties, see vpi_user.h + vpiUndefined: constant integer := -1; + vpiType: constant integer := 1; + vpiName: constant integer := 2; + vpiFullName: constant integer := 3; + vpiTimePrecision: constant integer := 12; + + -- object codes, see vpi_user.h + vpiModule: constant integer := 32; + vpiNet: constant integer := 36; + vpiScope: constant integer := 84; + vpiInternalScope: constant integer := 92; + vpiLeftRange: constant integer := 79; + vpiRightRange: constant integer := 83; + + -- Additionnal constants. + vpiCallback : constant Integer := 200; + + -- codes for the format tag of the vpi_value structure + vpiBinStrVal: constant integer := 1; + vpiOctStrVal: constant integer := 2; + vpiDecStrVal: constant integer := 3; + vpiHexStrVal: constant integer := 4; + vpiScalarVal: constant integer := 5; + vpiIntVal: constant integer := 6; + vpiRealVal: constant integer := 7; + vpiStringVal: constant integer := 8; + vpiVectorVal: constant integer := 9; + vpiStrengthVal: constant integer := 10; + vpiTimeVal: constant integer := 11; + vpiObjTypeVal: constant integer := 12; + vpiSuppressVal: constant integer := 13; + + -- codes for type tag of vpi_time structure + vpiSimTime: constant integer := 2; + + -- codes for the reason tag of cb_data structure + cbValueChange: constant integer:= 1; + cbReadOnlySynch: constant integer:= 7; + cbEndOfCompile: constant integer:= 10; + cbEndOfSimulation:constant integer:= 12; + + type struct_vpiHandle (mType : Integer := vpiUndefined); + type vpiHandle is access struct_vpiHandle; + + -- typedef struct t_vpi_time { + -- int type; + -- unsigned int high; + -- unsigned int low; + -- double real; + -- } s_vpi_time, *p_vpi_time; + type s_vpi_time is record + mType : Integer; + mHigh : Integer; -- this should be unsigned + mLow : Integer; -- this should be unsigned + mReal : Float; -- this should be double + end record; + type p_vpi_time is access s_vpi_time; + + -- typedef struct t_vpi_value + -- { int format; + -- union + -- { char*str; + -- int scalar; + -- int integer; + -- double real; + -- struct t_vpi_time *time; + -- struct t_vpi_vecval *vector; + -- struct t_vpi_strengthval *strength; + -- char*misc; + -- } value; + -- } s_vpi_value, *p_vpi_value; + type s_vpi_value (Format : integer) is record + case Format is + when vpiBinStrVal + | vpiOctStrVal + | vpiDecStrVal + | vpiHexStrVal + | vpiStringVal => + Str : Ghdl_C_String; + when vpiScalarVal => + Scalar : Integer; + when vpiIntVal => + Integer_m : Integer; + --when vpiRealVal=> null; -- what is the equivalent to double? + --when vpiTimeVal=> mTime: p_vpi_time; + --when vpiVectorVal=> mVector: p_vpi_vecval; + --when vpiStrengthVal=> mStrength: p_vpi_strengthval; + when others => + null; + end case; + end record; + type p_vpi_value is access s_vpi_value; + + --typedef struct t_cb_data { + -- int reason; + -- int (*cb_rtn)(struct t_cb_data*cb); + -- vpiHandle obj; + -- p_vpi_time time; + -- p_vpi_value value; + -- int index; + -- char*user_data; + --} s_cb_data, *p_cb_data; + type s_cb_data; + + type p_cb_data is access all s_cb_data; + function To_p_cb_data is new Ada.Unchecked_Conversion + (Source => Address, Target => p_cb_data); + + type cb_rtn_type is access function (Cb : p_cb_data) return Integer; + pragma Convention (C, cb_rtn_type); + + type s_cb_data is record + Reason : Integer; + Cb_Rtn : cb_rtn_type; + Obj : vpiHandle; + Time : p_vpi_time; + Value : p_vpi_value; + Index : Integer; + User_Data : Address; + end record; + + type struct_vpiHandle (mType : Integer := vpiUndefined) is record + case mType is + when vpiCallback => + Cb : p_cb_data; + when others => + Ref : VhpiHandleT; + end case; + end record; + + -- vpiHandle vpi_iterate(int type, vpiHandle ref) + function vpi_iterate (aType : Integer; Ref : vpiHandle) return vpiHandle; + pragma Export (C, vpi_iterate, "vpi_iterate"); + + -- int vpi_get(int property, vpiHandle ref) + function vpi_get (Property : Integer; Ref : vpiHandle) return Integer; + pragma Export (C, vpi_get, "vpi_get"); + + -- vpiHandle vpi_scan(vpiHandle iter) + function vpi_scan (Iter : vpiHandle) return vpiHandle; + pragma Export (C, vpi_scan, "vpi_scan"); + + -- char *vpi_get_str(int property, vpiHandle ref) + function vpi_get_str (Property : Integer; Ref : vpiHandle) + return Ghdl_C_String; + pragma Export (C, vpi_get_str, "vpi_get_str"); + + -- vpiHandle vpi_handle(int type, vpiHandle ref) + function vpi_handle (aType: integer; Ref: vpiHandle) + return vpiHandle; + pragma Export (C, vpi_handle, "vpi_handle"); + + -- void vpi_get_value(vpiHandle expr, p_vpi_value value); + procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value); + pragma Export (C, vpi_get_value, "vpi_get_value"); + + -- void vpi_get_time(vpiHandle obj, s_vpi_time*t); + procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time); + pragma Export (C, vpi_get_time, "vpi_get_time"); + + -- vpiHandle vpi_register_cb(p_cb_data data) + function vpi_register_cb (Data : p_cb_data) return vpiHandle; + pragma Export (C, vpi_register_cb, "vpi_register_cb"); + +------------------------------------------------------------------------------- +-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + -- int vpi_free_object(vpiHandle ref) + function vpi_free_object(aRef: vpiHandle) return integer; + pragma Export (C, vpi_free_object, "vpi_free_object"); + + -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) + function vpi_get_vlog_info(aVlog_info_p: System.Address) return integer; + pragma Export (C, vpi_get_vlog_info, "vpi_get_vlog_info"); + + -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index) + function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer) + return vpiHandle; + pragma Export (C, vpi_handle_by_index, "vpi_handle_by_index"); + + -- unsigned int vpi_mcd_close(unsigned int mcd) + function vpi_mcd_close (Mcd : Integer) return Integer; + pragma Export (C, vpi_mcd_close, "vpi_mcd_close"); + + -- char *vpi_mcd_name(unsigned int mcd) + function vpi_mcd_name (Mcd : Integer) return Integer; + pragma Export (C, vpi_mcd_name, "vpi_mcd_name"); + + -- unsigned int vpi_mcd_open(char *name) + function vpi_mcd_open (Name : Ghdl_C_String) return Integer; + pragma Export (C, vpi_mcd_open, "vpi_mcd_open"); + + -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, + -- p_vpi_time when, int flags) + function vpi_put_value (aObj : vpiHandle; + aValue : p_vpi_value; + aWhen : p_vpi_time; + aFlags : integer) + return vpiHandle; + pragma Export (C, vpi_put_value, "vpi_put_value"); + + -- void vpi_register_systf(const struct t_vpi_systf_data*ss) + procedure vpi_register_systf (aSs : Address); + pragma Export (C, vpi_register_systf, "vpi_register_systf"); + + -- int vpi_remove_cb(vpiHandle ref) + function vpi_remove_cb (Ref : vpiHandle) return integer; + pragma Export (C, vpi_remove_cb, "vpi_remove_cb"); + + -- void vpi_vprintf(const char*fmt, va_list ap) + procedure vpi_vprintf (Fmt: Address; Ap: Address); + pragma Export (C, vpi_vprintf, "vpi_vprintf"); + +------------------------------------------------------------------------------- +-- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + procedure Register; + +end Grt.Vpi; + diff --git a/src/translate/grt/grt-vstrings.adb b/src/translate/grt/grt-vstrings.adb new file mode 100644 index 0000000..30c58ab --- /dev/null +++ b/src/translate/grt/grt-vstrings.adb @@ -0,0 +1,422 @@ +-- GHDL Run Time (GRT) - variable strings. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Errors; use Grt.Errors; +with Grt.C; use Grt.C; + +package body Grt.Vstrings is + procedure Free (Fs : Fat_String_Acc); + pragma Import (C, Free); + + function Malloc (Len : Natural) return Fat_String_Acc; + pragma Import (C, Malloc); + + function Realloc (Ptr : Fat_String_Acc; Len : Natural) + return Fat_String_Acc; + pragma Import (C, Realloc); + + + procedure Free (Vstr : in out Vstring) is + begin + Free (Vstr.Str); + Vstr := (Str => null, + Max => 0, + Len => 0); + end Free; + + procedure Grow (Vstr : in out Vstring; Sum : Natural) + is + Nlen : constant Natural := Vstr.Len + Sum; + Nmax : Natural; + begin + Vstr.Len := Nlen; + if Nlen <= Vstr.Max then + return; + end if; + if Vstr.Max = 0 then + Nmax := 32; + else + Nmax := Vstr.Max; + end if; + while Nmax < Nlen loop + Nmax := Nmax * 2; + end loop; + Vstr.Str := Realloc (Vstr.Str, Nmax); + if Vstr.Str = null then + Internal_Error ("grt.vstrings.grow: memory exhausted"); + end if; + Vstr.Max := Nmax; + end Grow; + + procedure Append (Vstr : in out Vstring; C : Character) + is + begin + Grow (Vstr, 1); + Vstr.Str (Vstr.Len) := C; + end Append; + + procedure Append (Vstr : in out Vstring; Str : String) + is + S : constant Natural := Vstr.Len; + begin + Grow (Vstr, Str'Length); + Vstr.Str (S + 1 .. S + Str'Length) := Str; + end Append; + + procedure Append (Vstr : in out Vstring; Str : Ghdl_C_String) + is + S : constant Natural := Vstr.Len; + L : constant Natural := strlen (Str); + begin + Grow (Vstr, L); + Vstr.Str (S + 1 .. S + L) := Str (1 .. L); + end Append; + + function Length (Vstr : Vstring) return Natural is + begin + return Vstr.Len; + end Length; + + procedure Truncate (Vstr : in out Vstring; Len : Natural) is + begin + if Len > Vstr.Len then + Internal_Error ("grt.vstrings.truncate: bad len"); + end if; + Vstr.Len := Len; + end Truncate; + + procedure Put (Stream : FILEs; Vstr : Vstring) + is + S : size_t; + begin + S := size_t (Vstr.Len); + if S > 0 then + S := fwrite (Vstr.Str (1)'Address, S, 1, Stream); + end if; + end Put; + + procedure Free (Rstr : in out Rstring) is + begin + Free (Rstr.Str); + Rstr := (Str => null, + Max => 0, + First => 0); + end Free; + + function Length (Rstr : Rstring) return Natural is + begin + return Rstr.Max + 1 - Rstr.First; + end Length; + + procedure Grow (Rstr : in out Rstring; Min : Natural) + is + Len : constant Natural := Length (Rstr); + Nlen : constant Natural := Len + Min; + Nstr : Fat_String_Acc; + Nfirst : Natural; + Nmax : Natural; + begin + if Nlen <= Rstr.Max then + return; + end if; + if Rstr.Max = 0 then + Nmax := 32; + else + Nmax := Rstr.Max; + end if; + while Nmax < Nlen loop + Nmax := Nmax * 2; + end loop; + Nstr := Malloc (Nmax); + Nfirst := Nmax + 1 - Len; + if Rstr.Str /= null then + Nstr (Nfirst .. Nmax) := Rstr.Str (Rstr.First .. Rstr.Max); + Free (Rstr.Str); + end if; + Rstr := (Str => Nstr, + Max => Nmax, + First => Nfirst); + end Grow; + + procedure Prepend (Rstr : in out Rstring; C : Character) + is + begin + Grow (Rstr, 1); + Rstr.First := Rstr.First - 1; + Rstr.Str (Rstr.First) := C; + end Prepend; + + procedure Prepend (Rstr : in out Rstring; Str : String) + is + begin + Grow (Rstr, Str'Length); + Rstr.First := Rstr.First - Str'Length; + Rstr.Str (Rstr.First .. Rstr.First + Str'Length - 1) := Str; + end Prepend; + + procedure Prepend (Rstr : in out Rstring; Str : Ghdl_C_String) + is + L : constant Natural := strlen (Str); + begin + Grow (Rstr, L); + Rstr.First := Rstr.First - L; + Rstr.Str (Rstr.First .. Rstr.First + L - 1) := Str (1 .. L); + end Prepend; + + function Get_Address (Rstr : Rstring) return Address + is + begin + return Rstr.Str (Rstr.First)'Address; + end Get_Address; + + procedure Copy (Rstr : Rstring; Str : in out String; Len : out Natural) + is + begin + Len := Length (Rstr); + if Len > Str'Length then + Str := Rstr.Str (Rstr.First .. Rstr.First + Str'Length - 1); + else + Str (Str'First .. Str'First + Len - 1) := + Rstr.Str (Rstr.First .. Rstr.First + Len - 1); + end if; + end Copy; + + procedure Put (Stream : FILEs; Rstr : Rstring) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Get_Address (Rstr), size_t (Length (Rstr)), 1, Stream); + end Put; + + generic + type Ntype is range <>; + --Max_Len : Natural; + procedure Gen_To_String (Str : out String; First : out Natural; N : Ntype); + + procedure Gen_To_String (Str : out String; First : out Natural; N : Ntype) + is + subtype R_Type is String (1 .. Str'Length); + S : R_Type renames Str; + P : Natural := S'Last; + V : Ntype; + begin + if N > 0 then + V := -N; + else + V := N; + end if; + loop + S (P) := Character'Val (48 - (V rem 10)); + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + if N < 0 then + P := P - 1; + S (P) := '-'; + end if; + First := P; + end Gen_To_String; + + procedure To_String_I32 is new Gen_To_String (Ntype => Ghdl_I32); + + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I32) + renames To_String_I32; + + procedure To_String_I64 is new Gen_To_String (Ntype => Ghdl_I64); + + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I64) + renames To_String_I64; + + procedure To_String (Str : out String; Last : out Natural; N : Ghdl_F64) + is + function Trunc (V : Ghdl_F64) return Ghdl_F64; + pragma Import (C, Trunc); + + P : Natural := Str'First; + V : Ghdl_F64; + Vmax : Ghdl_F64; + Vd : Ghdl_F64; + Exp : Integer; + D : Integer; + B : Boolean; + begin + -- Handle sign. + if N < 0.0 then + Str (P) := '-'; + P := P + 1; + V := -N; + else + V := N; + end if; + + -- Compute the mantissa. + -- and normalize V in [0 .. 10.0[ + -- FIXME: should do a dichotomy. + if V = 0.0 then + Exp := 0; + elsif V < 1.0 then + Exp := 0; + loop + exit when V >= 1.0; + Exp := Exp - 1; + V := V * 10.0; + end loop; + else + Exp := 0; + loop + exit when V < 10.0; + Exp := Exp + 1; + V := V / 10.0; + end loop; + end if; + + Vmax := 10.0 ** (1 - 15); + for I in 0 .. 15 loop + -- Vd := Ghdl_F64'Truncation (V); + Vd := Trunc (V); + Str (P) := Character'Val (48 + Integer (Vd)); + P := P + 1; + V := (V - Vd) * 10.0; + + if I = 0 then + Str (P) := '.'; + P := P + 1; + end if; + exit when I > 0 and V < Vmax; + Vmax := Vmax * 10.0; + end loop; + + if Exp /= 0 then + -- LRM93 14.3 + -- if the exponent is present, the `e' is written as a lower case + -- character. + Str (P) := 'e'; + P := P + 1; + + if Exp < 0 then + Str (P) := '-'; + P := P + 1; + Exp := -Exp; + end if; + B := False; + for I in 0 .. 4 loop + D := (Exp / 10000) mod 10; + if D /= 0 or B or I = 4 then + Str (P) := Character'Val (48 + D); + P := P + 1; + B := True; + end if; + Exp := (Exp - D * 10000) * 10; + end loop; + end if; + + Last := P - 1; + end To_String; + + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Nbr_Digits : Ghdl_I32) + is + procedure Snprintf_Nf (Str : in out String; + Len : Natural; + Ndigits : Ghdl_I32; + V : Ghdl_F64); + pragma Import (C, Snprintf_Nf, "__ghdl_snprintf_nf"); + begin + Snprintf_Nf (Str, Str'Length, Nbr_Digits, N); + Last := strlen (To_Ghdl_C_String (Str'Address)); + end To_String; + + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Format : Ghdl_C_String) + is + procedure Snprintf_Fmtf (Str : in out String; + Len : Natural; + Format : Ghdl_C_String; + V : Ghdl_F64); + pragma Import (C, Snprintf_Fmtf, "__ghdl_snprintf_fmtf"); + begin + -- FIXME: check format ('%', f/g/e/a) + Snprintf_Fmtf (Str, Str'Length, Format, N); + Last := strlen (To_Ghdl_C_String (Str'Address)); + end To_String; + + procedure To_String (Str : out String_Time_Unit; + First : out Natural; + Value : Ghdl_I64; + Unit : Ghdl_I64) + is + V, U : Ghdl_I64; + D : Natural; + P : Natural := Str'Last; + Has_Digits : Boolean; + begin + -- Always work on negative values. + if Value > 0 then + V := -Value; + else + V := Value; + end if; + + Has_Digits := False; + U := Unit; + loop + if U = 1 then + if Has_Digits then + Str (P) := '.'; + P := P - 1; + else + Has_Digits := True; + end if; + end if; + + D := Natural (-(V rem 10)); + if D /= 0 or else Has_Digits then + Str (P) := Character'Val (48 + D); + P := P - 1; + Has_Digits := True; + end if; + U := U / 10; + V := V / 10; + exit when V = 0 and then U = 0; + end loop; + if not Has_Digits then + Str (P) := '0'; + else + P := P + 1; + end if; + if Value < 0 then + P := P - 1; + Str (P) := '-'; + end if; + First := P; + end To_String; +end Grt.Vstrings; diff --git a/src/translate/grt/grt-vstrings.ads b/src/translate/grt/grt-vstrings.ads new file mode 100644 index 0000000..94967bb --- /dev/null +++ b/src/translate/grt/grt-vstrings.ads @@ -0,0 +1,143 @@ +-- GHDL Run Time (GRT) - variable strings. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Stdio; use Grt.Stdio; +with Grt.Types; use Grt.Types; +with System; use System; + +package Grt.Vstrings is + -- A Vstring (Variable string) is an object which contains an unbounded + -- string. + type Vstring is limited private; + + -- Deallocate all storage internally allocated. + procedure Free (Vstr : in out Vstring); + + -- Append a character. + procedure Append (Vstr : in out Vstring; C : Character); + + -- Append a string. + procedure Append (Vstr : in out Vstring; Str : String); + + -- Append a C string. + procedure Append (Vstr : in out Vstring; Str : Ghdl_C_String); + + -- Get length of VSTR. + function Length (Vstr : Vstring) return Natural; + + -- Truncate VSTR to LEN. + -- It is an error if LEN is greater than the current length. + procedure Truncate (Vstr : in out Vstring; Len : Natural); + + -- Display VSTR. + procedure Put (Stream : FILEs; Vstr : Vstring); + + + -- A Rstring is link a Vstring but characters can only be prepended. + type Rstring is limited private; + + -- Deallocate storage associated with Rstr. + procedure Free (Rstr : in out Rstring); + + -- Prepend characters or strings. + procedure Prepend (Rstr : in out Rstring; C : Character); + procedure Prepend (Rstr : in out Rstring; Str : String); + procedure Prepend (Rstr : in out Rstring; Str : Ghdl_C_String); + + -- Get the length of RSTR. + function Length (Rstr : Rstring) return Natural; + + -- Return the address of the first character of RSTR. + function Get_Address (Rstr : Rstring) return Address; + + -- Display RSTR. + procedure Put (Stream : FILEs; Rstr : Rstring); + + -- Copy RSTR to STR, and return length of the string to LEN. + procedure Copy (Rstr : Rstring; Str : in out String; Len : out Natural); + + -- Write the image of N into STR padded to the right. FIRST is the index + -- of the first character, so the result is in STR (FIRST .. STR'last). + -- Requires at least 11 characters. + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I32); + + -- Write the image of N into STR padded to the right. FIRST is the index + -- of the first character, so the result is in STR (FIRST .. STR'last). + -- Requires at least 21 characters. + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I64); + + -- Write the image of N into STR. LAST is the index of the last character, + -- so the result is in STR (STR'first .. LAST). + -- Requires at least 24 characters. + -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1) + -- + exp_digits (4) -> 24. + procedure To_String (Str : out String; Last : out Natural; N : Ghdl_F64); + + subtype String_Real_Digits is String (1 .. 128); + + -- Write the image of N into STR using NBR_DIGITS digits after the decimal + -- point. + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Nbr_Digits : Ghdl_I32); + + subtype String_Real_Format is String (1 .. 128); + + -- Write the image of N into STR using NBR_DIGITS digits after the decimal + -- point. + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Format : Ghdl_C_String); + + -- Write the image of VALUE to STR using UNIT as unit. The output is in + -- STR (FIRST .. STR'last). + subtype String_Time_Unit is String (1 .. 22); + procedure To_String (Str : out String_Time_Unit; + First : out Natural; + Value : Ghdl_I64; + Unit : Ghdl_I64); + +private + subtype Fat_String is String (Positive); + type Fat_String_Acc is access Fat_String; + + type Vstring is record + Str : Fat_String_Acc := null; + Max : Natural := 0; + Len : Natural := 0; + end record; + + type Rstring is record + -- String whose bounds is (1 .. Max). + Str : Fat_String_Acc := null; + + -- Last index in STR. + Max : Natural := 0; + + -- Index of the first character. + First : Natural := 1; + end record; +end Grt.Vstrings; diff --git a/src/translate/grt/grt-waves.adb b/src/translate/grt/grt-waves.adb new file mode 100644 index 0000000..63bdb9a --- /dev/null +++ b/src/translate/grt/grt-waves.adb @@ -0,0 +1,1632 @@ +-- GHDL Run Time (GRT) - wave dumper (GHW) module. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Interfaces; use Interfaces; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Types; use Grt.Types; +with Grt.Avhpi; use Grt.Avhpi; +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Errors; use Grt.Errors; +with Grt.Astdio; use Grt.Astdio; +with Grt.Hooks; use Grt.Hooks; +with Grt.Table; +with Grt.Avls; use Grt.Avls; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Utils; +with Grt.Rtis_Types; +with Grt.Signals; use Grt.Signals; +with System; use System; +with Grt.Vstrings; use Grt.Vstrings; + +pragma Elaborate_All (Grt.Rtis_Utils); +pragma Elaborate_All (Grt.Table); + +package body Grt.Waves is + -- Waves filename. + Wave_Filename : String_Access := null; + -- Stream corresponding to the GHW filename. + Wave_Stream : FILEs; + + Ghw_Hie_Design : constant Unsigned_8 := 1; + Ghw_Hie_Block : constant Unsigned_8 := 3; + Ghw_Hie_Generate_If : constant Unsigned_8 := 4; + Ghw_Hie_Generate_For : constant Unsigned_8 := 5; + Ghw_Hie_Instance : constant Unsigned_8 := 6; + Ghw_Hie_Package : constant Unsigned_8 := 7; + Ghw_Hie_Process : constant Unsigned_8 := 13; + Ghw_Hie_Generic : constant Unsigned_8 := 14; + Ghw_Hie_Eos : constant Unsigned_8 := 15; -- End of scope. + Ghw_Hie_Signal : constant Unsigned_8 := 16; -- Signal. + Ghw_Hie_Port_In : constant Unsigned_8 := 17; -- Port + Ghw_Hie_Port_Out : constant Unsigned_8 := 18; -- Port + Ghw_Hie_Port_Inout : constant Unsigned_8 := 19; -- Port + Ghw_Hie_Port_Buffer : constant Unsigned_8 := 20; -- Port + Ghw_Hie_Port_Linkage : constant Unsigned_8 := 21; -- Port + + pragma Unreferenced (Ghw_Hie_Design); + pragma Unreferenced (Ghw_Hie_Generic); + + -- Return TRUE if OPT is an option for wave. + function Wave_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + begin + if Opt'Length < 6 or else Opt (F .. F + 5) /= "--wave" then + return False; + end if; + if Opt'Length > 6 and then Opt (F + 6) = '=' then + -- Add an extra NUL character. + Wave_Filename := new String (1 .. Opt'Length - 7 + 1); + Wave_Filename (1 .. Opt'Length - 7) := Opt (F + 7 .. Opt'Last); + Wave_Filename (Wave_Filename'Last) := NUL; + return True; + else + return False; + end if; + end Wave_Option; + + procedure Wave_Help is + begin + Put_Line (" --wave=FILENAME dump signal values into a wave file"); + end Wave_Help; + + procedure Wave_Put (Str : String) + is + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (Str'Address, Str'Length, 1, Wave_Stream); + end Wave_Put; + + procedure Wave_Putc (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), Wave_Stream); + end Wave_Putc; + + procedure Wave_Newline is + begin + Wave_Putc (Nl); + end Wave_Newline; + + procedure Wave_Put_Byte (B : Unsigned_8) + is + V : Unsigned_8 := B; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, 1, 1, Wave_Stream); + end Wave_Put_Byte; + + procedure Wave_Put_ULEB128 (Val : Ghdl_E32) + is + V : Ghdl_E32; + R : Ghdl_E32; + begin + V := Val; + loop + R := V mod 128; + V := V / 128; + if V = 0 then + Wave_Put_Byte (Unsigned_8 (R)); + exit; + else + Wave_Put_Byte (Unsigned_8 (128 + R)); + end if; + end loop; + end Wave_Put_ULEB128; + + procedure Wave_Put_SLEB128 (Val : Ghdl_I32) + is + function To_Ghdl_U32 is new Ada.Unchecked_Conversion + (Ghdl_I32, Ghdl_U32); + V : Ghdl_U32 := To_Ghdl_U32 (Val); + +-- function Shift_Right_Arithmetic (Value : Ghdl_U32; Amount : Natural) +-- return Ghdl_U32; +-- pragma Import (Intrinsic, Shift_Right_Arithmetic); + R : Unsigned_8; + begin + loop + R := Unsigned_8 (V mod 128); + V := Shift_Right_Arithmetic (V, 7); + if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0) + then + Wave_Put_Byte (R); + exit; + else + Wave_Put_Byte (R or 16#80#); + end if; + end loop; + end Wave_Put_SLEB128; + + procedure Wave_Put_LSLEB128 (Val : Ghdl_I64) + is + function To_Ghdl_U64 is new Ada.Unchecked_Conversion + (Ghdl_I64, Ghdl_U64); + V : Ghdl_U64 := To_Ghdl_U64 (Val); + + R : Unsigned_8; + begin + loop + R := Unsigned_8 (V mod 128); + V := Shift_Right_Arithmetic (V, 7); + if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0) + then + Wave_Put_Byte (R); + exit; + else + Wave_Put_Byte (R or 16#80#); + end if; + end loop; + end Wave_Put_LSLEB128; + + procedure Wave_Put_I32 (Val : Ghdl_I32) + is + V : Ghdl_I32 := Val; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, 4, 1, Wave_Stream); + end Wave_Put_I32; + + procedure Wave_Put_I64 (Val : Ghdl_I64) + is + V : Ghdl_I64 := Val; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, 8, 1, Wave_Stream); + end Wave_Put_I64; + + procedure Wave_Put_F64 (F64 : Ghdl_F64) + is + V : Ghdl_F64 := F64; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, Ghdl_F64'Size / Storage_Unit, 1, Wave_Stream); + end Wave_Put_F64; + + procedure Wave_Puts (Str : Ghdl_C_String) is + begin + Put (Wave_Stream, Str); + end Wave_Puts; + + procedure Write_Value (Value : Value_Union; Mode : Mode_Type) is + begin + case Mode is + when Mode_B1 => + Wave_Put_Byte (Ghdl_B1'Pos (Value.B1)); + when Mode_E8 => + Wave_Put_Byte (Ghdl_E8'Pos (Value.E8)); + when Mode_E32 => + Wave_Put_ULEB128 (Value.E32); + when Mode_I32 => + Wave_Put_SLEB128 (Value.I32); + when Mode_I64 => + Wave_Put_LSLEB128 (Value.I64); + when Mode_F64 => + Wave_Put_F64 (Value.F64); + end case; + end Write_Value; + + subtype Section_Name is String (1 .. 4); + type Header_Type is record + Name : Section_Name; + Pos : long; + end record; + + package Section_Table is new Grt.Table + (Table_Component_Type => Header_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 16); + + -- Create a new section. + -- Write the header in the file. + -- Save the location for the directory. + procedure Wave_Section (Name : Section_Name) is + begin + Section_Table.Append (Header_Type'(Name => Name, + Pos => ftell (Wave_Stream))); + Wave_Put (Name); + end Wave_Section; + + procedure Wave_Write_Size_Order is + begin + -- Byte order, 1 byte. + -- 0: bad, 1 : little-endian, 2 : big endian. + declare + type Byte_Arr is array (0 .. 3) of Unsigned_8; + function To_Byte_Arr is new Ada.Unchecked_Conversion + (Source => Unsigned_32, Target => Byte_Arr); + B4 : constant Byte_Arr := To_Byte_Arr (16#11_22_33_44#); + V : Unsigned_8; + begin + if B4 (0) = 16#11# then + -- Big endian. + V := 2; + elsif B4 (0) = 16#44# then + -- Little endian. + V := 1; + else + -- Unknown endian. + V := 0; + end if; + Wave_Put_Byte (V); + end; + -- Word size, 1 byte. + Wave_Put_Byte (Integer'Size / 8); + -- File offset size, 1 byte + Wave_Put_Byte (1); + -- Unused, must be zero (MBZ). + Wave_Put_Byte (0); + end Wave_Write_Size_Order; + + procedure Wave_Write_Directory + is + Pos : long; + begin + Pos := ftell (Wave_Stream); + Wave_Section ("DIR" & NUL); + Wave_Write_Size_Order; + Wave_Put_I32 (Ghdl_I32 (Section_Table.Last)); + for I in Section_Table.First .. Section_Table.Last loop + Wave_Put (Section_Table.Table (I).Name); + Wave_Put_I32 (Ghdl_I32 (Section_Table.Table (I).Pos)); + end loop; + Wave_Put ("EOD" & NUL); + + Wave_Section ("TAI" & NUL); + Wave_Write_Size_Order; + Wave_Put_I32 (Ghdl_I32 (Pos)); + end Wave_Write_Directory; + + -- Called before elaboration. + procedure Wave_Init + is + Mode : constant String := "wb" & NUL; + begin + if Wave_Filename = null then + Wave_Stream := NULL_Stream; + return; + end if; + if Wave_Filename.all = "-" & NUL then + Wave_Stream := stdout; + else + Wave_Stream := fopen (Wave_Filename.all'Address, Mode'Address); + if Wave_Stream = NULL_Stream then + Error_C ("cannot open "); + Error_E (Wave_Filename (Wave_Filename'First + .. Wave_Filename'Last - 1)); + return; + end if; + end if; + end Wave_Init; + + procedure Write_File_Header + is + begin + -- Magic, 9 bytes. + Wave_Put ("GHDLwave" & Nl); + -- Header length. + Wave_Put_Byte (16); + -- Version-major, 1 byte. + Wave_Put_Byte (0); + -- Version-minor, 1 byte. + Wave_Put_Byte (1); + + Wave_Write_Size_Order; + end Write_File_Header; + + procedure Avhpi_Error (Err : AvhpiErrorT) + is + pragma Unreferenced (Err); + begin + Put_Line ("Waves.Avhpi_Error!"); + null; + end Avhpi_Error; + + package Str_Table is new Grt.Table + (Table_Component_Type => Ghdl_C_String, + Table_Index_Type => AVL_Value, + Table_Low_Bound => 1, + Table_Initial => 16); + + package Str_AVL is new Grt.Table + (Table_Component_Type => AVL_Node, + Table_Index_Type => AVL_Nid, + Table_Low_Bound => AVL_Root, + Table_Initial => 16); + + Strings_Len : Natural := 0; + + function Str_Compare (L, R : AVL_Value) return Integer + is + Ls, Rs : Ghdl_C_String; + begin + Ls := Str_Table.Table (L); + Rs := Str_Table.Table (R); + if L = R then + return 0; + end if; + return Strcmp (Ls, Rs); + end Str_Compare; + + procedure Disp_Str_Avl (N : AVL_Nid) is + begin + Put (stdout, "node: "); + Put_I32 (stdout, Ghdl_I32 (N)); + New_Line (stdout); + Put (stdout, " left: "); + Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Left)); + New_Line (stdout); + Put (stdout, " right: "); + Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Right)); + New_Line (stdout); + Put (stdout, " height: "); + Put_I32 (stdout, Str_AVL.Table (N).Height); + New_Line (stdout); + Put (stdout, " str: "); + --Put (stdout, Str_AVL.Table (N).Val); + New_Line (stdout); + end Disp_Str_Avl; + + pragma Unreferenced (Disp_Str_Avl); + + function Create_Str_Index (Str : Ghdl_C_String) return AVL_Value + is + Res : AVL_Nid; + begin + Str_Table.Append (Str); + Str_AVL.Append (AVL_Node'(Val => Str_Table.Last, + Left | Right => AVL_Nil, + Height => 1)); + Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)), + Str_Compare'Access, + Str_AVL.Last, Res); + if Res /= Str_AVL.Last then + Str_AVL.Decrement_Last; + Str_Table.Decrement_Last; + else + Strings_Len := Strings_Len + strlen (Str); + end if; + return Str_AVL.Table (Res).Val; + end Create_Str_Index; + + pragma Unreferenced (Create_Str_Index); + + procedure Create_String_Id (Str : Ghdl_C_String) + is + Res : AVL_Nid; + begin + if Str = null then + return; + end if; + Str_Table.Append (Str); + Str_AVL.Append (AVL_Node'(Val => Str_Table.Last, + Left | Right => AVL_Nil, + Height => 1)); + Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)), + Str_Compare'Access, + Str_AVL.Last, Res); + if Res /= Str_AVL.Last then + Str_AVL.Decrement_Last; + Str_Table.Decrement_Last; + else + Strings_Len := Strings_Len + strlen (Str); + end if; + end Create_String_Id; + + function Get_String (Str : Ghdl_C_String) return AVL_Value + is + H, L, M : AVL_Value; + Diff : Integer; + begin + L := Str_Table.First; + H := Str_Table.Last; + loop + M := (L + H) / 2; + Diff := Strcmp (Str, Str_Table.Table (M)); + if Diff = 0 then + return M; + elsif Diff < 0 then + H := M - 1; + else + L := M + 1; + end if; + exit when L > H; + end loop; + return 0; + end Get_String; + + procedure Write_String_Id (Str : Ghdl_C_String) is + begin + if Str = null then + Wave_Put_Byte (0); + else + Wave_Put_ULEB128 (Ghdl_E32 (Get_String (Str))); + end if; + end Write_String_Id; + + type Type_Node is record + Type_Rti : Ghdl_Rti_Access; + Context : Rti_Context; + end record; + + package Types_Table is new Grt.Table + (Table_Component_Type => Type_Node, + Table_Index_Type => AVL_Value, + Table_Low_Bound => 1, + Table_Initial => 16); + + package Types_AVL is new Grt.Table + (Table_Component_Type => AVL_Node, + Table_Index_Type => AVL_Nid, + Table_Low_Bound => AVL_Root, + Table_Initial => 16); + + function Type_Compare (L, R : AVL_Value) return Integer + is + function To_Ia is new + Ada.Unchecked_Conversion (Ghdl_Rti_Access, Integer_Address); + + function "<" (L, R : Ghdl_Rti_Access) return Boolean is + begin + return To_Ia (L) < To_Ia (R); + end "<"; + + Ls : Type_Node renames Types_Table.Table (L); + Rs : Type_Node renames Types_Table.Table (R); + begin + if Ls.Type_Rti /= Rs.Type_Rti then + if Ls.Type_Rti < Rs.Type_Rti then + return -1; + else + return 1; + end if; + end if; + if Ls.Context.Block /= Rs.Context.Block then + if Ls.Context.Block < Rs.Context.Block then + return -1; + else + return +1; + end if; + end if; + if Ls.Context.Base /= Rs.Context.Base then + if Ls.Context.Base < Rs.Context.Base then + return -1; + else + return +1; + end if; + end if; + return 0; + end Type_Compare; + + -- Try to find type (RTI, CTXT) in the types_AVL table. + -- The first step is to canonicalize CTXT, so that it is the CTXT of + -- the type (and not a sub-scope of it). + procedure Find_Type (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + N_Ctxt : out Rti_Context; + Id : out AVL_Nid) + is + Depth : Ghdl_Rti_Depth; + begin + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 => + N_Ctxt := Null_Context; + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal => + N_Ctxt := Ctxt; + when others => + -- Compute the canonical context. + if Rti.Max_Depth < Rti.Depth then + Internal_Error ("grt.waves.find_type"); + end if; + Depth := Rti.Max_Depth; + if Depth = 0 or else Ctxt.Block = null then + N_Ctxt := Null_Context; + else + N_Ctxt := Ctxt; + while N_Ctxt.Block.Depth > Depth loop + N_Ctxt := Get_Parent_Context (N_Ctxt); + end loop; + end if; + end case; + + -- If the type is already known, return now. + -- Otherwise, ID is set to AVL_Nil. + Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => N_Ctxt)); + Id := Find_Node + (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)), + Type_Compare'Access, + Types_Table.Last); + Types_Table.Decrement_Last; + end Find_Type; + + procedure Write_Type_Id (Tid : AVL_Nid) is + begin + Wave_Put_ULEB128 (Ghdl_E32 (Types_AVL.Table (Tid).Val)); + end Write_Type_Id; + + procedure Write_Type_Id (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + N_Ctxt : Rti_Context; + Res : AVL_Nid; + begin + Find_Type (Rti, Ctxt, N_Ctxt, Res); + if Res = AVL_Nil then + -- raise Program_Error; + Internal_Error ("write_type_id"); + end if; + Write_Type_Id (Res); + end Write_Type_Id; + + procedure Add_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + Res : AVL_Nid; + begin + -- Then, create the type. + Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => Ctxt)); + Types_AVL.Append (AVL_Node'(Val => Types_Table.Last, + Left | Right => AVL_Nil, + Height => 1)); + + Get_Node + (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)), + Type_Compare'Access, + Types_AVL.Last, Res); + if Res /= Types_AVL.Last then + --raise Program_Error; + Internal_Error ("wave.create_type(2)"); + end if; + end Add_Type; + + procedure Create_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + N_Ctxt : Rti_Context; + Res : AVL_Nid; + begin + Find_Type (Rti, Ctxt, N_Ctxt, Res); + if Res /= AVL_Nil then + return; + end if; + + -- First, create all the types it depends on. + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 => + declare + Enum : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Create_String_Id (Enum.Name); + for I in 1 .. Enum.Nbr loop + Create_String_Id (Enum.Names (I - 1)); + end loop; + end; + when Ghdl_Rtik_Subtype_Array => + 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_Complex_Type (Rti) then + B_Ctxt := Ctxt; + else + B_Ctxt := N_Ctxt; + end if; + Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), B_Ctxt); + end; + when Ghdl_Rtik_Type_Array => + declare + Arr : Ghdl_Rtin_Type_Array_Acc; + begin + Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti); + Create_String_Id (Arr.Name); + Create_Type (Arr.Element, N_Ctxt); + for I in 1 .. Arr.Nbr_Dim loop + Create_Type (Arr.Indexes (I - 1), N_Ctxt); + end loop; + end; + when Ghdl_Rtik_Subtype_Scalar => + declare + Sub : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); + Create_String_Id (Sub.Name); + Create_Type (Sub.Basetype, N_Ctxt); + end; + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 + | Ghdl_Rtik_Type_F64 => + declare + Base : Ghdl_Rtin_Type_Scalar_Acc; + begin + Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti); + Create_String_Id (Base.Name); + end; + when Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 => + declare + Base : Ghdl_Rtin_Type_Physical_Acc; + Unit_Name : Ghdl_C_String; + begin + Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Create_String_Id (Base.Name); + for I in 1 .. Base.Nbr loop + Unit_Name := + Rtis_Utils.Get_Physical_Unit_Name (Base.Units (I - 1)); + Create_String_Id (Unit_Name); + end loop; + end; + when Ghdl_Rtik_Type_Record => + declare + Rec : Ghdl_Rtin_Type_Record_Acc; + El : Ghdl_Rtin_Element_Acc; + begin + Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti); + Create_String_Id (Rec.Name); + for I in 1 .. Rec.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); + Create_String_Id (El.Name); + Create_Type (El.Eltype, N_Ctxt); + end loop; + end; + when others => + Internal_Error ("wave.create_type"); +-- Internal_Error ("wave.create_type: does not handle " & +-- Ghdl_Rtik'Image (Rti.Kind)); + end case; + + -- Then, create the type. + Add_Type (Rti, N_Ctxt); + end Create_Type; + + procedure Create_Object_Type (Obj : VhpiHandleT) + is + Obj_Type : VhpiHandleT; + Error : AvhpiErrorT; + Rti : Ghdl_Rti_Access; + begin + -- Extract type of the signal. + Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Rti := Avhpi_Get_Rti (Obj_Type); + Create_Type (Rti, Avhpi_Get_Context (Obj_Type)); + + -- The the signal type is an unconstrained array, also put the object + -- in the type AVL. + -- The real type will be written to the file. + if Rti.Kind = Ghdl_Rtik_Type_Array then + Add_Type (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj)); + end if; + end Create_Object_Type; + + procedure Write_Object_Type (Obj : VhpiHandleT) + is + Obj_Type : VhpiHandleT; + Error : AvhpiErrorT; + Rti : Ghdl_Rti_Access; + begin + -- Extract type of the signal. + Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Rti := Avhpi_Get_Rti (Obj_Type); + if Rti.Kind = Ghdl_Rtik_Type_Array then + Write_Type_Id (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj)); + else + Write_Type_Id (Rti, Avhpi_Get_Context (Obj_Type)); + end if; + end Write_Object_Type; + + procedure Create_Generate_Type (Gen : VhpiHandleT) + is + Iterator : VhpiHandleT; + Error : AvhpiErrorT; + begin + -- Extract the iterator. + Vhpi_Handle (VhpiIterScheme, Gen, Iterator, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Create_Object_Type (Iterator); + end Create_Generate_Type; + + procedure Write_Generate_Type_And_Value (Gen : VhpiHandleT) + is + Iter : VhpiHandleT; + Iter_Type : VhpiHandleT; + Error : AvhpiErrorT; + Addr : Address; + Mode : Mode_Type; + Rti : Ghdl_Rti_Access; + begin + -- Extract the iterator. + Vhpi_Handle (VhpiIterScheme, Gen, Iter, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Write_Object_Type (Iter); + + Vhpi_Handle (VhpiSubtype, Iter, Iter_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Rti := Avhpi_Get_Rti (Iter_Type); + Addr := Avhpi_Get_Address (Iter); + + case Get_Base_Type (Rti).Kind is + when Ghdl_Rtik_Type_B1 => + Mode := Mode_B1; + when Ghdl_Rtik_Type_E8 => + Mode := Mode_E8; + when Ghdl_Rtik_Type_E32 => + Mode := Mode_E32; + when Ghdl_Rtik_Type_I32 => + Mode := Mode_I32; + when Ghdl_Rtik_Type_I64 => + Mode := Mode_I64; + when Ghdl_Rtik_Type_F64 => + Mode := Mode_F64; + when others => + Internal_Error ("bad iterator type"); + end case; + Write_Value (To_Ghdl_Value_Ptr (Addr).all, Mode); + end Write_Generate_Type_And_Value; + + type Step_Type is (Step_Name, Step_Hierarchy); + + Nbr_Scopes : Natural := 0; + Nbr_Scope_Signals : Natural := 0; + Nbr_Dumped_Signals : Natural := 0; + + -- This is only valid during write_hierarchy. + function Get_Signal_Number (Sig : Ghdl_Signal_Ptr) return Natural + is + function To_Integer_Address is new Ada.Unchecked_Conversion + (Ghdl_Signal_Ptr, Integer_Address); + begin + return Natural (To_Integer_Address (Sig.Alink)); + end Get_Signal_Number; + + procedure Write_Signal_Number (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param_Type : Natural) + is + pragma Unreferenced (Val_Name); + pragma Unreferenced (Val_Type); + pragma Unreferenced (Param_Type); + + Num : Natural; + + function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion + (Source => Integer_Address, Target => Ghdl_Signal_Ptr); + Sig : Ghdl_Signal_Ptr; + begin + -- Convert to signal. + Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); + + -- Get signal number. + Num := Get_Signal_Number (Sig); + + -- If the signal number is 0, then assign a valid signal number. + if Num = 0 then + Nbr_Dumped_Signals := Nbr_Dumped_Signals + 1; + Sig.Alink := To_Ghdl_Signal_Ptr + (Integer_Address (Nbr_Dumped_Signals)); + Num := Nbr_Dumped_Signals; + end if; + + -- Do the real job: write the signal number. + Wave_Put_ULEB128 (Ghdl_E32 (Num)); + end Write_Signal_Number; + + procedure Foreach_Scalar_Signal_Number is new + Grt.Rtis_Utils.Foreach_Scalar (Param_Type => Natural, + Process => Write_Signal_Number); + + procedure Write_Signal_Numbers (Decl : VhpiHandleT) + is + Ctxt : Rti_Context; + Sig : Ghdl_Rtin_Object_Acc; + begin + Ctxt := Avhpi_Get_Context (Decl); + 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, 0); + end Write_Signal_Numbers; + + procedure Write_Hierarchy_El (Decl : VhpiHandleT) + is + Mode2hie : constant array (VhpiModeT) of Unsigned_8 := + (VhpiErrorMode => Ghw_Hie_Signal, + VhpiInMode => Ghw_Hie_Port_In, + VhpiOutMode => Ghw_Hie_Port_Out, + VhpiInoutMode => Ghw_Hie_Port_Inout, + VhpiBufferMode => Ghw_Hie_Port_Buffer, + VhpiLinkageMode => Ghw_Hie_Port_Linkage); + V : Unsigned_8; + begin + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK => + V := Mode2hie (Vhpi_Get_Mode (Decl)); + when VhpiSigDeclK => + V := Ghw_Hie_Signal; + when VhpiForGenerateK => + V := Ghw_Hie_Generate_For; + when VhpiIfGenerateK => + V := Ghw_Hie_Generate_If; + when VhpiBlockStmtK => + V := Ghw_Hie_Block; + when VhpiCompInstStmtK => + V := Ghw_Hie_Instance; + when VhpiProcessStmtK => + V := Ghw_Hie_Process; + when VhpiPackInstK => + V := Ghw_Hie_Package; + when VhpiRootInstK => + V := Ghw_Hie_Instance; + when others => + --raise Program_Error; + Internal_Error ("write_hierarchy_el"); + end case; + Wave_Put_Byte (V); + Write_String_Id (Avhpi_Get_Base_Name (Decl)); + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK + | VhpiSigDeclK => + Write_Object_Type (Decl); + Write_Signal_Numbers (Decl); + when VhpiForGenerateK => + Write_Generate_Type_And_Value (Decl); + when others => + null; + end case; + end Write_Hierarchy_El; + + -- Create a hierarchy block. + procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type); + + procedure Wave_Put_Hierarchy_1 (Inst : VhpiHandleT; Step : Step_Type) + is + Decl_It : VhpiHandleT; + Decl : VhpiHandleT; + Error : AvhpiErrorT; + begin + Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + -- Extract signals. + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK + | VhpiSigDeclK => + case Step is + when Step_Name => + Create_String_Id (Avhpi_Get_Base_Name (Decl)); + Nbr_Scope_Signals := Nbr_Scope_Signals + 1; + Create_Object_Type (Decl); + when Step_Hierarchy => + Write_Hierarchy_El (Decl); + end case; + --Wave_Put_Name (Decl); + --Wave_Newline; + when others => + null; + end case; + end loop; + + -- No sub-scopes for packages. + if Vhpi_Get_Kind (Inst) = VhpiPackInstK then + return; + end if; + + -- Extract sub-scopes. + Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Nbr_Scopes := Nbr_Scopes + 1; + + case Vhpi_Get_Kind (Decl) is + when VhpiIfGenerateK + | VhpiForGenerateK + | VhpiBlockStmtK + | VhpiCompInstStmtK => + Wave_Put_Hierarchy_Block (Decl, Step); + when VhpiProcessStmtK => + case Step is + when Step_Name => + Create_String_Id (Avhpi_Get_Base_Name (Decl)); + when Step_Hierarchy => + Write_Hierarchy_El (Decl); + end case; + when others => + Internal_Error ("wave_put_hierarchy_1"); +-- Wave_Put ("unknown "); +-- Wave_Put (VhpiClassKindT'Image (Vhpi_Get_Kind (Decl))); +-- Wave_Newline; + end case; + end loop; + end Wave_Put_Hierarchy_1; + + procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type) + is + begin + case Step is + when Step_Name => + Create_String_Id (Avhpi_Get_Base_Name (Inst)); + if Vhpi_Get_Kind (Inst) = VhpiForGenerateK then + Create_Generate_Type (Inst); + end if; + when Step_Hierarchy => + Write_Hierarchy_El (Inst); + end case; + + Wave_Put_Hierarchy_1 (Inst, Step); + + if Step = Step_Hierarchy then + Wave_Put_Byte (Ghw_Hie_Eos); + end if; + end Wave_Put_Hierarchy_Block; + + procedure Wave_Put_Hierarchy (Root : VhpiHandleT; Step : Step_Type) + is + Pack_It : VhpiHandleT; + Pack : VhpiHandleT; + Error : AvhpiErrorT; + begin + -- First packages. + Get_Package_Inst (Pack_It); + loop + Vhpi_Scan (Pack_It, Pack, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Wave_Put_Hierarchy_Block (Pack, Step); + end loop; + + -- Then top entity. + Wave_Put_Hierarchy_Block (Root, Step); + end Wave_Put_Hierarchy; + + procedure Disp_Str_AVL (Str : AVL_Nid; Indent : Natural) + is + begin + if Str = AVL_Nil then + return; + end if; + Disp_Str_AVL (Str_AVL.Table (Str).Left, Indent + 1); + for I in 1 .. Indent loop + Wave_Putc (' '); + end loop; + Wave_Puts (Str_Table.Table (Str_AVL.Table (Str).Val)); +-- Wave_Putc ('('); +-- Put_I32 (Wave_Stream, Ghdl_I32 (Str)); +-- Wave_Putc (')'); +-- Put_I32 (Wave_Stream, Get_Height (Str)); + Wave_Newline; + Disp_Str_AVL (Str_AVL.Table (Str).Right, Indent + 1); + end Disp_Str_AVL; + + procedure Write_Strings + is + begin +-- Wave_Put ("AVL height: "); +-- Put_I32 (Wave_Stream, Ghdl_I32 (Check_AVL (Str_Root))); +-- Wave_Newline; + Wave_Put ("strings length: "); + Put_I32 (Wave_Stream, Ghdl_I32 (Strings_Len)); + Wave_Newline; + Disp_Str_AVL (AVL_Root, 0); + fflush (Wave_Stream); + end Write_Strings; + + pragma Unreferenced (Write_Strings); + + procedure Freeze_Strings + is + type Str_Table1_Type is array (1 .. Str_Table.Last) of Ghdl_C_String; + type Str_Table1_Acc is access Str_Table1_Type; + Idx : AVL_Value; + Table1 : Str_Table1_Acc; + + procedure Free is new Ada.Unchecked_Deallocation + (Str_Table1_Type, Str_Table1_Acc); + + procedure Store_Strings (N : AVL_Nid) is + begin + if N = AVL_Nil then + return; + end if; + Store_Strings (Str_AVL.Table (N).Left); + Table1 (Idx) := Str_Table.Table (Str_AVL.Table (N).Val); + Idx := Idx + 1; + Store_Strings (Str_AVL.Table (N).Right); + end Store_Strings; + begin + Table1 := new Str_Table1_Type; + Idx := 1; + Store_Strings (AVL_Root); + Str_Table.Release; + Str_AVL.Free; + for I in Table1.all'Range loop + Str_Table.Table (I) := Table1 (I); + end loop; + Free (Table1); + end Freeze_Strings; + + procedure Write_Strings_Compress + is + Last : Ghdl_C_String; + V : Ghdl_C_String; + L : Natural; + L1 : Natural; + begin + Wave_Section ("STR" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I32 (Ghdl_I32 (Str_Table.Last)); + Wave_Put_I32 (Ghdl_I32 (Strings_Len)); + for I in Str_Table.First .. Str_Table.Last loop + V := Str_Table.Table (I); + if I = Str_Table.First then + L := 1; + else + Last := Str_Table.Table (I - 1); + + for I in Positive loop + if V (I) /= Last (I) then + L := I; + exit; + end if; + end loop; + L1 := L - 1; + loop + if L1 >= 32 then + Wave_Put_Byte (Unsigned_8 (L1 mod 32) + 16#80#); + else + Wave_Put_Byte (Unsigned_8 (L1 mod 32)); + end if; + L1 := L1 / 32; + exit when L1 = 0; + end loop; + end if; + + if Boolean'(False) then + Put ("string "); + Put_I32 (stdout, Ghdl_I32 (I)); + Put (": "); + Put (V); + New_Line; + end if; + + loop + exit when V (L) = NUL; + Wave_Putc (V (L)); + L := L + 1; + end loop; + end loop; + -- Last string length. + Wave_Put_Byte (0); + -- End marker. + Wave_Put ("EOS" & NUL); + end Write_Strings_Compress; + + procedure Write_Range (Rti : Ghdl_Rti_Access; Rng : Ghdl_Range_Ptr) + is + Kind : Ghdl_Rtik; + begin + Kind := Rti.Kind; + if Kind = Ghdl_Rtik_Subtype_Scalar then + Kind := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype.Kind; + end if; + case Kind is + when Ghdl_Rtik_Type_B1 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.B1.Dir) * 16#80#); + Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Left)); + Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Right)); + when Ghdl_Rtik_Type_E8 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.E8.Dir) * 16#80#); + Wave_Put_Byte (Unsigned_8 (Rng.E8.Left)); + Wave_Put_Byte (Unsigned_8 (Rng.E8.Right)); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_P32 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.I32.Dir) * 16#80#); + Wave_Put_SLEB128 (Rng.I32.Left); + Wave_Put_SLEB128 (Rng.I32.Right); + when Ghdl_Rtik_Type_P64 + | Ghdl_Rtik_Type_I64 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.P64.Dir) * 16#80#); + Wave_Put_LSLEB128 (Rng.P64.Left); + Wave_Put_LSLEB128 (Rng.P64.Right); + when Ghdl_Rtik_Type_F64 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.F64.Dir) * 16#80#); + Wave_Put_F64 (Rng.F64.Left); + Wave_Put_F64 (Rng.F64.Right); + when others => + Internal_Error ("waves.write_range: unhandled kind"); + --Internal_Error ("waves.write_range: unhandled kind " + -- & Ghdl_Rtik'Image (Kind)); + end case; + end Write_Range; + + procedure Write_Types + is + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + begin + Wave_Section ("TYP" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I32 (Ghdl_I32 (Types_Table.Last)); + for I in Types_Table.First .. Types_Table.Last loop + Rti := Types_Table.Table (I).Type_Rti; + Ctxt := Types_Table.Table (I).Context; + + if Rti.Kind = Ghdl_Rtik_Signal or Rti.Kind = Ghdl_Rtik_Port then + declare + Obj_Rti : constant Ghdl_Rtin_Object_Acc := + To_Ghdl_Rtin_Object_Acc (Rti); + Arr : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type); + Addr : Ghdl_Uc_Array_Acc; + begin + Wave_Put_Byte (Ghdl_Rtik'Pos (Ghdl_Rtik_Subtype_Array)); + Write_String_Id (null); + Write_Type_Id (Obj_Rti.Obj_Type, Ctxt); + Addr := To_Ghdl_Uc_Array_Acc + (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); + declare + Rngs : Ghdl_Range_Array (0 .. Arr.Nbr_Dim - 1); + begin + Bound_To_Range (Addr.Bounds, Arr, Rngs); + for I in Rngs'Range loop + Write_Range (Arr.Indexes (I), Rngs (I)); + end loop; + end; + end; + else + -- Kind. + Wave_Put_Byte (Ghdl_Rtik'Pos (Rti.Kind)); + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 => + declare + Enum : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Write_String_Id (Enum.Name); + Wave_Put_ULEB128 (Ghdl_E32 (Enum.Nbr)); + for I in 1 .. Enum.Nbr loop + Write_String_Id (Enum.Names (I - 1)); + end loop; + end; + when Ghdl_Rtik_Subtype_Array => + declare + Arr : Ghdl_Rtin_Subtype_Array_Acc; + begin + Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Write_String_Id (Arr.Name); + Write_Type_Id (To_Ghdl_Rti_Access (Arr.Basetype), Ctxt); + declare + Rngs : Ghdl_Range_Array + (0 .. Arr.Basetype.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt), + Arr.Basetype, Rngs); + for I in Rngs'Range loop + Write_Range (Arr.Basetype.Indexes (I), Rngs (I)); + end loop; + end; + end; + when Ghdl_Rtik_Type_Array => + declare + Arr : Ghdl_Rtin_Type_Array_Acc; + begin + Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti); + Write_String_Id (Arr.Name); + Write_Type_Id (Arr.Element, Ctxt); + Wave_Put_ULEB128 (Ghdl_E32 (Arr.Nbr_Dim)); + for I in 1 .. Arr.Nbr_Dim loop + Write_Type_Id (Arr.Indexes (I - 1), Ctxt); + end loop; + end; + when Ghdl_Rtik_Type_Record => + declare + Rec : Ghdl_Rtin_Type_Record_Acc; + El : Ghdl_Rtin_Element_Acc; + begin + Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti); + Write_String_Id (Rec.Name); + Wave_Put_ULEB128 (Ghdl_E32 (Rec.Nbrel)); + for I in 1 .. Rec.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); + Write_String_Id (El.Name); + Write_Type_Id (El.Eltype, Ctxt); + end loop; + end; + when Ghdl_Rtik_Subtype_Scalar => + declare + Sub : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); + Write_String_Id (Sub.Name); + Write_Type_Id (Sub.Basetype, Ctxt); + Write_Range + (Sub.Basetype, + To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth, + Sub.Range_Loc, + Ctxt))); + end; + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 + | Ghdl_Rtik_Type_F64 => + declare + Base : Ghdl_Rtin_Type_Scalar_Acc; + begin + Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti); + Write_String_Id (Base.Name); + end; + when Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 => + declare + Base : Ghdl_Rtin_Type_Physical_Acc; + Unit : Ghdl_Rti_Access; + begin + Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Write_String_Id (Base.Name); + Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr)); + for I in 1 .. Base.Nbr loop + Unit := Base.Units (I - 1); + Write_String_Id + (Rtis_Utils.Get_Physical_Unit_Name (Unit)); + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + Wave_Put_LSLEB128 + (To_Ghdl_Rtin_Unit64_Acc (Unit).Value); + when Ghdl_Rtik_Unitptr => + case Rti.Kind is + when Ghdl_Rtik_Type_P64 => + Wave_Put_LSLEB128 + (To_Ghdl_Rtin_Unitptr_Acc (Unit). + Addr.I64); + when Ghdl_Rtik_Type_P32 => + Wave_Put_SLEB128 + (To_Ghdl_Rtin_Unitptr_Acc (Unit). + Addr.I32); + when others => + Internal_Error + ("wave.write_types(P32/P64-1)"); + end case; + when others => + Internal_Error + ("wave.write_types(P32/P64-2)"); + end case; + end loop; + end; + when others => + Internal_Error ("wave.write_types"); + -- Internal_Error ("wave.write_types: does not handle " & + -- Ghdl_Rtik'Image (Rti.Kind)); + end case; + end if; + end loop; + Wave_Put_Byte (0); + end Write_Types; + + procedure Write_Known_Types + is + use Grt.Rtis_Types; + + Boolean_Type_Id : AVL_Nid; + Bit_Type_Id : AVL_Nid; + Std_Ulogic_Type_Id : AVL_Nid; + + function Search_Type_Id (Rti : Ghdl_Rti_Access) return AVL_Nid + is + Ctxt : Rti_Context; + Tid : AVL_Nid; + begin + Find_Type (Rti, Null_Context, Ctxt, Tid); + return Tid; + end Search_Type_Id; + begin + Search_Types_RTI; + + Boolean_Type_Id := Search_Type_Id (Std_Standard_Boolean_RTI_Ptr); + + Bit_Type_Id := Search_Type_Id (Std_Standard_Bit_RTI_Ptr); + + if Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr /= null then + Std_Ulogic_Type_Id := Search_Type_Id + (Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr); + else + Std_Ulogic_Type_Id := AVL_Nil; + end if; + + Wave_Section ("WKT" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + + if Boolean_Type_Id /= AVL_Nil then + Wave_Put_Byte (1); + Write_Type_Id (Boolean_Type_Id); + end if; + + if Bit_Type_Id /= AVL_Nil then + Wave_Put_Byte (2); + Write_Type_Id (Bit_Type_Id); + end if; + + if Std_Ulogic_Type_Id /= AVL_Nil then + Wave_Put_Byte (3); + Write_Type_Id (Std_Ulogic_Type_Id); + end if; + + Wave_Put_Byte (0); + end Write_Known_Types; + + -- Table of signals to be dumped. + package Dump_Table is new Grt.Table + (Table_Component_Type => Ghdl_Signal_Ptr, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 32); + + function Get_Dump_Entry (N : Natural) return Ghdl_Signal_Ptr is + begin + return Dump_Table.Table (N); + end Get_Dump_Entry; + + pragma Unreferenced (Get_Dump_Entry); + + procedure Write_Hierarchy (Root : VhpiHandleT) + is + N : Natural; + begin + -- Check Alink is 0. + for I in Sig_Table.First .. Sig_Table.Last loop + if Sig_Table.Table (I).Alink /= null then + Internal_Error ("wave.write_hierarchy"); + end if; + end loop; + + Wave_Section ("HIE" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I32 (Ghdl_I32 (Nbr_Scopes)); + Wave_Put_I32 (Ghdl_I32 (Nbr_Scope_Signals)); + Wave_Put_I32 (Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1)); + Wave_Put_Hierarchy (Root, Step_Hierarchy); + Wave_Put_Byte (0); + + Dump_Table.Set_Last (Nbr_Dumped_Signals); + for I in Dump_Table.First .. Dump_Table.Last loop + Dump_Table.Table (I) := null; + end loop; + + -- Save and clear. + for I in Sig_Table.First .. Sig_Table.Last loop + N := Get_Signal_Number (Sig_Table.Table (I)); + if N /= 0 then + if Dump_Table.Table (N) /= null then + Internal_Error ("wave.write_hierarchy(2)"); + end if; + Dump_Table.Table (N) := Sig_Table.Table (I); + Sig_Table.Table (I).Alink := null; + end if; + end loop; + end Write_Hierarchy; + + procedure Write_Signal_Value (Sig : Ghdl_Signal_Ptr) is + begin + -- FIXME: for some signals, the significant value is the driving value! + Write_Value (Sig.Value, Sig.Mode); + end Write_Signal_Value; + + procedure Write_Snapshot is + begin + Wave_Section ("SNP" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I64 (Ghdl_I64 (Cycle_Time)); + + for I in Dump_Table.First .. Dump_Table.Last loop + Write_Signal_Value (Dump_Table.Table (I)); + end loop; + Wave_Put ("ESN" & NUL); + end Write_Snapshot; + + procedure Wave_Cycle; + + -- Called after elaboration. + procedure Wave_Start + is + Root : VhpiHandleT; + begin + -- Do nothing if there is no VCD file to generate. + if Wave_Stream = NULL_Stream then + return; + end if; + + Write_File_Header; + + -- FIXME: write infos + -- * date + -- * timescale + -- * design name ? + -- ... + + -- Put hierarchy. + Get_Root_Inst (Root); + -- Vcd_Search_Packages; + Wave_Put_Hierarchy (Root, Step_Name); + + Freeze_Strings; + + -- Register_Cycle_Hook (Vcd_Cycle'Access); + Write_Strings_Compress; + Write_Types; + Write_Known_Types; + Write_Hierarchy (Root); + + -- End of header mark. + Wave_Section ("EOH" & NUL); + + Write_Snapshot; + + Register_Cycle_Hook (Wave_Cycle'Access); + + fflush (Wave_Stream); + end Wave_Start; + + Wave_Time : Std_Time := 0; + In_Cyc : Boolean := False; + + procedure Wave_Close_Cyc + is + begin + Wave_Put_LSLEB128 (-1); + Wave_Put ("ECY" & NUL); + In_Cyc := False; + end Wave_Close_Cyc; + + procedure Wave_Cycle + is + Diff : Std_Time; + Sig : Ghdl_Signal_Ptr; + Last : Natural; + begin + if not In_Cyc then + Wave_Section ("CYC" & NUL); + Wave_Put_I64 (Ghdl_I64 (Cycle_Time)); + In_Cyc := True; + else + Diff := Cycle_Time - Wave_Time; + Wave_Put_LSLEB128 (Ghdl_I64 (Diff)); + end if; + Wave_Time := Cycle_Time; + + -- Dump signals. + Last := 0; + for I in Dump_Table.First .. Dump_Table.Last loop + Sig := Dump_Table.Table (I); + if Sig.Flags.Cyc_Event then + Wave_Put_ULEB128 (Ghdl_U32 (I - Last)); + Last := I; + Write_Signal_Value (Sig); + Sig.Flags.Cyc_Event := False; + end if; + end loop; + Wave_Put_Byte (0); + end Wave_Cycle; + + -- Called at the end of the simulation. + procedure Wave_End is + begin + if Wave_Stream = NULL_Stream then + return; + end if; + if In_Cyc then + Wave_Close_Cyc; + end if; + Wave_Write_Directory; + fflush (Wave_Stream); + end Wave_End; + + Wave_Hooks : aliased constant Hooks_Type := + (Option => Wave_Option'Access, + Help => Wave_Help'Access, + Init => Wave_Init'Access, + Start => Wave_Start'Access, + Finish => Wave_End'Access); + + procedure Register is + begin + Register_Hooks (Wave_Hooks'Access); + end Register; +end Grt.Waves; diff --git a/src/translate/grt/grt-waves.ads b/src/translate/grt/grt-waves.ads new file mode 100644 index 0000000..72d7ea6 --- /dev/null +++ b/src/translate/grt/grt-waves.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - wave dumper (GHW) module. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +package Grt.Waves is + procedure Register; +end Grt.Waves; diff --git a/src/translate/grt/grt-zlib.ads b/src/translate/grt/grt-zlib.ads new file mode 100644 index 0000000..9dfee36 --- /dev/null +++ b/src/translate/grt/grt-zlib.ads @@ -0,0 +1,47 @@ +-- GHDL Run Time (GRT) - Zlib binding. +-- Copyright (C) 2005 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with System; use System; +with Grt.C; use Grt.C; + +package Grt.Zlib is + pragma Linker_Options ("-lz"); + + type gzFile is new System.Address; + + NULL_gzFile : constant gzFile := gzFile (System'To_Address (0)); + + function gzputc (File : gzFile; C : int) return int; + pragma Import (C, gzputc); + + function gzwrite (File : gzFile; Buf : voids; Len : int) return int; + pragma Import (C, gzwrite); + + function gzopen (Path : chars; Mode : chars) return gzFile; + pragma Import (C, gzopen); + + procedure gzclose (File : gzFile); + pragma Import (C, gzclose); +end Grt.Zlib; diff --git a/src/translate/grt/grt.adc b/src/translate/grt/grt.adc new file mode 100644 index 0000000..f228499 --- /dev/null +++ b/src/translate/grt/grt.adc @@ -0,0 +1,46 @@ +-- GHDL Run Time (GRT) - Configuration pragmas. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +-- The GRT library is built with a lot of restrictions. +-- The purpose of these restrictions (mainly No_Run_Time) is not to link with +-- the GNAT run time library. The user does not need to download or compile +-- it. +-- +-- However, GRT works without these restrictions. If you want to use GRT +-- in Ada, you may compile GRT without these restrictions (remove the -gnatec +-- flag). +-- +-- This files is *not* names gnat.adc, in order to ease the possibility of +-- not using it. +pragma Restrictions (No_Exception_Handlers); +--pragma restrictions (No_Exceptions); +pragma Restrictions (No_Secondary_Stack); +--pragma Restrictions (No_Elaboration_Code); +pragma Restrictions (No_Io); +pragma restrictions (no_dependence => Ada.Tags); +pragma restrictions (no_dependence => GNAT); +pragma Restrictions (Max_Tasks => 0); +pragma Restrictions (No_Implicit_Heap_Allocations); +pragma No_Run_Time; diff --git a/src/translate/grt/grt.ads b/src/translate/grt/grt.ads new file mode 100644 index 0000000..9727d04 --- /dev/null +++ b/src/translate/grt/grt.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - Top of hierarchy. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +package Grt is + pragma Pure (Grt); +end Grt; diff --git a/src/translate/grt/grt.ver b/src/translate/grt/grt.ver new file mode 100644 index 0000000..031c207 --- /dev/null +++ b/src/translate/grt/grt.ver @@ -0,0 +1,25 @@ +{ + global: +vpi_free_object; +vpi_get; +vpi_get_str; +vpi_get_time; +vpi_get_value; +vpi_get_vlog_info; +vpi_handle; +vpi_handle_by_index; +vpi_iterate; +vpi_mcd_close; +vpi_mcd_name; +vpi_mcd_open; +vpi_put_value; +vpi_register_cb; +vpi_register_systf; +vpi_remove_cb; +vpi_scan; +vpi_vprintf; +vpi_printf; + local: + *; +}; + diff --git a/src/translate/grt/main.adb b/src/translate/grt/main.adb new file mode 100644 index 0000000..5de3794 --- /dev/null +++ b/src/translate/grt/main.adb @@ -0,0 +1,32 @@ +-- GHDL Run Time (GRT) - C-like entry point. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Ghdl_Main; + +function Main (Argc : Integer; Argv : System.Address) + return Integer +is +begin + return Ghdl_Main (Argc, Argv); +end Main; diff --git a/src/translate/grt/main.ads b/src/translate/grt/main.ads new file mode 100644 index 0000000..f7c4142 --- /dev/null +++ b/src/translate/grt/main.ads @@ -0,0 +1,34 @@ +-- GHDL Run Time (GRT) - C-like entry point. +-- Copyright (C) 2002 - 2014 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. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +-- In the usual case of a standalone executable, this file defines the +-- standard entry point, ie the main() function. +-- +-- However, as explained in the manual, the user can use its own main() +-- function, and calls the ghdl entry point ghdl_main. +with System; + +function Main (Argc : Integer; Argv : System.Address) return Integer; +pragma Export (C, Main, "main"); diff --git a/src/translate/mcode/Makefile.in b/src/translate/mcode/Makefile.in new file mode 100644 index 0000000..beb450a --- /dev/null +++ b/src/translate/mcode/Makefile.in @@ -0,0 +1,54 @@ +PREFIX=/usr/local +target=i686-pc-linux-gnu + +CFLAGS=-O +GNATFLAGS=$(CFLAGS) -gnatn + +GRT_FLAGS=$(CFLAGS) + +all: ghdl_mcode std.v93 std.v87 ieee.v93 ieee.v87 synopsys.v93 synopsys.v87 mentor.v93 + + +GRTSRCDIR=grt + +####grt Makefile.inc + +ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) mmap_binding.o force + gnatmake -aIghdldrv -aIghdl -aIortho -aIgrt $(GNATFLAGS) ghdl_mcode $(GNAT_BARGS) -largs mmap_binding.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(GRT_EXTRA_LIB) -Wl,--version-script=$(GRTSRCDIR)/grt.ver -Wl,--export-dynamic + +mmap_binding.o: ortho/mmap_binding.c + $(CC) -c -g -o $@ $< + +default_pathes.ads: Makefile + echo "-- DO NOT EDIT" > tmp-dpathes.ads + echo "-- This file is created by Makefile" >> tmp-dpathes.ads + echo "package Default_Pathes is" >> tmp-dpathes.ads + echo " Prefix : constant String :=">> tmp-dpathes.ads + echo " \"$(PREFIX)/lib/ghdl/\";" >> tmp-dpathes.ads + echo "end Default_Pathes;" >> tmp-dpathes.ads + if test -r $@ && cmp tmp-dpathes.ads $@; then \ + echo "$@ unchanged"; \ + else \ + mv tmp-dpathes.ads $@; \ + fi + $(RM) tmp-dpathes.ads + +force: + +LIB93_DIR:=./lib/v93 +LIB87_DIR:=./lib/v87 +LIBSRC_DIR:=./libraries +ANALYZE=../../../ghdl_mcode -a --ieee=none +REL_DIR=../../.. +VHDLLIBS_COPY_OBJS:=no +CP=cp +LN=ln -s + +./lib: + mkdir $@ + +$(LIB93_DIR) $(LIB87_DIR): ./lib + mkdir $@ + + +####libraries Makefile.inc diff --git a/src/translate/mcode/README b/src/translate/mcode/README new file mode 100644 index 0000000..a10cd6e --- /dev/null +++ b/src/translate/mcode/README @@ -0,0 +1,47 @@ +This is the README from the source distribution of GHDL. + +To get the binary distribution or more information, go to http://ghdl.free.fr + +Copyright: +********** +GHDL is copyright (c) 2002, 2003, 2004, 2005 Tristan Gingold. +See the GHDL manual for more details. + +This program 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 +(at your option) any later version. + +This program 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 this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. + + +Building GHDL from sources for Windows: +*************************************** + +Note: this was tested with Windows XP SP2 familly edition. + +Note: If you want to create the installer, GHDL should be built on a +FAT partition. NSIS rounds files date to be FAT compliant (seconds are always +even) and because GHDL stores dates, the files date must not be modified. + +Required: +* the Ada95 GNAT compiler (GNAT GPL 2005 is known to work). +* NSIS to create the installer. + +Unzip, +edit winbuild to use correct path for makensis, +run winbuild. + +The installer is in the windows directory. + +Send bugs and comments on http://gna.org/project/ghdl + +Tristan Gingold. diff --git a/src/translate/mcode/dist.sh b/src/translate/mcode/dist.sh new file mode 100755 index 0000000..cf24141 --- /dev/null +++ b/src/translate/mcode/dist.sh @@ -0,0 +1,506 @@ +#!/bin/sh + +# Script used to create tar balls. +# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +# +# GHDL is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any later +# version. +# +# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING. If not, write to the Free +# Software Foundation, 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. + +# Building a distribution: +# * update the 'version' variable in ../../Makefile +# * Regenerate version.ads: make -f ../../Makefile version.ads +# * Check NEWS, README and INSTALL files. +# * Check version and copyright years in doc/ghdl.texi, ghdlmain.adb +# * Check GCCVERSION below. +# * 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 +# * Run the testsuites: GHDL=ghdl ./testsuite.sh +# * Update website/index.html (./dist.sh website helps, rename .new) +# * upload (./dist upload) +# * CVS commit, tag + cd image. +# * remove previous version in /usr/local + +## DO NOT MODIFY this file while it is running... + +set -e + +# GTKWave version. +GTKWAVE_VERSION=1.3.72 + +# GHDL version (extracted from version.ads) +VERSION=`sed -n -e 's/.*GHDL \([0-9.a-z]*\) (.*/\1/p' ../../version.ads` + +CWD=`pwd` + +distdir=ghdl-$VERSION +tarfile=$distdir.tar +zipfile=$distdir.zip + +PREFIX=/usr/local +bindirname=ghdl-$VERSION-i686-pc-linux +TARINSTALL=$DISTDIR/$bindirname.tar.bz2 +VHDLDIR=$distdir/vhdl +DOWNLOAD_HTML=../../website/download.html +DESTDIR=$CWD/ +UNSTRIPDIR=${distdir}-unstripped + +PATH=/usr/gnat/bin:$PATH + +do_clean () +{ + rm -rf $distdir + mkdir $distdir + mkdir $distdir/ghdl + mkdir $distdir/ghdldrv + mkdir $distdir/libraries + mkdir $distdir/libraries/std $distdir/libraries/ieee + mkdir $distdir/libraries/vital95 $distdir/libraries/vital2000 + mkdir $distdir/libraries/synopsys $distdir/libraries/mentor + mkdir $distdir/grt + mkdir $distdir/grt/config + mkdir $distdir/ortho + mkdir $distdir/windows +} + +# Build Makefile +do_Makefile () +{ + sed -e "/^####libraries Makefile.inc/r ../../libraries/Makefile.inc" \ + -e "/^####grt Makefile.inc/r ../grt/Makefile.inc" \ + < Makefile.in > $distdir/Makefile +} + +# Copy (or link) sources files into $distdir +do_files () +{ +. ../gcc/dist-common.sh + +ortho_mcode_files=" +binary_file-elf.adb +binary_file-elf.ads +binary_file-memory.adb +binary_file-memory.ads +binary_file.adb +binary_file.ads +disa_x86.adb +disa_x86.ads +disassemble.ads +dwarf.ads +elf32.adb +elf32.ads +elf64.ads +elf_common.adb +elf_common.ads +elf_arch32.ads +elf_arch.ads +hex_images.adb +hex_images.ads +memsegs.ads +memsegs_mmap.ads +memsegs_mmap.adb +memsegs_c.c +ortho_code-abi.ads +ortho_code-binary.adb +ortho_code-binary.ads +ortho_code-consts.adb +ortho_code-consts.ads +ortho_code-debug.adb +ortho_code-debug.ads +ortho_code-decls.adb +ortho_code-decls.ads +ortho_code-disps.adb +ortho_code-disps.ads +ortho_code-dwarf.adb +ortho_code-dwarf.ads +ortho_code-exprs.adb +ortho_code-exprs.ads +ortho_code-flags.ads +ortho_code-opts.adb +ortho_code-opts.ads +ortho_code-types.adb +ortho_code-types.ads +ortho_code-sysdeps.adb +ortho_code-sysdeps.ads +ortho_code-x86-emits.adb +ortho_code-x86-emits.ads +ortho_code-x86-insns.adb +ortho_code-x86-insns.ads +ortho_code-x86-abi.adb +ortho_code-x86-abi.ads +ortho_code-x86-flags.ads +ortho_code-x86.adb +ortho_code-x86.ads +ortho_code.ads +ortho_code_main.adb +ortho_ident.adb +ortho_ident.ads +ortho_mcode.adb +ortho_mcode.ads +ortho_nodes.ads +" + +windows_files=" +compile.bat +complib.bat +default_pathes.ads +ghdl.nsi +windows_default_path.adb +windows_default_path.ads +ghdlfilter.adb +ortho_code-sysdeps.adb +grt-modules.adb +" + +drv_files=" +ghdlcomp.ads +ghdlcomp.adb +foreigns.ads +foreigns.adb +ghdlrun.adb +ghdlrun.ads +ghdl_mcode.adb +" + +for i in $cfiles; do ln -sf $CWD/../../$i $distdir/ghdl/$i; done +for i in $tfiles; do ln -sf $CWD/../$i $distdir/ghdl/$i; done + +ln -sf $CWD/../../doc/ghdl.texi $distdir/ghdl.texi + +for i in $ortho_files; do ln -sf $CWD/../../ortho/$i $distdir/ortho/$i; done + +for i in $ortho_mcode_files; do + ln -sf $CWD/../../ortho/mcode/$i $distdir/ortho/$i +done + +for i in $ghdl_files $drv_files; do + ln -sf $CWD/../ghdldrv/$i $distdir/ghdldrv/$i +done + +for i in $libraries_files; do + ln -sf $CWD/../../libraries/$i $distdir/libraries/$i +done + +for i in $grt_files; do + ln -sf $CWD/../grt/$i $distdir/grt/$i +done + +for i in $grt_config_files; do + ln -sf $CWD/../grt/config/$i $distdir/grt/config/$i +done + +for i in $windows_files; do + ln -sf $CWD/windows/$i $distdir/windows/$i +done + echo "!define VERSION \"$VERSION\"" > $distdir/windows/version.nsi + + + ln -sf $CWD/winbuild.bat $distdir/winbuild.bat + +makeinfo --html --no-split -o $distdir/windows/ghdl.htm $CWD/../../doc/ghdl.texi +} + +do_sources_dir () +{ + \rm -rf $distdir + mkdir $distdir + do_clean + do_Makefile + do_files + ln -sf ../../../COPYING $distdir +} + +# Create the tar of sources. +do_tar () +{ + do_sources_dir + tar cvhf $tarfile $distdir + bzip2 -f $tarfile + rm -rf $distdir +} + +# Create the zip of sources. +do_zip () +{ + do_sources_dir + zip -r $zipfile $distdir + rm -rf $distdir +} + +# Extract the source, configure and make. +do_compile () +{ + set -x + + do_update_gcc_sources; + + rm -rf $GCCDISTOBJ + mkdir $GCCDISTOBJ + cd $GCCDISTOBJ + ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX + make CFLAGS="-O -g" + make -C gcc vhdl.info + cd $CWD +} + +check_root () +{ + if [ $UID -ne 0 ]; then + echo "$0: you must be root"; + exit 1; + fi +} + +# Do a make install +do_compile2 () +{ + set -x + cd $GCCDISTOBJ + # Check the info file is not empty. + if [ -s gcc/doc/ghdl.info ]; then + echo "info file found" + else + echo "Error: ghdl.info not found". + exit 1; + fi + mkdir -p $DESTDIR/usr/local || true + make DESTDIR=$DESTDIR install + cd $CWD + if [ -d $UNSTRIPDIR ]; then + rm -rf $UNSTRIPDIR + fi + mkdir $UNSTRIPDIR + cp ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl $UNSTRIPDIR + chmod -w $UNSTRIPDIR/* + strip ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl +} + +# Create the tar file from the current installation. +do_tar_install () +{ + tar -C $DESTDIR -jcvf $TARINSTALL \ + ./$PREFIX/bin/ghdl ./$PREFIX/info/ghdl.info \ + ./$GCCLIBDIR/vhdl \ + ./$GCCLIBEXECDIR/ghdl1 +} + +do_extract_tar_install () +{ + check_root; + cd / + tar jxvf $TARINSTALL + cd $CWD +} + +# Create the tar file to be distributed. +do_tar_dist () +{ + rm -rf $bindirname + mkdir $bindirname + sed -e "s/@TARFILE@/$dir.tar/" < INSTALL > $bindirname/INSTALL + ln ../../COPYING $bindirname + ln $TARINSTALL $bindirname + tar cvf $bindirname.tar $bindirname +} + +# Remove the non-ghdl files of gcc in the current installation. +do_distclean_gcc () +{ + set -x + rm -f ${DESTDIR}${PREFIX}/bin/cpp ${DESTDIR}${PREFIX}/bin/gcc + rm -f ${DESTDIR}${PREFIX}/bin/gccbug ${DESTDIR}${PREFIX}/bin/gcov + rm -f ${DESTDIR}${PREFIX}/bin/${MACHINE}-gcc* + rm -f ${DESTDIR}${PREFIX}/info/cpp.info* + rm -f ${DESTDIR}${PREFIX}/info/cppinternals.info* + rm -f ${DESTDIR}${PREFIX}/info/gcc.info* + rm -f ${DESTDIR}${PREFIX}/info/gccinstall.info* + rm -f ${DESTDIR}${PREFIX}/info/gccint.info* + rm -f ${DESTDIR}${PREFIX}/lib/*.a ${DESTDIR}${PREFIX}/lib/*.so* + rm -rf ${DESTDIR}${PREFIX}/share + rm -rf ${DESTDIR}${PREFIX}/man + rm -rf ${DESTDIR}${PREFIX}/include + rm -f ${DESTDIR}${GCCLIBEXECDIR}/cc1 ${DESTDIR}${GCCLIBEXECDIR}/collect2 + rm -f ${DESTDIR}${GCCLIBEXECDIR}/cpp0 ${DESTDIR}${GCCLIBEXECDIR}/tradcpp0 + rm -f ${DESTDIR}${GCCLIBDIR}/*.o ${DESTDIR}$GCCLIBDIR/*.a + rm -f ${DESTDIR}${GCCLIBDIR}/specs + rm -rf ${DESTDIR}${GCCLIBDIR}/include + rm -rf ${DESTDIR}${GCCLIBDIR}/install-tools + rm -rf ${DESTDIR}${GCCLIBEXECDIR}/install-tools +} + +# Remove ghdl files in the current installation. +do_distclean_ghdl () +{ + check_root; + set -x + rm -f $PREFIX/bin/ghdl + rm -f $PREFIX/info/ghdl.info* + rm -f $GCCLIBEXECDIR/ghdl1 + rm -rf $GCCLIBDIR/vhdl +} + +# Build the source tar, and build the binaries. +do_dist_phase1 () +{ + do_sources; + do_compile; + do_compile2; + do_distclean_gcc; + do_tar_install; + do_tar_dist; + rm -rf ./$PREFIX +} + +# Install the binaries and create the binary tar. +do_dist_phase2 () +{ + check_root; + do_distclean_ghdl; + do_extract_tar_install; + echo "dist_phase2 success" +} + +# Create gtkwave patch +do_gtkwave_patch () +{ +# rm -rf gtkwave-patch + mkdir gtkwave-patch + diff -rc -x Makefile.in $GTKWAVE_BASE.orig $GTKWAVE_BASE | \ + sed -e "/^Only in/d" \ + > gtkwave-patch/gtkwave-$GTKWAVE_VERSION.diffs + cp ../grt/ghwlib.c ../grt/ghwlib.h $GTKWAVE_BASE/src/ghw.c gtkwave-patch + sed -e "s/VERSION/$GTKWAVE_VERSION/g" < README.gtkwave > gtkwave-patch/README + tar zcvf ../../website/gtkwave-patch.tgz gtkwave-patch + rm -rf gtkwave-patch +} + +# Update the index.html +# Update the doc +do_website () +{ + sed -e " +/SRC-HREF/ s/href=\".*\"/href=\"$tarfile.bz2\"/ +/BIN-HREF/ s/href=\".*\"/href=\"$bindirname.tar\"/ +/HISTORY/ a \\ + <tr>\\ + <td>$VERSION</td>\\ + <td>`date +'%b %e %Y'`</td>\\ + <td>$GCCVERSION</td>\\ + <td><a href=\"$tarfile.bz2\">$tarfile.bz2</a></td>\\ + <td><a href=\"$bindirname.tar\">\\ + $bindirname.tar</a></td>\\ + </tr> +" < $DOWNLOAD_HTML > "$DOWNLOAD_HTML".new + dir=../../website/ghdl + echo "Updating $dir" + rm -rf $dir + makeinfo --html -o $dir ../../doc/ghdl.texi +} + +# Do ftp commands to upload +do_upload () +{ +if tty -s; then + echo -n "Please, enter password: " + stty -echo + read pass + stty echo + echo +else + echo "$0: upload must be done from a tty" + exit 1; +fi +ftp -n <<EOF +open ftpperso.free.fr +user ghdl $pass +prompt +hash +bin +passive +put $tarfile.bz2 +put $bindirname.tar +put INSTALL +lcd ../../website +put NEWS +put index.html +put download.html +put features.html +put roadmap.html +put manual.html +put more.html +put links.html +put bug.html +put waveviewer.html +put gtkwave-patch.tgz +put favicon.ico +lcd ghdl +cd ghdl +mput \* +bye +EOF +} + +if [ $# -eq 0 ]; then + do_zip; +else + for i ; do + case $i in + clean) + do_clean ;; + Makefile|makefile) + do_Makefile ;; + files) + do_files ;; + sources) + do_sources_dir ;; + tar) + do_tar ;; + zip) + do_zip ;; + compile) + do_compile;; + update_gcc) + do_update_gcc_sources;; + compile2) + do_compile2;; + tar_install) + do_tar_install;; + tar_dist) + do_tar_dist;; + -v | --version | version) + echo $VERSION + exit 0 + ;; + website) + do_website;; + upload) + do_upload;; + distclean_gcc) + do_distclean_gcc;; + distclean_ghdl) + do_distclean_ghdl;; + dist_phase1) + do_dist_phase1;; + dist_phase2) + do_dist_phase2;; + gtkwave_patch) + do_gtkwave_patch;; + *) + echo "usage: $0 clean|Makefile|files|all" + exit 1 ;; + esac + done +fi diff --git a/src/translate/mcode/winbuild.bat b/src/translate/mcode/winbuild.bat new file mode 100644 index 0000000..8c28268 --- /dev/null +++ b/src/translate/mcode/winbuild.bat @@ -0,0 +1,18 @@ +call windows\compile
+if errorlevel 1 goto end
+
+call windows\complib
+if errorlevel 1 goto end
+
+gnatmake windows/ghdlversion -o windows/ghdlversion.exe
+windows\ghdlversion < ../../version.ads > windows/version.nsi
+
+"c:\Program Files\NSIS\makensis" windows\ghdl.nsi
+if errorlevel 1 goto end
+
+exit /b 0
+
+:end
+echo "Error during compilation"
+exit /b 1
+
diff --git a/src/translate/mcode/windows/compile.bat b/src/translate/mcode/windows/compile.bat new file mode 100644 index 0000000..c668ef0 --- /dev/null +++ b/src/translate/mcode/windows/compile.bat @@ -0,0 +1,24 @@ +mkdir build
+cd build
+
+rem Do the compilation
+set CFLAGS=-O -g
+gcc -c %CFLAGS% ../../grt/grt-cbinding.c
+gcc -c %CFLAGS% ../../grt/grt-cvpi.c
+gcc -c %CFLAGS% ../../grt/config/clock.c
+gcc -c %CFLAGS% ../../../ortho/mcode/memsegs_c.c
+gcc -c %CFLAGS% -DWITH_GNAT_RUN_TIME ../../grt/config/win32.c
+gnatmake %CFLAGS% -gnatn -aI../windows -aI../../.. -aI../.. -aI../../ghdldrv -aI../../../psl -aI../../grt -aI../../../ortho/mcode ghdl_mcode -aI../../../ortho -o ghdl.exe -largs grt-cbinding.o clock.o grt-cvpi.o memsegs_c.o win32.o -largs -Wl,--stack,8404992
+
+if errorlevel 1 goto failed
+
+strip ghdl.exe
+
+cd ..
+exit /b 0
+
+:failed
+echo "Compilation failed"
+cd ..
+exit /b 1
+
diff --git a/src/translate/mcode/windows/complib.bat b/src/translate/mcode/windows/complib.bat new file mode 100644 index 0000000..88a43ce --- /dev/null +++ b/src/translate/mcode/windows/complib.bat @@ -0,0 +1,68 @@ +set GHDL=ghdl
+
+cd build
+gnatmake -aI..\windows ghdlfilter
+cd ..
+
+set REL=..\..\..
+set LIBSRC=%REL%\..\..\libraries
+set STD_SRCS=textio textio_body
+set IEEE_SRCS=std_logic_1164 std_logic_1164_body numeric_std numeric_std-body numeric_bit numeric_bit-body
+set VITAL95_SRCS=vital_timing vital_timing_body vital_primitives vital_primitives_body
+set VITAL2000_SRCS=timing_p timing_b prmtvs_p prmtvs_b memory_p memory_b
+
+set SYNOPSYS_SRCS=std_logic_arith std_logic_textio std_logic_unsigned std_logic_signed std_logic_misc std_logic_misc-body
+
+mkdir lib
+cd lib
+
+mkdir v87
+cd v87
+
+mkdir std
+cd std
+for %%F in (%STD_SRCS%) do %REL%\build\ghdlfilter -v87 < %LIBSRC%\std\%%F.vhdl > %%F.v87 && %REL%\build\%GHDL% -a --std=87 --bootstrap --work=std %%F.v87
+cd ..
+
+mkdir ieee
+cd ieee
+rem Base ieee
+for %%F in (%IEEE_SRCS%) do %REL%\build\ghdlfilter -v87 < %LIBSRC%\ieee\%%F.vhdl > %%F.v87 && %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee %%F.v87
+rem Vital 95
+for %%F in (%VITAL95_SRCS%) do copy %LIBSRC%\vital95\%%F.vhdl %%F.vhd && %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee %%F.vhd
+cd ..
+
+mkdir synopsys
+cd synopsys
+for %%F in (%IEEE_SRCS%) do %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee ..\ieee\%%F.v87
+for %%F in (%VITAL95_SRCS%) do %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee ..\ieee\%%F.vhd
+for %%F in (%SYNOPSYS_SRCS%) do copy %LIBSRC%\synopsys\%%F.vhdl %%F.vhd && %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee %%F.vhd
+cd ..
+
+cd ..
+mkdir v93
+cd v93
+
+mkdir std
+cd std
+for %%F in (%STD_SRCS%) do %REL%\build\ghdlfilter -v93 < %LIBSRC%\std\%%F.vhdl > %%F.v93 && %REL%\build\%GHDL% -a --std=93 --bootstrap --work=std %%F.v93
+cd ..
+
+mkdir ieee
+cd ieee
+echo Base ieee
+for %%F in (%IEEE_SRCS%) do %REL%\build\ghdlfilter -v93 < %LIBSRC%\ieee\%%F.vhdl > %%F.v93 && %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee %%F.v93
+echo Vital 2000
+for %%F in (%VITAL2000_SRCS%) do copy %LIBSRC%\vital2000\%%F.vhdl %%F.vhd && %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee %%F.vhd
+cd ..
+
+mkdir synopsys
+cd synopsys
+for %%F in (%IEEE_SRCS%) do %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee ..\ieee\%%F.v93
+for %%F in (%VITAL2000_SRCS%) do %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee ..\ieee\%%F.vhd
+for %%F in (%SYNOPSYS_SRCS%) do %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee ..\..\v87\synopsys\%%F.vhd
+cd ..
+
+cd ..
+
+cd ..
diff --git a/src/translate/mcode/windows/default_pathes.ads b/src/translate/mcode/windows/default_pathes.ads new file mode 100644 index 0000000..51b350f --- /dev/null +++ b/src/translate/mcode/windows/default_pathes.ads @@ -0,0 +1,8 @@ +with Windows_Default_Path;
+pragma Elaborate_All (Windows_Default_Path);
+
+package Default_Pathes is
+ Install_Prefix : constant String :=
+ Windows_Default_Path.Get_Windows_Exec_Path;
+ Lib_Prefix : constant String := "lib";
+end Default_Pathes;
diff --git a/src/translate/mcode/windows/ghdl.nsi b/src/translate/mcode/windows/ghdl.nsi new file mode 100644 index 0000000..aa4d559 --- /dev/null +++ b/src/translate/mcode/windows/ghdl.nsi @@ -0,0 +1,455 @@ +; ghdl.nsi
+;
+; This script is based on example2.nsi.
+; remember the directory,
+; Check if administrator
+; uninstall support
+; TODO:
+; * allow multiple version
+; * command line installation
+; * Allow user install
+
+;--------------------------------
+!include version.nsi
+;--------------------------------
+
+; The name of the installer
+Name "Ghdl"
+
+; The file to write
+OutFile "ghdl-installer-${VERSION}.exe"
+
+SetDateSave on
+
+; The default installation directory
+InstallDir $PROGRAMFILES\Ghdl
+
+; Registry key to check for directory (so if you install again, it will
+; overwrite the old one automatically)
+InstallDirRegKey HKLM "Software\Ghdl" "Install_Dir"
+
+LicenseData ..\..\..\COPYING
+; LicenseForceSelection
+
+;--------------------------------
+
+; Pages
+
+Page license
+Page components
+Page directory
+Page instfiles
+
+UninstPage uninstConfirm
+UninstPage instfiles
+
+;--------------------------------
+Function .onInit
+ Call IsNT
+ pop $R0
+ StrCmp $R0 1 nt_ok
+ MessageBox MB_OK|MB_ICONEXCLAMATION "You must use Windows NT (XP/2000/Me...)"
+ Quit
+
+nt_ok:
+ Call IsUserAdmin
+ Pop $R0
+ StrCmp $R0 "true" Admin
+ MessageBox MB_OK|MB_ICONEXCLAMATION "You must have Admin rights"
+ Quit
+
+Admin:
+
+ ;;; Check if already installed.
+ ReadRegStr $0 HKLM "Software\Ghdl" "Install_Dir"
+ IfErrors not_installed
+ ReadRegStr $0 HKLM "Software\Ghdl" "Version"
+ IfErrors unknown_prev_version
+ Goto known_version
+unknown_prev_version:
+ StrCpy $0 "(unknown)"
+known_version:
+ MessageBox MB_OKCANCEL|MB_ICONEXCLAMATION "You already have GHDL version $0 installed. Deinstall ?" IDCANCEL install_abort IDOK deinstall
+install_abort:
+ Abort "Installation aborted"
+deinstall:
+ ReadRegStr $0 HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "UninstallString"
+ IfErrors deinstall_failed
+
+ ; First version of the GHDL installer adds quotes
+ StrCpy $1 $0 1
+ StrCmp $1 '"' 0 str_ok
+ StrCpy $1 $0 "" 1
+ StrCpy $0 $1 -1
+str_ok:
+
+ ; Read install dir
+ ReadRegStr $1 HKLM "Software\Ghdl" "Install_Dir"
+ IfErrors deinstall_failed
+
+; MessageBox MB_OK 'copy $0 to $TEMP'
+
+ ClearErrors
+; MessageBox MB_OK 'copy $0 to $TEMP'
+ CopyFiles $0 $TEMP
+ IfErrors deinstall_failed
+ ExecWait '"$TEMP\uninst-ghdl.exe" /S _?=$1'
+ IfErrors deinstall_failed
+ Delete "$TEMP\uninst-ghdl.exe"
+ Return
+deinstall_failed:
+ Delete $TEMP\uninst-ghdl.exe
+ MessageBox MB_YESNO|MB_ICONSTOP "Can't deinstall GHDL: de-installer not found or failed. Continue installation ?" IDNO install_abort
+not_installed:
+ Return
+FunctionEnd
+
+;--------------------------------
+
+; The stuff to install
+Section "Ghdl Compiler (required)"
+
+ SectionIn RO
+
+ ; Set output path to the installation directory.
+ SetOutPath $INSTDIR\bin
+ File /oname=ghdl.exe ..\build\ghdl.exe
+
+ SetOutPath $INSTDIR
+ File /oname=COPYING.txt ..\..\..\COPYING
+
+ ; Write the installation path into the registry
+ WriteRegStr HKLM "Software\Ghdl" "Install_Dir" $INSTDIR
+ ; Write te version
+ WriteRegStr HKLM "Software\Ghdl" "Version" ${VERSION}
+
+ ; Write the uninstall keys for Windows
+ WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "DisplayName" "Ghdl"
+ WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "UninstallString" $INSTDIR\uninst-ghdl.exe
+ WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "NoModify" 1
+ WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "NoRepair" 1
+ WriteUninstaller $INSTDIR\uninst-ghdl.exe"
+
+SectionEnd
+
+Section "VHDL standard and ieee libraries"
+ SectionIn RO
+ SetOutPath $INSTDIR\lib\v87
+ File /r ..\lib\v87\std ..\lib\v87\ieee
+ SetOutPath $INSTDIR\lib\v93
+ File /r ..\lib\v93\std ..\lib\v93\ieee
+SectionEnd
+
+Section "Synopsys libraries (Recommended)"
+ SetOutPath $INSTDIR\lib\v87
+ File /r ..\lib\v87\synopsys
+ SetOutPath $INSTDIR\lib\v93
+ File /r ..\lib\v93\synopsys
+SectionEnd
+
+Section "Documentation (Recommended)"
+ SetOutPath $INSTDIR
+ File /oname=ghdl.htm ..\..\..\doc\ghdl.html
+SectionEnd
+
+Section "Add in PATH (Recommended)"
+ WriteRegDWORD HKLM "Software\Ghdl" "PathSet" 1
+ Push $INSTDIR\Bin
+ Call AddToPath
+SectionEnd
+
+; Optional section (can be disabled by the user)
+;Section "Start Menu Shortcuts"
+;
+; CreateDirectory "$SMPROGRAMS\Ghdl"
+; CreateShortCut "$SMPROGRAMS\Ghdl\Uninstall.lnk" "$INSTDIR\uninstall.exe" "" "$INSTDIR\uninstall.exe" 0
+; CreateShortCut "$SMPROGRAMS\Ghdl\Ghdl.lnk" "$INSTDIR\example2.nsi" "" "$INSTDIR\example2.nsi" 0
+;
+;SectionEnd
+;
+
+;--------------------------------
+
+; Uninstaller
+
+Section "Uninstall"
+
+ ReadRegDWORD $0 HKLM "Software\Ghdl" "PathSet"
+ StrCmp $0 "1" "" path_not_set
+ Push $INSTDIR\Bin
+ Call un.RemoveFromPath
+
+path_not_set:
+
+ ; Remove registry keys
+ DeleteRegKey HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl"
+ DeleteRegKey HKLM Software\Ghdl
+
+ ; Remove files and uninstaller
+ Delete $INSTDIR\bin\ghdl.exe
+ Delete $INSTDIR\uninst-ghdl.exe
+ Delete $INSTDIR\COPYING.txt
+ RMDir $INSTDIR\bin
+ RMDir /r $INSTDIR\lib
+
+
+ ; Remove shortcuts, if any
+ ; Delete "$SMPROGRAMS\Ghdl\*.*"
+
+ ; Remove directories used
+ ; RMDir "$SMPROGRAMS\Ghdl"
+ RMDir "$INSTDIR"
+
+SectionEnd
+
+;;;;;;;; Misc functions
+
+; Author: Lilla (lilla@earthlink.net) 2003-06-13
+; function IsUserAdmin uses plugin \NSIS\PlusgIns\UserInfo.dll
+; This function is based upon code in \NSIS\Contrib\UserInfo\UserInfo.nsi
+; This function was tested under NSIS 2 beta 4 (latest CVS as of this writing).
+;
+; Usage:
+; Call IsUserAdmin
+; Pop $R0 ; at this point $R0 is "true" or "false"
+;
+Function IsUserAdmin
+Push $R0
+Push $R1
+Push $R2
+
+ClearErrors
+UserInfo::GetName
+IfErrors Win9x
+Pop $R1
+UserInfo::GetAccountType
+Pop $R2
+
+StrCmp $R2 "Admin" 0 Continue
+; Observation: I get here when running Win98SE. (Lilla)
+; The functions UserInfo.dll looks for are there on Win98 too,
+; but just don't work. So UserInfo.dll, knowing that admin isn't required
+; on Win98, returns admin anyway. (per kichik)
+; MessageBox MB_OK 'User "$R1" is in the Administrators group'
+StrCpy $R0 "true"
+Goto Done
+
+Continue:
+; You should still check for an empty string because the functions
+; UserInfo.dll looks for may not be present on Windows 95. (per kichik)
+StrCmp $R2 "" Win9x
+StrCpy $R0 "false"
+;MessageBox MB_OK 'User "$R1" is in the "$R2" group'
+Goto Done
+
+Win9x:
+; comment/message below is by UserInfo.nsi author:
+; This one means you don't need to care about admin or
+; not admin because Windows 9x doesn't either
+;MessageBox MB_OK "Error! This DLL can't run under Windows 9x!"
+StrCpy $R0 "true"
+
+Done:
+;MessageBox MB_OK 'User= "$R1" AccountType= "$R2" IsUserAdmin= "$R0"'
+
+Pop $R2
+Pop $R1
+Exch $R0
+FunctionEnd
+
+
+!define ALL_USERS
+
+!ifndef WriteEnvStr_RegKey
+ !ifdef ALL_USERS
+ !define WriteEnvStr_RegKey \
+ 'HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment"'
+ !else
+ !define WriteEnvStr_RegKey 'HKCU "Environment"'
+ !endif
+!endif
+
+!verbose 3
+!include "WinMessages.NSH"
+!verbose 4
+
+; AddToPath - Adds the given dir to the search path.
+; Input - head of the stack
+; Note - Win9x systems requires reboot
+
+Function AddToPath
+ Exch $0
+ Push $1
+ Push $2
+ Push $3
+
+ # don't add if the path doesn't exist
+ IfFileExists "$0\*.*" "" AddToPath_done
+
+ ReadEnvStr $1 PATH
+ Push "$1;"
+ Push "$0;"
+ Call StrStr
+ Pop $2
+ StrCmp $2 "" "" AddToPath_done
+ Push "$1;"
+ Push "$0\;"
+ Call StrStr
+ Pop $2
+ StrCmp $2 "" "" AddToPath_done
+ GetFullPathName /SHORT $3 $0
+ Push "$1;"
+ Push "$3;"
+ Call StrStr
+ Pop $2
+ StrCmp $2 "" "" AddToPath_done
+ Push "$1;"
+ Push "$3\;"
+ Call StrStr
+ Pop $2
+ StrCmp $2 "" "" AddToPath_done
+
+ ReadRegStr $1 ${WriteEnvStr_RegKey} "PATH"
+ StrCpy $2 $1 1 -1 # copy last char
+ StrCmp $2 ";" 0 +2 # if last char == ;
+ StrCpy $1 $1 -1 # remove last char
+ StrCmp $1 "" AddToPath_NTdoIt
+ StrCpy $0 "$1;$0"
+ AddToPath_NTdoIt:
+ WriteRegExpandStr ${WriteEnvStr_RegKey} "PATH" $0
+ SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000
+
+ AddToPath_done:
+ Pop $3
+ Pop $2
+ Pop $1
+ Pop $0
+FunctionEnd
+
+; RemoveFromPath - Remove a given dir from the path
+; Input: head of the stack
+
+Function un.RemoveFromPath
+ Exch $0
+ Push $1
+ Push $2
+ Push $3
+ Push $4
+ Push $5
+ Push $6
+
+ IntFmt $6 "%c" 26 # DOS EOF
+
+ ReadRegStr $1 ${WriteEnvStr_RegKey} "PATH"
+ StrCpy $5 $1 1 -1 # copy last char
+ StrCmp $5 ";" +2 # if last char != ;
+ StrCpy $1 "$1;" # append ;
+ Push $1
+ Push "$0;"
+ Call un.StrStr ; Find `$0;` in $1
+ Pop $2 ; pos of our dir
+ StrCmp $2 "" unRemoveFromPath_done
+ ; else, it is in path
+ # $0 - path to add
+ # $1 - path var
+ StrLen $3 "$0;"
+ StrLen $4 $2
+ StrCpy $5 $1 -$4 # $5 is now the part before the path to remove
+ StrCpy $6 $2 "" $3 # $6 is now the part after the path to remove
+ StrCpy $3 $5$6
+
+ StrCpy $5 $3 1 -1 # copy last char
+ StrCmp $5 ";" 0 +2 # if last char == ;
+ StrCpy $3 $3 -1 # remove last char
+
+ WriteRegExpandStr ${WriteEnvStr_RegKey} "PATH" $3
+ SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000
+
+ unRemoveFromPath_done:
+ Pop $6
+ Pop $5
+ Pop $4
+ Pop $3
+ Pop $2
+ Pop $1
+ Pop $0
+FunctionEnd
+
+###########################################
+# Utility Functions #
+###########################################
+
+; IsNT
+; no input
+; output, top of the stack = 1 if NT or 0 if not
+;
+; Usage:
+; Call IsNT
+; Pop $R0
+; ($R0 at this point is 1 or 0)
+
+!macro IsNT un
+Function ${un}IsNT
+ Push $0
+ ReadRegStr $0 HKLM "SOFTWARE\Microsoft\Windows NT\CurrentVersion" CurrentVersion
+ StrCmp $0 "" 0 IsNT_yes
+ ; we are not NT.
+ Pop $0
+ Push 0
+ Return
+
+ IsNT_yes:
+ ; NT!!!
+ Pop $0
+ Push 1
+FunctionEnd
+!macroend
+!insertmacro IsNT ""
+;!insertmacro IsNT "un."
+
+; StrStr
+; input, top of stack = string to search for
+; top of stack-1 = string to search in
+; output, top of stack (replaces with the portion of the string remaining)
+; modifies no other variables.
+;
+; Usage:
+; Push "this is a long ass string"
+; Push "ass"
+; Call StrStr
+; Pop $R0
+; ($R0 at this point is "ass string")
+
+!macro StrStr un
+Function ${un}StrStr
+Exch $R1 ; st=haystack,old$R1, $R1=needle
+ Exch ; st=old$R1,haystack
+ Exch $R2 ; st=old$R1,old$R2, $R2=haystack
+ Push $R3
+ Push $R4
+ Push $R5
+ StrLen $R3 $R1
+ StrCpy $R4 0
+ ; $R1=needle
+ ; $R2=haystack
+ ; $R3=len(needle)
+ ; $R4=cnt
+ ; $R5=tmp
+ loop:
+ StrCpy $R5 $R2 $R3 $R4
+ StrCmp $R5 $R1 done
+ StrCmp $R5 "" done
+ IntOp $R4 $R4 + 1
+ Goto loop
+done:
+ StrCpy $R1 $R2 "" $R4
+ Pop $R5
+ Pop $R4
+ Pop $R3
+ Pop $R2
+ Exch $R1
+FunctionEnd
+!macroend
+!insertmacro StrStr ""
+!insertmacro StrStr "un."
+
diff --git a/src/translate/mcode/windows/ghdlfilter.adb b/src/translate/mcode/windows/ghdlfilter.adb new file mode 100644 index 0000000..d37c2db --- /dev/null +++ b/src/translate/mcode/windows/ghdlfilter.adb @@ -0,0 +1,58 @@ +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + +procedure Ghdlfilter is + type Mode_Kind is (Mode_93, Mode_87); + Mode : Mode_Kind; + + Line : String (1 .. 128); + Len : Natural; + + Comment : Boolean; + Block_Comment : Boolean; +begin + if Argument_Count /= 1 then + Put_Line (Standard_Error, "usage: " & Command_Name & " -v93|-v87"); + return; + end if; + + if Argument (1) = "-v93" then + Mode := Mode_93; + elsif Argument (1) = "-v87" then + Mode := Mode_87; + else + Put_Line (Standard_Error, "bad mode"); + return; + end if; + + Block_Comment := False; + + loop + exit when End_Of_File; + Get_Line (Line, Len); + + Comment := Block_Comment; + + if Len > 5 then + if Mode = Mode_87 and Line (Len - 4 .. Len) = "--V93" then + Comment := True; + elsif Mode = Mode_93 and Line (Len - 4 .. Len) = "--V87" then + Comment := True; + end if; + end if; + if Len = 11 + and then Mode = Mode_87 + and then Line (1 .. 11) = "--START-V93" then + Block_Comment := True; + end if; + + if Len = 9 and then Line (1 .. 9) = "--END-V93" then + Block_Comment := False; + end if; + + if Comment then + Put ("-- "); + end if; + Put_Line (Line (1 .. Len)); + end loop; +end Ghdlfilter; diff --git a/src/translate/mcode/windows/ghdlversion.adb b/src/translate/mcode/windows/ghdlversion.adb new file mode 100755 index 0000000..d2f1c28 --- /dev/null +++ b/src/translate/mcode/windows/ghdlversion.adb @@ -0,0 +1,30 @@ +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Strings.Fixed; use Ada.Strings.Fixed; + +procedure Ghdlversion is + Line : String (1 .. 128); + Len : Natural; + Pos : Natural; + E : Natural; +begin + loop + exit when End_Of_File; + Get_Line (Line, Len); + + -- Search GHDL + Pos := Index (Line (1 .. Len), "GHDL "); + if Pos /= 0 then + Pos := Pos + 5; + E := Pos; + while Line (E) in '0' .. '9' + or Line (E) in 'a' .. 'z' + or Line (E) = '.' + loop + exit when E = Len; + E := E + 1; + end loop; + Put_Line ("!define VERSION """ & Line (Pos .. E - 1) & """"); + return; + end if; + end loop; +end Ghdlversion; diff --git a/src/translate/mcode/windows/grt-modules.adb b/src/translate/mcode/windows/grt-modules.adb new file mode 100644 index 0000000..35b27c3 --- /dev/null +++ b/src/translate/mcode/windows/grt-modules.adb @@ -0,0 +1,37 @@ +-- GHDL Run Time (GRT) - Modules. +-- Copyright (C) 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System.Storage_Elements; -- Work around GNAT bug. +with Grt.Vcd; +with Grt.Vpi; +with Grt.Waves; +with Grt.Vital_Annotate; +with Grt.Disp_Tree; +with Grt.Disp_Rti; + +package body Grt.Modules is + procedure Register_Modules is + begin + -- List of modules to be registered. + Grt.Disp_Tree.Register; + Grt.Vcd.Register; + Grt.Waves.Register; + Grt.Vpi.Register; + Grt.Vital_Annotate.Register; + Grt.Disp_Rti.Register; + end Register_Modules; +end Grt.Modules; diff --git a/src/translate/mcode/windows/ortho_code-x86-flags.ads b/src/translate/mcode/windows/ortho_code-x86-flags.ads new file mode 100644 index 0000000..8915f31 --- /dev/null +++ b/src/translate/mcode/windows/ortho_code-x86-flags.ads @@ -0,0 +1,2 @@ +with Ortho_Code.X86.Flags_Windows; +package Ortho_Code.X86.Flags renames Ortho_Code.X86.Flags_Windows; diff --git a/src/translate/mcode/windows/windows_default_path.adb b/src/translate/mcode/windows/windows_default_path.adb new file mode 100644 index 0000000..23aa2f6 --- /dev/null +++ b/src/translate/mcode/windows/windows_default_path.adb @@ -0,0 +1,45 @@ +with Interfaces.C; use Interfaces.C; +with System; use System; + +package body Windows_Default_Path is + + subtype DWORD is Interfaces.C.Unsigned_Long; + subtype LPWSTR is String; + subtype HINSTANCE is Address; + function GetModuleFileName (Inst : HINSTANCE; Buf : Address; Size : DWORD) + return DWORD; + pragma Import (Stdcall, GetModuleFileName, "GetModuleFileNameA"); + + function Get_Windows_Exec_Path return String + is + File : String (1 .. 256); + Size : DWORD; + P : Natural; + begin + -- Get exe file path. + Size := GetModuleFileName (Null_Address, File'Address, File'Length); + if Size = 0 or Size = File'Length then + return "{cannot find install path}\lib"; + end if; + + -- Remove Program file. + P := Natural (Size); + while P > 0 loop + exit when File (P) = '\'; + exit when File (P) = ':' and P = 2; + P := P - 1; + end loop; + if File (P) = '\' and P > 1 then + -- Remove directory + P := P - 1; + while P > 0 loop + exit when File (P) = '\'; + exit when File (P) = ':' and P = 2; + P := P - 1; + end loop; + end if; + + return File (1 .. P); + end Get_Windows_Exec_Path; +end Windows_Default_Path; + diff --git a/src/translate/mcode/windows/windows_default_path.ads b/src/translate/mcode/windows/windows_default_path.ads new file mode 100644 index 0000000..8e63034 --- /dev/null +++ b/src/translate/mcode/windows/windows_default_path.ads @@ -0,0 +1,5 @@ +package Windows_Default_Path is
+ -- Get the default path from executable name.
+ -- This function is called during elaboration!
+ function Get_Windows_Exec_Path return String;
+end Windows_Default_Path;
diff --git a/src/translate/ortho_front.adb b/src/translate/ortho_front.adb new file mode 100644 index 0000000..56c7e61 --- /dev/null +++ b/src/translate/ortho_front.adb @@ -0,0 +1,445 @@ +-- Ortho entry point for translation. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Name_Table; +with Std_Package; +with Back_End; +with Flags; +with Translation; +with Iirs; use Iirs; +with Libraries; use Libraries; +with Sem; +with Errorout; use Errorout; +with GNAT.OS_Lib; +with Canon; +with Disp_Vhdl; +with Bug; +with Trans_Be; +with Options; + +package body Ortho_Front is + -- The action to be performed by the compiler. + type Action_Type is + ( + -- Normal mode: compile a design file. + Action_Compile, + + -- Elaborate a design unit. + Action_Elaborate, + + -- Analyze files and elaborate unit. + Action_Anaelab, + + -- Generate code for std.package. + Action_Compile_Std_Package + ); + Action : Action_Type := Action_Compile; + + -- Name of the entity to elaborate. + Elab_Entity : String_Acc; + -- Name of the architecture to elaborate. + Elab_Architecture : String_Acc; + -- Filename for the list of files to link. + Elab_Filelist : String_Acc; + + Flag_Expect_Failure : Boolean; + + type Id_Link; + type Id_Link_Acc is access Id_Link; + type Id_Link is record + Id : Name_Id; + Link : Id_Link_Acc; + end record; + Anaelab_Files : Id_Link_Acc := null; + Anaelab_Files_Last : Id_Link_Acc := null; + + procedure Init is + begin + -- Initialize. + Trans_Be.Register_Translation_Back_End; + + Options.Initialize; + + Elab_Filelist := null; + Elab_Entity := null; + Elab_Architecture := null; + Flag_Expect_Failure := False; + end Init; + + function Decode_Elab_Option (Arg : String_Acc) return Natural + is + begin + Elab_Architecture := null; + -- Entity (+ architecture) to elaborate + if Arg = null then + Error_Msg_Option + ("entity or configuration name required after --elab"); + return 0; + end if; + if Arg (Arg.all'Last) = ')' then + -- Name is ENTITY(ARCH). + -- Split. + declare + P : Natural; + Len : Natural; + Is_Ext : Boolean; + begin + P := Arg.all'Last - 1; + Len := P - Arg.all'First + 1; + -- Must be at least 'e(a)'. + if Len < 4 then + Error_Msg_Option ("ill-formed name after --elab"); + return 0; + end if; + -- Handle extended name. + if Arg (P) = '\' then + P := P - 1; + Is_Ext := True; + else + Is_Ext := False; + end if; + loop + if P = Arg.all'First then + Error_Msg_Option ("ill-formed name after --elab"); + return 0; + end if; + exit when Arg (P) = '(' and Is_Ext = False; + if Arg (P) = '\' then + if Arg (P - 1) = '\' then + P := P - 2; + elsif Arg (P - 1) = '(' then + P := P - 1; + exit; + else + Error_Msg_Option ("ill-formed name after --elab"); + return 0; + end if; + else + P := P - 1; + end if; + end loop; + Elab_Architecture := new String'(Arg (P + 1 .. Arg'Last - 1)); + Elab_Entity := new String'(Arg (Arg'First .. P - 1)); + end; + else + Elab_Entity := new String'(Arg.all); + Elab_Architecture := new String'(""); + end if; + return 2; + end Decode_Elab_Option; + + function Decode_Option (Opt : String_Acc; Arg: String_Acc) return Natural + is + begin + if Opt.all = "--compile-standard" then + Action := Action_Compile_Std_Package; + Flags.Bootstrap := True; + return 1; + elsif Opt.all = "--elab" then + if Action /= Action_Compile then + Error_Msg_Option ("several --elab options"); + return 0; + end if; + Action := Action_Elaborate; + return Decode_Elab_Option (Arg); + elsif Opt.all = "--anaelab" then + if Action /= Action_Compile then + Error_Msg_Option ("several --anaelab options"); + return 0; + end if; + Action := Action_Anaelab; + return Decode_Elab_Option (Arg); + elsif Opt'Length > 14 + and then Opt (Opt'First .. Opt'First + 13) = "--ghdl-source=" + then + if Action /= Action_Anaelab then + Error_Msg_Option + ("--ghdl-source option allowed only after --anaelab options"); + return 0; + end if; + if Arg /= null then + Error_Msg_Option ("no argument allowed after --ghdl-source"); + return 0; + end if; + declare + L : Id_Link_Acc; + begin + L := new Id_Link'(Id => Name_Table.Get_Identifier + (Opt (Opt'First + 14 .. Opt'Last)), + Link => null); + if Anaelab_Files = null then + Anaelab_Files := L; + else + Anaelab_Files_Last.Link := L; + end if; + Anaelab_Files_Last := L; + end; + return 2; + elsif Opt.all = "-l" then + if Arg = null then + Error_Msg_Option ("filename required after -l"); + end if; + if Elab_Filelist /= null then + Error_Msg_Option ("several -l options"); + else + Elab_Filelist := new String'(Arg.all); + end if; + return 2; + elsif Opt.all = "--help" then + Options.Disp_Options_Help; + return 1; + elsif Opt.all = "--expect-failure" then + Flag_Expect_Failure := True; + return 1; + elsif Opt'Length > 7 and then Opt (1 .. 7) = "--ghdl-" then + if Options.Parse_Option (Opt (7 .. Opt'Last)) then + return 1; + else + return 0; + end if; + elsif Options.Parse_Option (Opt.all) then + return 1; + else + return 0; + end if; + end Decode_Option; + + + -- Lighter version of libraries.is_obselete, since DESIGN_UNIT must be in + -- the currently analyzed design file. + function Is_Obsolete (Design_Unit : Iir_Design_Unit) + return Boolean + is + List : Iir_List; + El : Iir; + begin + if Get_Date (Design_Unit) = Date_Obsolete then + return True; + end if; + List := Get_Dependence_List (Design_Unit); + if Is_Null_List (List) then + return False; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when Is_Null (El); + -- FIXME: there may be entity_aspect_entity... + if Get_Kind (El) = Iir_Kind_Design_Unit + and then Get_Date (El) = Date_Obsolete + then + return True; + end if; + end loop; + return False; + end Is_Obsolete; + + Nbr_Parse : Natural := 0; + + function Parse (Filename : String_Acc) return Boolean + is + Res : Iir_Design_File; + New_Design_File : Iir_Design_File; + Design : Iir_Design_Unit; + Next_Design : Iir_Design_Unit; + + -- The vhdl filename to compile. + Vhdl_File : Name_Id; + begin + if Nbr_Parse = 0 then + -- Initialize only once... + Libraries.Load_Std_Library; + + -- Here, time_base can be set. + Translation.Initialize; + Canon.Canon_Flag_Add_Labels := True; + + if Flags.List_All and then Flags.List_Annotate then + Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit); + end if; + + if Action = Action_Anaelab and then Anaelab_Files /= null + then + Libraries.Load_Work_Library (True); + else + Libraries.Load_Work_Library (False); + end if; + end if; + Nbr_Parse := Nbr_Parse + 1; + + case Action is + when Action_Elaborate => + Flags.Flag_Elaborate := True; + Flags.Flag_Only_Elab_Warnings := True; + Translation.Chap12.Elaborate + (Elab_Entity.all, Elab_Architecture.all, + Elab_Filelist.all, False); + + if Errorout.Nbr_Errors > 0 then + -- This may happen (bad entity for example). + raise Compilation_Error; + end if; + when Action_Anaelab => + -- Parse files. + if Anaelab_Files = null then + Flags.Flag_Elaborate_With_Outdated := False; + else + Flags.Flag_Elaborate_With_Outdated := True; + declare + L : Id_Link_Acc; + begin + L := Anaelab_Files; + while L /= null loop + Res := Libraries.Load_File (L.Id); + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Put units into library. + Design := Get_First_Design_Unit (Res); + while not Is_Null (Design) loop + Next_Design := Get_Chain (Design); + Set_Chain (Design, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Design); + Design := Next_Design; + end loop; + L := L.Link; + end loop; + end; + end if; + + Flags.Flag_Elaborate := True; + Flags.Flag_Only_Elab_Warnings := False; + Translation.Chap12.Elaborate + (Elab_Entity.all, Elab_Architecture.all, "", True); + + if Errorout.Nbr_Errors > 0 then + -- This may happen (bad entity for example). + raise Compilation_Error; + end if; + when Action_Compile_Std_Package => + if Filename /= null then + Error_Msg_Option + ("--compile-standard is not compatible with a filename"); + return False; + end if; + Translation.Translate_Standard (True); + + when Action_Compile => + if Filename = null then + Error_Msg_Option ("no input file"); + return False; + end if; + if Nbr_Parse > 1 then + Error_Msg_Option ("can compile only one file (file """ & + Filename.all & """ ignored)"); + return False; + end if; + Vhdl_File := Name_Table.Get_Identifier (Filename.all); + + Translation.Translate_Standard (False); + + Flags.Flag_Elaborate := False; + Res := Libraries.Load_File (Vhdl_File); + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Semantize all design units. + -- FIXME: outdate the design file? + New_Design_File := Null_Iir; + Design := Get_First_Design_Unit (Res); + while not Is_Null (Design) loop + -- Sem, canon, annotate a design unit. + Back_End.Finish_Compilation (Design, True); + + Next_Design := Get_Chain (Design); + if Errorout.Nbr_Errors = 0 then + Set_Chain (Design, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Design); + New_Design_File := Get_Design_File (Design); + end if; + + Design := Next_Design; + end loop; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Do late analysis checks. + Design := Get_First_Design_Unit (New_Design_File); + while not Is_Null (Design) loop + Sem.Sem_Analysis_Checks_List + (Design, Flags.Warn_Delayed_Checks); + Design := Get_Chain (Design); + end loop; + + -- Compile only now. + if not Is_Null (New_Design_File) then + -- Note: the order of design unit is kept. + Design := Get_First_Design_Unit (New_Design_File); + while not Is_Null (Design) loop + if not Is_Obsolete (Design) then + + if Get_Kind (Get_Library_Unit (Design)) + = Iir_Kind_Configuration_Declaration + then + -- Defer code generation of configuration declaration. + -- (default binding may change between analysis and + -- elaboration). + Translation.Translate (Design, False); + else + Translation.Translate (Design, True); + end if; + + if Errorout.Nbr_Errors > 0 then + -- This can happen (foreign attribute). + raise Compilation_Error; + end if; + end if; + + Design := Get_Chain (Design); + end loop; + end if; + + -- Save the working library. + Libraries.Save_Work_Library; + end case; + if Flag_Expect_Failure then + return False; + else + return True; + end if; + exception + --when File_Error => + -- Error_Msg_Option ("cannot open file '" & Filename.all & "'"); + -- return False; + when Compilation_Error + | Parse_Error => + if Flag_Expect_Failure then + -- Very brutal... + GNAT.OS_Lib.OS_Exit (0); + end if; + return False; + when Option_Error => + return False; + when E: others => + Bug.Disp_Bug_Box (E); + raise; + end Parse; +end Ortho_Front; diff --git a/src/translate/trans_analyzes.adb b/src/translate/trans_analyzes.adb new file mode 100644 index 0000000..8147e93 --- /dev/null +++ b/src/translate/trans_analyzes.adb @@ -0,0 +1,182 @@ +-- 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; +with Ada.Text_IO; +with Errorout; + +package body Trans_Analyzes is + Driver_List : Iir_List; + + Has_After : Boolean; + function Extract_Driver_Target (Target : Iir) return Walk_Status + is + Base : Iir; + Prefix : Iir; + begin + Base := Get_Object_Prefix (Target); + -- Assigment to subprogram interface does not create a driver. + if Get_Kind (Base) = Iir_Kind_Interface_Signal_Declaration + and then + Get_Kind (Get_Parent (Base)) = Iir_Kind_Procedure_Declaration + then + return Walk_Continue; + end if; + + Prefix := Get_Longuest_Static_Prefix (Target); + Add_Element (Driver_List, Prefix); + if Has_After then + Set_After_Drivers_Flag (Base, True); + end if; + return Walk_Continue; + end Extract_Driver_Target; + + function Extract_Driver_Stmt (Stmt : Iir) return Walk_Status + is + Status : Walk_Status; + pragma Unreferenced (Status); + We : Iir; + begin + case Get_Kind (Stmt) is + when Iir_Kind_Signal_Assignment_Statement => + We := Get_Waveform_Chain (Stmt); + if We /= Null_Iir + and then Get_Chain (We) = Null_Iir + and then Get_Time (We) = Null_Iir + and then Get_Kind (Get_We_Value (We)) /= Iir_Kind_Null_Literal + then + Has_After := False; + else + Has_After := True; + end if; + Status := Walk_Assignment_Target + (Get_Target (Stmt), Extract_Driver_Target'Access); + when Iir_Kind_Procedure_Call_Statement => + declare + Call : constant Iir := Get_Procedure_Call (Stmt); + Assoc : Iir; + Formal : Iir; + Inter : Iir; + begin + -- Very pessimist. + Has_After := True; + + Assoc := Get_Parameter_Association_Chain (Call); + Inter := Get_Interface_Declaration_Chain + (Get_Implementation (Call)); + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + if Formal = Null_Iir then + Formal := Inter; + Inter := Get_Chain (Inter); + else + Formal := Get_Association_Interface (Assoc); + end if; + if Get_Kind (Assoc) + = Iir_Kind_Association_Element_By_Expression + and then + Get_Kind (Formal) = Iir_Kind_Interface_Signal_Declaration + and then Get_Mode (Formal) /= Iir_In_Mode + then + Status := Extract_Driver_Target (Get_Actual (Assoc)); + end if; + Assoc := Get_Chain (Assoc); + end loop; + end; + when others => + null; + end case; + return Walk_Continue; + end Extract_Driver_Stmt; + + procedure Extract_Drivers_Sequential_Stmt_Chain (Chain : Iir) + is + Status : Walk_Status; + pragma Unreferenced (Status); + begin + Status := Walk_Sequential_Stmt_Chain (Chain, Extract_Driver_Stmt'Access); + end Extract_Drivers_Sequential_Stmt_Chain; + + procedure Extract_Drivers_Declaration_Chain (Chain : Iir) + is + Decl : Iir := Chain; + begin + while Decl /= Null_Iir loop + + -- Only procedures and impure functions may contain assignment. + if Get_Kind (Decl) = Iir_Kind_Procedure_Body + or else (Get_Kind (Decl) = Iir_Kind_Function_Body + and then + not Get_Pure_Flag (Get_Subprogram_Specification (Decl))) + then + Extract_Drivers_Declaration_Chain (Get_Declaration_Chain (Decl)); + Extract_Drivers_Sequential_Stmt_Chain + (Get_Sequential_Statement_Chain (Decl)); + end if; + + Decl := Get_Chain (Decl); + end loop; + end Extract_Drivers_Declaration_Chain; + + function Extract_Drivers (Proc : Iir) return Iir_List + is + begin + Driver_List := Create_Iir_List; + Extract_Drivers_Declaration_Chain (Get_Declaration_Chain (Proc)); + Extract_Drivers_Sequential_Stmt_Chain + (Get_Sequential_Statement_Chain (Proc)); + + return Driver_List; + end Extract_Drivers; + + procedure Free_Drivers_List (List : in out Iir_List) + is + El : Iir; + begin + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Set_After_Drivers_Flag (Get_Object_Prefix (El), False); + end loop; + Destroy_Iir_List (List); + end Free_Drivers_List; + + procedure Dump_Drivers (Proc : Iir; List : Iir_List) + is + use Ada.Text_IO; + use Errorout; + El : Iir; + begin + Put_Line ("List of drivers for " & Disp_Node (Proc) & ":"); + Put_Line (" (declared at " & Disp_Location (Proc) & ")"); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Get_After_Drivers_Flag (Get_Object_Prefix (El)) then + Put ("* "); + else + Put (" "); + end if; + Disp_Vhdl.Disp_Vhdl (El); + New_Line; + end loop; + end Dump_Drivers; + +end Trans_Analyzes; diff --git a/src/translate/trans_analyzes.ads b/src/translate/trans_analyzes.ads new file mode 100644 index 0000000..ecebb75 --- /dev/null +++ b/src/translate/trans_analyzes.ads @@ -0,0 +1,31 @@ +-- 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 + -- Extract a list of drivers from PROC. + function Extract_Drivers (Proc : Iir) return Iir_List; + + -- Free the list. + procedure Free_Drivers_List (List : in out Iir_List); + + -- Dump list of drivers (LIST) for process PROC. + procedure Dump_Drivers (Proc : Iir; List : Iir_List); + +end Trans_Analyzes; diff --git a/src/translate/trans_be.adb b/src/translate/trans_be.adb new file mode 100644 index 0000000..dd1b6c3 --- /dev/null +++ b/src/translate/trans_be.adb @@ -0,0 +1,182 @@ +-- Back-end for translation. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; +with Disp_Tree; +with Disp_Vhdl; +with Sem; +with Canon; +with Translation; +with Errorout; use Errorout; +with Post_Sems; +with Flags; +with Ada.Text_IO; +with Back_End; + +package body Trans_Be is + procedure Finish_Compilation + (Unit : Iir_Design_Unit; Main : Boolean := False) + is + use Ada.Text_IO; + Lib : Iir; + begin + -- No need to semantize during elaboration. + --if Flags.Will_Elaborate then + -- return; + --end if; + + Lib := Get_Library_Unit (Unit); + + if (Main or Flags.Dump_All) and then Flags.Dump_Parse then + Disp_Tree.Disp_Tree (Unit); + end if; + + -- Semantic analysis. + if Flags.Verbose then + Put_Line ("semantize " & Disp_Node (Lib)); + end if; + Sem.Semantic (Unit); + + if (Main or Flags.Dump_All) and then Flags.Dump_Sem then + Disp_Tree.Disp_Tree (Unit); + end if; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if (Main or Flags.List_All) and then Flags.List_Sem then + Disp_Vhdl.Disp_Vhdl (Unit); + end if; + + -- Post checks + ---------------- + + Post_Sems.Post_Sem_Checks (Unit); + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Canonalisation. + ------------------ + if Flags.Verbose then + Put_Line ("canonicalize " & Disp_Node (Lib)); + end if; + + Canon.Canonicalize (Unit); + + if (Main or Flags.Dump_All) and then Flags.Dump_Canon then + Disp_Tree.Disp_Tree (Unit); + end if; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if (Main or Flags.List_All) and then Flags.List_Canon then + Disp_Vhdl.Disp_Vhdl (Unit); + end if; + + if Flags.Flag_Elaborate then + if Get_Kind (Lib) = Iir_Kind_Architecture_Body then + declare + Config : Iir_Design_Unit; + begin + Config := Canon.Create_Default_Configuration_Declaration (Lib); + Set_Default_Configuration_Declaration (Lib, Config); + if (Main or Flags.Dump_All) and then Flags.Dump_Canon then + Disp_Tree.Disp_Tree (Config); + end if; + if (Main or Flags.List_All) and then Flags.List_Canon then + Disp_Vhdl.Disp_Vhdl (Config); + end if; + end; + end if; + + -- Do not translate during elaboration. + -- This is done directly in Translation.Chap12. + return; + end if; + + -- Translation + --------------- + if not Main then + -- Main units (those from the analyzed design file) are translated + -- directly by ortho_front. + + Translation.Translate (Unit, Main); + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + end if; + + end Finish_Compilation; + + procedure Sem_Foreign (Decl : Iir) + is + use Translation; + Fi : Foreign_Info_Type; + pragma Unreferenced (Fi); + begin + case Get_Kind (Decl) is + when Iir_Kind_Architecture_Body => + Error_Msg_Sem ("FOREIGN architectures are not yet handled", Decl); + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + null; + when others => + Error_Kind ("sem_foreign", Decl); + end case; + -- Let is generate error messages. + Fi := Translate_Foreign_Id (Decl); + end Sem_Foreign; + + function Parse_Option (Opt : String) return Boolean is + begin + if Opt = "--dump-drivers" then + Translation.Flag_Dump_Drivers := True; + elsif Opt = "--no-direct-drivers" then + Translation.Flag_Direct_Drivers := False; + elsif Opt = "--no-range-checks" then + Translation.Flag_Range_Checks := False; + elsif Opt = "--no-index-checks" then + Translation.Flag_Index_Checks := False; + elsif Opt = "--no-identifiers" then + Translation.Flag_Discard_Identifiers := True; + else + return False; + end if; + return True; + end Parse_Option; + + procedure Disp_Option + is + procedure P (Str : String) renames Ada.Text_IO.Put_Line; + begin + P (" --dump-drivers dump processes drivers"); + end Disp_Option; + + procedure Register_Translation_Back_End is + begin + Back_End.Finish_Compilation := Finish_Compilation'Access; + Back_End.Sem_Foreign := Sem_Foreign'Access; + Back_End.Parse_Option := Parse_Option'Access; + Back_End.Disp_Option := Disp_Option'Access; + end Register_Translation_Back_End; +end Trans_Be; diff --git a/src/translate/trans_be.ads b/src/translate/trans_be.ads new file mode 100644 index 0000000..9ff0603 --- /dev/null +++ b/src/translate/trans_be.ads @@ -0,0 +1,21 @@ +-- Back-end for translation. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Trans_Be is + procedure Register_Translation_Back_End; +end Trans_Be; + diff --git a/src/translate/trans_decls.ads b/src/translate/trans_decls.ads new file mode 100644 index 0000000..e104c71 --- /dev/null +++ b/src/translate/trans_decls.ads @@ -0,0 +1,257 @@ +-- Declarations for well-known nodes generated by translation. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ortho_Nodes; use Ortho_Nodes; + +package Trans_Decls is + -- Procedures called in case of assert failed. + Ghdl_Assert_Failed : O_Dnode; + Ghdl_Ieee_Assert_Failed : O_Dnode; + Ghdl_Psl_Assert_Failed : O_Dnode; + + Ghdl_Psl_Cover : O_Dnode; + Ghdl_Psl_Cover_Failed : O_Dnode; + -- Procedure for report statement. + Ghdl_Report : O_Dnode; + + -- Register a process. + Ghdl_Process_Register : O_Dnode; + Ghdl_Sensitized_Process_Register : O_Dnode; + 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; + Ghdl_Process_Wait_Exit : O_Dnode; + -- Complete form: + Ghdl_Process_Wait_Set_Timeout : O_Dnode; + Ghdl_Process_Wait_Add_Sensitivity : O_Dnode; + Ghdl_Process_Wait_Suspend : O_Dnode; + Ghdl_Process_Wait_Close : O_Dnode; + + -- Register a sensitivity for a process. + Ghdl_Process_Add_Sensitivity : O_Dnode; + + -- Register a driver for a process. + Ghdl_Process_Add_Driver : O_Dnode; + Ghdl_Signal_Add_Direct_Driver : O_Dnode; + + -- NOW variable. + Ghdl_Now : O_Dnode; + + -- Protected variables. + Ghdl_Protected_Enter : O_Dnode; + Ghdl_Protected_Leave : O_Dnode; + Ghdl_Protected_Init : O_Dnode; + Ghdl_Protected_Fini : O_Dnode; + + Ghdl_Signal_Set_Disconnect : O_Dnode; + Ghdl_Signal_Disconnect : O_Dnode; + + Ghdl_Signal_Driving : O_Dnode; + + Ghdl_Signal_Direct_Assign : O_Dnode; + + Ghdl_Signal_Simple_Assign_Error : O_Dnode; + Ghdl_Signal_Start_Assign_Error : O_Dnode; + Ghdl_Signal_Next_Assign_Error : O_Dnode; + + Ghdl_Signal_Start_Assign_Null : O_Dnode; + Ghdl_Signal_Next_Assign_Null : O_Dnode; + + Ghdl_Create_Signal_E8 : O_Dnode; + Ghdl_Signal_Init_E8 : O_Dnode; + Ghdl_Signal_Simple_Assign_E8 : O_Dnode; + Ghdl_Signal_Start_Assign_E8 : O_Dnode; + Ghdl_Signal_Next_Assign_E8 : O_Dnode; + Ghdl_Signal_Associate_E8 : O_Dnode; + Ghdl_Signal_Driving_Value_E8 : O_Dnode; + + Ghdl_Create_Signal_E32 : O_Dnode; + Ghdl_Signal_Init_E32 : O_Dnode; + Ghdl_Signal_Simple_Assign_E32 : O_Dnode; + Ghdl_Signal_Start_Assign_E32 : O_Dnode; + Ghdl_Signal_Next_Assign_E32 : O_Dnode; + Ghdl_Signal_Associate_E32 : O_Dnode; + Ghdl_Signal_Driving_Value_E32 : O_Dnode; + + Ghdl_Create_Signal_B1 : O_Dnode; + Ghdl_Signal_Init_B1 : O_Dnode; + Ghdl_Signal_Simple_Assign_B1 : O_Dnode; + Ghdl_Signal_Start_Assign_B1 : O_Dnode; + Ghdl_Signal_Next_Assign_B1 : O_Dnode; + Ghdl_Signal_Associate_B1 : O_Dnode; + Ghdl_Signal_Driving_Value_B1 : O_Dnode; + + Ghdl_Create_Signal_I32 : O_Dnode; + Ghdl_Signal_Init_I32 : O_Dnode; + Ghdl_Signal_Simple_Assign_I32 : O_Dnode; + Ghdl_Signal_Start_Assign_I32 : O_Dnode; + Ghdl_Signal_Next_Assign_I32 : O_Dnode; + Ghdl_Signal_Associate_I32 : O_Dnode; + Ghdl_Signal_Driving_Value_I32 : O_Dnode; + + Ghdl_Create_Signal_F64 : O_Dnode; + Ghdl_Signal_Init_F64 : O_Dnode; + Ghdl_Signal_Simple_Assign_F64 : O_Dnode; + Ghdl_Signal_Start_Assign_F64 : O_Dnode; + Ghdl_Signal_Next_Assign_F64 : O_Dnode; + Ghdl_Signal_Associate_F64 : O_Dnode; + Ghdl_Signal_Driving_Value_F64 : O_Dnode; + + Ghdl_Create_Signal_I64 : O_Dnode; + Ghdl_Signal_Init_I64 : O_Dnode; + Ghdl_Signal_Simple_Assign_I64 : O_Dnode; + Ghdl_Signal_Start_Assign_I64 : O_Dnode; + Ghdl_Signal_Next_Assign_I64 : O_Dnode; + Ghdl_Signal_Associate_I64 : O_Dnode; + Ghdl_Signal_Driving_Value_I64 : O_Dnode; + + Ghdl_Signal_In_Conversion : O_Dnode; + Ghdl_Signal_Out_Conversion : O_Dnode; + + Ghdl_Signal_Add_Source : O_Dnode; + Ghdl_Signal_Effective_Value : O_Dnode; + + Ghdl_Signal_Create_Resolution : O_Dnode; + + Ghdl_Signal_Name_Rti : O_Dnode; + Ghdl_Signal_Merge_Rti : O_Dnode; + + Ghdl_Signal_Get_Nbr_Drivers : O_Dnode; + Ghdl_Signal_Get_Nbr_Ports: O_Dnode; + Ghdl_Signal_Read_Driver : O_Dnode; + Ghdl_Signal_Read_Port : O_Dnode; + + -- Signal attribute. + Ghdl_Create_Stable_Signal : O_Dnode; + Ghdl_Create_Quiet_Signal : O_Dnode; + Ghdl_Create_Transaction_Signal : O_Dnode; + Ghdl_Signal_Attribute_Register_Prefix : O_Dnode; + Ghdl_Create_Delayed_Signal : O_Dnode; + + -- Guard signal. + Ghdl_Signal_Create_Guard : O_Dnode; + Ghdl_Signal_Guard_Dependence : O_Dnode; + + -- Predefined subprograms. + Ghdl_Memcpy : O_Dnode; + Ghdl_Deallocate : O_Dnode; + Ghdl_Malloc : O_Dnode; + Ghdl_Malloc0 : O_Dnode; + Ghdl_Real_Exp : O_Dnode; + Ghdl_Integer_Exp : O_Dnode; + + -- Procedure called in case of check failed. + Ghdl_Program_Error : O_Dnode; + Ghdl_Bound_Check_Failed_L1 : O_Dnode; + + -- Stack 2. + Ghdl_Stack2_Allocate : O_Dnode; + Ghdl_Stack2_Mark : O_Dnode; + Ghdl_Stack2_Release : O_Dnode; + + Std_Standard_Boolean_Rti : O_Dnode; + Std_Standard_Bit_Rti : O_Dnode; + + -- Predefined file subprograms. + Ghdl_Text_File_Elaborate : O_Dnode; + Ghdl_File_Elaborate : O_Dnode; + + Ghdl_Text_File_Finalize : O_Dnode; + Ghdl_File_Finalize : O_Dnode; + + Ghdl_Text_File_Open : O_Dnode; + Ghdl_File_Open : O_Dnode; + + Ghdl_Text_File_Open_Status : O_Dnode; + Ghdl_File_Open_Status : O_Dnode; + + Ghdl_Text_Write : O_Dnode; + Ghdl_Write_Scalar : O_Dnode; + + Ghdl_Read_Scalar : O_Dnode; + + Ghdl_Text_Read_Length : O_Dnode; + + Ghdl_Text_File_Close : O_Dnode; + Ghdl_File_Close : O_Dnode; + Ghdl_File_Flush : O_Dnode; + + Ghdl_File_Endfile : O_Dnode; + + -- 'Image attributes. + Ghdl_Image_B1 : O_Dnode; + Ghdl_Image_E8 : O_Dnode; + Ghdl_Image_E32 : O_Dnode; + Ghdl_Image_I32 : O_Dnode; + Ghdl_Image_P32 : O_Dnode; + Ghdl_Image_P64 : O_Dnode; + Ghdl_Image_F64 : O_Dnode; + + -- 'Value attributes + Ghdl_Value_B1 : O_Dnode; + Ghdl_Value_E8 : O_Dnode; + Ghdl_Value_E32 : O_Dnode; + Ghdl_Value_I32 : O_Dnode; + Ghdl_Value_P32 : O_Dnode; + Ghdl_Value_P64 : O_Dnode; + Ghdl_Value_F64 : O_Dnode; + + -- 'Path_Name + Ghdl_Get_Path_Name : O_Dnode; + Ghdl_Get_Instance_Name : O_Dnode; + + -- For PSL. + Ghdl_Std_Ulogic_To_Boolean_Array : O_Dnode; + + -- For std_logic_1164 (vhdl 2008). + Ghdl_Std_Ulogic_Match_Eq : O_Dnode; + Ghdl_Std_Ulogic_Match_Ne : O_Dnode; + Ghdl_Std_Ulogic_Match_Lt : O_Dnode; + Ghdl_Std_Ulogic_Match_Le : O_Dnode; + Ghdl_Std_Ulogic_Array_Match_Eq : O_Dnode; + Ghdl_Std_Ulogic_Array_Match_Ne : O_Dnode; + + -- For To_String (vhdl 2008). + Ghdl_To_String_I32 : O_Dnode; + Ghdl_To_String_F64 : O_Dnode; + Ghdl_To_String_F64_Digits : O_Dnode; + Ghdl_To_String_F64_Format : O_Dnode; + Ghdl_To_String_B1 : O_Dnode; + Ghdl_To_String_E8 : O_Dnode; + Ghdl_To_String_E32 : O_Dnode; + Ghdl_To_String_Char : O_Dnode; + Ghdl_To_String_P32 : O_Dnode; + Ghdl_To_String_P64 : O_Dnode; + Ghdl_Time_To_String_Unit : O_Dnode; + Ghdl_Array_Char_To_String_B1 : O_Dnode; + Ghdl_Array_Char_To_String_E8 : O_Dnode; + Ghdl_Array_Char_To_String_E32 : O_Dnode; + Ghdl_BV_To_String : O_Dnode; + Ghdl_BV_To_Ostring : O_Dnode; + Ghdl_BV_To_Hstring : O_Dnode; + + -- Register a package + Ghdl_Rti_Add_Package : O_Dnode; + Ghdl_Rti_Add_Top : O_Dnode; + + Ghdl_Elaborate : O_Dnode; +end Trans_Decls; diff --git a/src/translate/translation.adb b/src/translate/translation.adb new file mode 100644 index 0000000..7c5fbe8 --- /dev/null +++ b/src/translate/translation.adb @@ -0,0 +1,31355 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002, 2003, 2004, 2005, 2006 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System; +with Ada.Unchecked_Deallocation; +with Interfaces; use Interfaces; +with Ortho_Nodes; use Ortho_Nodes; +with Ortho_Ident; use Ortho_Ident; +with Evaluation; use Evaluation; +with Flags; use Flags; +with Ada.Text_IO; +with Types; use Types; +with Errorout; use Errorout; +with Name_Table; -- use Name_Table; +with Iirs_Utils; use Iirs_Utils; +with Std_Package; use Std_Package; +with Libraries; +with Files_Map; +with Std_Names; +with Configuration; +with Interfaces.C_Streams; +with Sem_Names; +with Sem_Inst; +with Sem; +with Iir_Chains; use Iir_Chains; +with Nodes; +with Nodes_Meta; +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; + +package body Translation is + + -- Ortho type node for STD.BOOLEAN. + 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; + + -- Ortho type for std.standard.integer. + Std_Integer_Otype : O_Tnode; + + -- Ortho type for std.standard.real. + Std_Real_Otype : O_Tnode; + + -- Ortho type node for std.standard.time. + Std_Time_Otype : O_Tnode; + + -- Node for the variable containing the current filename. + Current_Filename_Node : O_Dnode := O_Dnode_Null; + Current_Library_Unit : Iir := Null_Iir; + + -- Global declarations. + Ghdl_Ptr_Type : O_Tnode; + Sizetype : O_Tnode; + Ghdl_I32_Type : O_Tnode; + Ghdl_I64_Type : O_Tnode; + Ghdl_Real_Type : O_Tnode; + -- Constant character. + Char_Type_Node : O_Tnode; + -- Array of char. + Chararray_Type : O_Tnode; + -- Pointer to array of char. + Char_Ptr_Type : O_Tnode; + -- Array of char ptr. + Char_Ptr_Array_Type : O_Tnode; + Char_Ptr_Array_Ptr_Type : O_Tnode; + + Ghdl_Index_Type : O_Tnode; + Ghdl_Index_0 : O_Cnode; + Ghdl_Index_1 : O_Cnode; + + -- Type for a file (this is in fact a index in a private table). + Ghdl_File_Index_Type : O_Tnode; + Ghdl_File_Index_Ptr_Type : O_Tnode; + + -- Record containing a len and string fields. + Ghdl_Str_Len_Type_Node : O_Tnode; + Ghdl_Str_Len_Type_Len_Field : O_Fnode; + Ghdl_Str_Len_Type_Str_Field : O_Fnode; + Ghdl_Str_Len_Ptr_Node : O_Tnode; + Ghdl_Str_Len_Array_Type_Node : O_Tnode; + + -- Location. + Ghdl_Location_Type_Node : O_Tnode; + Ghdl_Location_Filename_Node : O_Fnode; + Ghdl_Location_Line_Node : O_Fnode; + Ghdl_Location_Col_Node : O_Fnode; + Ghdl_Location_Ptr_Node : O_Tnode; + + -- Allocate memory for a block. + Ghdl_Alloc_Ptr : O_Dnode; + + -- bool type. + Ghdl_Bool_Type : O_Tnode; + type Enode_Boolean_Array is array (Boolean) of O_Cnode; + Ghdl_Bool_Nodes : Enode_Boolean_Array; + Ghdl_Bool_False_Node : O_Cnode renames Ghdl_Bool_Nodes (False); + Ghdl_Bool_True_Node : O_Cnode renames Ghdl_Bool_Nodes (True); + + Ghdl_Bool_Array_Type : O_Tnode; + Ghdl_Bool_Array_Ptr : O_Tnode; + + -- Comparaison type. + Ghdl_Compare_Type : O_Tnode; + Ghdl_Compare_Lt : O_Cnode; + Ghdl_Compare_Eq : O_Cnode; + Ghdl_Compare_Gt : O_Cnode; + + -- Dir type. + Ghdl_Dir_Type_Node : O_Tnode; + Ghdl_Dir_To_Node : O_Cnode; + Ghdl_Dir_Downto_Node : O_Cnode; + + -- Signals. + Ghdl_Scalar_Bytes : O_Tnode; + Ghdl_Signal_Type : O_Tnode; + Ghdl_Signal_Value_Field : O_Fnode; + Ghdl_Signal_Driving_Value_Field : O_Fnode; + Ghdl_Signal_Last_Value_Field : O_Fnode; + Ghdl_Signal_Last_Event_Field : O_Fnode; + Ghdl_Signal_Last_Active_Field : O_Fnode; + Ghdl_Signal_Event_Field : O_Fnode; + Ghdl_Signal_Active_Field : O_Fnode; + Ghdl_Signal_Has_Active_Field : O_Fnode; + + Ghdl_Signal_Ptr : O_Tnode; + Ghdl_Signal_Ptr_Ptr : O_Tnode; + + type Object_Kind_Type is (Mode_Value, Mode_Signal); + + -- Well known identifiers. + 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; + Wki_Upframe : O_Ident; + Wki_Frame : O_Ident; + Wki_Val : O_Ident; + Wki_L_Len : O_Ident; + Wki_R_Len : O_Ident; + + -- ALLOCATION_KIND defines the type of memory storage. + -- ALLOC_STACK means the object is allocated on the local stack and + -- deallocated at the end of the function. + -- ALLOC_SYSTEM for object created during design elaboration and whose + -- life is infinite. + -- ALLOC_RETURN for unconstrained object returns by function. + -- ALLOC_HEAP for object created by new. + type Allocation_Kind is + (Alloc_Stack, Alloc_Return, Alloc_Heap, Alloc_System); + + package Chap10 is + -- There are three data storage kind: global, local or instance. + -- For example, a constant can have: + -- * a global storage when declared inside a package. This storage + -- can be accessed from any point. + -- * a local storage when declared in a subprogram. This storage + -- can be accessed from the subprogram, is created when the subprogram + -- is called and destroy when the subprogram exit. + -- * an instance storage when declared inside a process. This storage + -- can be accessed from the process via an instance pointer, is + -- created during elaboration. + --procedure Push_Global_Factory (Storage : O_Storage); + --procedure Pop_Global_Factory; + procedure Set_Global_Storage (Storage : O_Storage); + + -- Set the global scope handling. + Global_Storage : O_Storage; + + -- Scope for variables. This is used both to build instances (so it + -- contains the record type that contains objects declared in that + -- scope) and to use instances (it contains the path to access to these + -- objects). + type Var_Scope_Type is private; + + type Var_Scope_Acc is access all Var_Scope_Type; + for Var_Scope_Acc'Storage_Size use 0; + + Null_Var_Scope : constant Var_Scope_Type; + + type Var_Type is private; + Null_Var : constant Var_Type; + + -- Return the record type for SCOPE. + function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode; + + -- Return the size for instances of SCOPE. + function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode; + + -- Return True iff SCOPE is defined. + function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean; + + -- Create an empty and incomplete scope type for SCOPE using NAME. + procedure Predeclare_Scope_Type (Scope : Var_Scope_Acc; Name : O_Ident); + + -- Declare a pointer PTR_TYPE with NAME to scope type SCOPE. + procedure Declare_Scope_Acc + (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode); + + -- Start to build an instance. + -- If INSTANCE_TYPE is not O_TNODE_NULL, it must be an uncompleted + -- record type, that will be completed. + procedure Push_Instance_Factory (Scope : Var_Scope_Acc); + + -- Manually add a field to the current instance being built. + function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) + return O_Fnode; + + -- In the scope being built, add a field NAME that contain sub-scope + -- CHILD. CHILD is modified so that accesses to CHILD objects is done + -- via SCOPE. + procedure Add_Scope_Field + (Name : O_Ident; Child : in out Var_Scope_Type); + + -- Return the offset of field for CHILD in its parent scope. + function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode) + return O_Cnode; + + -- Finish the building of the current instance and return the type + -- built. + procedure Pop_Instance_Factory (Scope : Var_Scope_Acc); + + -- Create a new scope, in which variable are created locally + -- (ie, on the stack). Always created unlocked. + procedure Push_Local_Factory; + + -- Destroy a local scope. + procedure Pop_Local_Factory; + + -- Set_Scope defines how to access to variables of SCOPE. + -- Variables defined in SCOPE can be accessed via field SCOPE_FIELD + -- in scope SCOPE_PARENT. + procedure Set_Scope_Via_Field + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc); + + -- Variables defined in SCOPE can be accessed by dereferencing + -- field SCOPE_FIELD defined in SCOPE_PARENT. + procedure Set_Scope_Via_Field_Ptr + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc); + + -- Variables/scopes defined in SCOPE can be accessed via + -- dereference of parameter SCOPE_PARAM. + procedure Set_Scope_Via_Param_Ptr + (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode); + + -- Variables/scopes defined in SCOPE can be accessed via DECL. + procedure Set_Scope_Via_Decl + (Scope : in out Var_Scope_Type; Decl : O_Dnode); + + -- Variables/scopes defined in SCOPE can be accessed by derefencing + -- VAR. + procedure Set_Scope_Via_Var_Ptr + (Scope : in out Var_Scope_Type; Var : Var_Type); + + -- No more accesses to SCOPE_TYPE are allowed. Scopes must be cleared + -- before being set. + procedure Clear_Scope (Scope : in out Var_Scope_Type); + + -- Reset the identifier. + type Id_Mark_Type is limited private; + type Local_Identifier_Type is private; + + procedure Reset_Identifier_Prefix; + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : String; + Val : Iir_Int32 := 0); + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : Name_Id; + Val : Iir_Int32 := 0); + procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type); + procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type); + + -- Save/restore the local identifier number; this is used by package + -- body, which has the same prefix as the package declaration, so it + -- must continue local identifiers numbers. + -- This is used by subprogram bodies too. + procedure Save_Local_Identifier (Id : out Local_Identifier_Type); + procedure Restore_Local_Identifier (Id : Local_Identifier_Type); + + -- Create an identifier from IIR node ID without the prefix. + function Create_Identifier_Without_Prefix (Id : Iir) + return O_Ident; + function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) + return O_Ident; + + -- Create an identifier from the current prefix. + function Create_Identifier return O_Ident; + + -- Create an identifier from IIR node ID with prefix. + function Create_Identifier (Id : Iir; Str : String := "") + return O_Ident; + function Create_Identifier + (Id : Iir; Val : Iir_Int32; Str : String := "") + return O_Ident; + function Create_Identifier (Id : Name_Id; Str : String := "") + return O_Ident; + -- Create a prefixed identifier from a string. + function Create_Identifier (Str : String) return O_Ident; + + -- Create an identifier for a variable. + -- IE, if the variable is global, prepend the prefix, + -- if the variable belong to an instance, no prefix is added. + type Var_Ident_Type is private; + function Create_Var_Identifier (Id : Iir) return Var_Ident_Type; + function Create_Var_Identifier (Id : String) return Var_Ident_Type; + function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural) + return Var_Ident_Type; + function Create_Uniq_Identifier return Var_Ident_Type; + + -- Create variable NAME of type VTYPE in the current scope. + -- If the current scope is the global scope, then a variable is + -- created at the top level (using decl_global_storage). + -- If the current scope is not the global scope, then a field is added + -- to the current scope. + function Create_Var + (Name : Var_Ident_Type; + Vtype : O_Tnode; + Storage : O_Storage := Global_Storage) + return Var_Type; + + -- Create a global variable. + function Create_Global_Var + (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) + return Var_Type; + + -- Create a global constant and initialize it to INITIAL_VALUE. + function Create_Global_Const + (Name : O_Ident; + Vtype : O_Tnode; + Storage : O_Storage; + Initial_Value : O_Cnode) + return Var_Type; + procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode); + + -- Return the (real) reference to a variable created by Create_Var. + function Get_Var (Var : Var_Type) return O_Lnode; + + -- Return a reference to the instance of type ITYPE. + function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode; + + -- Return the address of the instance for block BLOCK. + function Get_Instance_Access (Block : Iir) return O_Enode; + + -- Return the storage for the variable VAR. + function Get_Alloc_Kind_For_Var (Var : Var_Type) return Allocation_Kind; + + -- Return TRUE iff VAR is stable, ie get_var (VAR) can be referenced + -- several times. + function Is_Var_Stable (Var : Var_Type) return Boolean; + + -- Used only to generate RTI. + function Is_Var_Field (Var : Var_Type) return Boolean; + function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode; + function Get_Var_Label (Var : Var_Type) return O_Dnode; + + -- For package instantiation. + + -- Associate INST_SCOPE as the instantiated scope for ORIG_SCOPE. + procedure Push_Instantiate_Var_Scope + (Inst_Scope : Var_Scope_Acc; Orig_Scope : Var_Scope_Acc); + + -- Remove the association for INST_SCOPE. + procedure Pop_Instantiate_Var_Scope + (Inst_Scope : Var_Scope_Acc); + + -- Get the associated instantiated scope for SCOPE. + function Instantiated_Var_Scope (Scope : Var_Scope_Acc) + return Var_Scope_Acc; + + -- Create a copy of VAR using instantiated scope (if needed). + function Instantiate_Var (Var : Var_Type) return Var_Type; + + -- Create a copy of SCOPE using instantiated scope (if needed). + function Instantiate_Var_Scope (Scope : Var_Scope_Type) + return Var_Scope_Type; + private + type Local_Identifier_Type is new Natural; + type Id_Mark_Type is record + Len : Natural; + Local_Id : Local_Identifier_Type; + end record; + + type Var_Ident_Type is record + Id : O_Ident; + end record; + + -- An instance contains all the data (variable, signals, constant...) + -- which are declared by an entity and an architecture. + -- (An architecture inherits the data of its entity). + -- + -- The processes and implicit guard signals of an entity/architecture + -- are translated into functions. The first argument of these functions + -- is a pointer to the instance. + + type Inst_Build_Kind_Type is (Local, Global, Instance); + type Inst_Build_Type (Kind : Inst_Build_Kind_Type); + type Inst_Build_Acc is access Inst_Build_Type; + type Inst_Build_Type (Kind : Inst_Build_Kind_Type) is record + Prev : Inst_Build_Acc; + Prev_Id_Start : Natural; + case Kind is + when Local => + -- Previous global storage. + Prev_Global_Storage : O_Storage; + when Global => + null; + when Instance => + Scope : Var_Scope_Acc; + Elements : O_Element_List; + end case; + end record; + + -- Kind of variable: + -- VAR_NONE: the variable doesn't exist. + -- VAR_GLOBAL: the variable is a global variable (static or not). + -- VAR_LOCAL: the variable is on the stack. + -- VAR_SCOPE: the variable is in the instance record. + type Var_Kind is (Var_None, Var_Global, Var_Local, Var_Scope); + + type Var_Type (Kind : Var_Kind := Var_None) is record + case Kind is + when Var_None => + null; + when Var_Global + | Var_Local => + E : O_Dnode; + when Var_Scope => + I_Field : O_Fnode; + I_Scope : Var_Scope_Acc; + end case; + end record; + + Null_Var : constant Var_Type := (Kind => Var_None); + + type Var_Scope_Kind is (Var_Scope_None, + Var_Scope_Ptr, + Var_Scope_Decl, + Var_Scope_Field, + Var_Scope_Field_Ptr); + + type Var_Scope_Type (Kind : Var_Scope_Kind := Var_Scope_None) is record + Scope_Type : O_Tnode := O_Tnode_Null; + + case Kind is + when Var_Scope_None => + -- Not set, cannot be referenced. + null; + when Var_Scope_Ptr + | Var_Scope_Decl => + -- Instance for entity, architecture, component, subprogram, + -- resolver, process, guard function, PSL directive, PSL cover, + -- PSL assert, component instantiation elaborator + D : O_Dnode; + when Var_Scope_Field + | Var_Scope_Field_Ptr => + -- For an entity: the architecture. + -- For an architecture: ptr to a generate subblock. + -- For a subprogram: parent frame + Field : O_Fnode; + Up_Link : Var_Scope_Acc; + end case; + end record; + + Null_Var_Scope : constant Var_Scope_Type := (Scope_Type => O_Tnode_Null, + Kind => Var_Scope_None); + + end Chap10; + use Chap10; + + package Chap1 is + -- Declare types for block BLK + procedure Start_Block_Decl (Blk : Iir); + + procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration); + + -- Generate code to initialize generics of instance INSTANCE of ENTITY + -- using the default values. + -- This is used when ENTITY is at the top of a design hierarchy. + procedure Translate_Entity_Init (Entity : Iir); + + procedure Translate_Architecture_Body (Arch : Iir); + + -- CONFIG may be one of: + -- * configuration_declaration + -- * component_configuration + procedure Translate_Configuration_Declaration (Config : Iir); + end Chap1; + + package Chap2 is + -- Subprogram specification being currently translated. This is used + -- for the return statement. + Current_Subprogram : Iir := Null_Iir; + + procedure Translate_Subprogram_Interfaces (Spec : Iir); + procedure Elab_Subprogram_Interfaces (Spec : Iir); + + procedure Translate_Subprogram_Declaration (Spec : Iir); + procedure Translate_Subprogram_Body (Subprg : Iir); + + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type); + + procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration); + procedure Translate_Package_Body (Decl : Iir_Package_Body); + procedure Translate_Package_Instantiation_Declaration (Inst : Iir); + + procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir); + + -- Add info for an interface_package_declaration or a + -- package_instantiation_declaration + procedure Instantiate_Info_Package (Inst : Iir); + + -- Elaborate packages that DESIGN_UNIT depends on (except std.standard). + procedure Elab_Dependence (Design_Unit: Iir_Design_Unit); + + -- Declare an incomplete record type DECL_TYPE and access PTR_TYPE to + -- it. The names are respectively INSTTYPE and INSTPTR. + procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc; + Ptr_Type : out O_Tnode); + + -- Subprograms instances. + -- + -- Subprograms declared inside entities, architecture, blocks + -- or processes (but not inside packages) may access to data declared + -- outside the subprogram (and this with a life longer than the + -- subprogram life). These data correspond to constants, variables, + -- files, signals or types. However these data are not shared between + -- instances of the same entity, architecture... Subprograms instances + -- is the way subprograms access to these data. + -- One subprogram instance corresponds to a record. + + -- Type to save an old instance builder. Subprograms may have at most + -- one instance. If they need severals (for example a protected + -- subprogram), the most recent one will have a reference to the + -- previous one. + type Subprg_Instance_Stack is limited private; + + -- Declare an instance to be added for subprograms. + -- DECL is the node for which the instance is created. This is used by + -- PUSH_SCOPE. + -- PTR_TYPE is a pointer to DECL_TYPE. + -- IDENT is an identifier for the interface. + -- The previous instance is stored to PREV. It must be restored with + -- Pop_Subprg_Instance. + -- Add_Subprg_Instance_Interfaces will add an interface of name IDENT + -- and type PTR_TYPE for every instance declared by + -- PUSH_SUBPRG_INSTANCE. + procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; + Ptr_Type : O_Tnode; + Ident : O_Ident; + Prev : out Subprg_Instance_Stack); + + -- Since local subprograms has a direct access to its father interfaces, + -- they do not required instances interfaces. + -- These procedures are provided to temporarly disable the addition of + -- instances interfaces. Use Pop_Subpg_Instance to restore to the + -- previous state. + procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack); + + -- Revert of the previous subprogram. + -- Instances must be removed in opposite order they are added. + procedure Pop_Subprg_Instance (Ident : O_Ident; + Prev : Subprg_Instance_Stack); + + -- True iff there is currently a subprogram instance. + function Has_Current_Subprg_Instance return Boolean; + + -- Contains the subprogram interface for the instance. + type Subprg_Instance_Type is private; + Null_Subprg_Instance : constant Subprg_Instance_Type; + + -- Add interfaces during the creation of a subprogram. + procedure Add_Subprg_Instance_Interfaces + (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type); + + -- Add a field in the current factory that reference the current + -- instance. + procedure Add_Subprg_Instance_Field (Field : out O_Fnode); + + -- Associate values to the instance interface during invocation of a + -- subprogram. + procedure Add_Subprg_Instance_Assoc + (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type); + + -- Get the value to be associated to the instance interface. + function Get_Subprg_Instance (Vars : Subprg_Instance_Type) + return O_Enode; + + -- True iff VARS is associated with an instance. + function Has_Subprg_Instance (Vars : Subprg_Instance_Type) + return Boolean; + + -- Assign the instance field FIELD of VAR. + procedure Set_Subprg_Instance_Field + (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type); + + -- To be called at the beginning and end of a subprogram body creation. + -- Call PUSH_SCOPE for the subprogram intances. + procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type); + procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type); + + -- Call Push_Scope to reference instance from FIELD. + procedure Start_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode); + procedure Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode); + + -- Same as above, but for IIR. + procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List; + Subprg : Iir); + + procedure Start_Subprg_Instance_Use (Subprg : Iir); + procedure Finish_Subprg_Instance_Use (Subprg : Iir); + + function Instantiate_Subprg_Instance (Inst : Subprg_Instance_Type) + return Subprg_Instance_Type; + private + type Subprg_Instance_Type is record + Inter : O_Dnode; + Inter_Type : O_Tnode; + Scope : Var_Scope_Acc; + end record; + Null_Subprg_Instance : constant Subprg_Instance_Type := + (O_Dnode_Null, O_Tnode_Null, null); + + type Subprg_Instance_Stack is record + Scope : Var_Scope_Acc; + Ptr_Type : O_Tnode; + Ident : O_Ident; + end record; + + Null_Subprg_Instance_Stack : constant Subprg_Instance_Stack := + (null, O_Tnode_Null, O_Ident_Nul); + + Current_Subprg_Instance : Subprg_Instance_Stack := + Null_Subprg_Instance_Stack; + end Chap2; + + package Chap5 is + -- Attribute specification. + procedure Translate_Attribute_Specification + (Spec : Iir_Attribute_Specification); + procedure Elab_Attribute_Specification + (Spec : Iir_Attribute_Specification); + + -- Disconnection specification. + procedure Elab_Disconnection_Specification + (Spec : Iir_Disconnection_Specification); + + -- Elab an unconstrained port. + procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir); + + procedure Elab_Generic_Map_Aspect (Mapping : Iir); + + -- There are 4 cases of generic/port map: + -- 1) component instantiation + -- 2) component configuration (association of a component with an entity + -- / architecture) + -- 3) block header + -- 4) direct (entity + architecture or configuration) instantiation + -- + -- MAPPING is the node containing the generic/port map aspects. + procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir); + end Chap5; + + + package Chap8 is + procedure Translate_Statements_Chain (First : Iir); + + -- Return true if there is a return statement in the chain. + function Translate_Statements_Chain_Has_Return (First : Iir) + return Boolean; + + -- Create a case branch for CHOICE. + -- Used by case statement and aggregates. + procedure Translate_Case_Choice + (Choice : Iir; Choice_Type : Iir; Blk : in out O_Case_Block); + + -- Inc or dec by VAL ITERATOR according to DIR. + -- Used for loop statements. + procedure Gen_Update_Iterator (Iterator : O_Dnode; + Dir : Iir_Direction; + Val : Unsigned_64; + Itype : Iir); + + procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir); + end Chap8; + + package Chap9 is + procedure Translate_Block_Declarations (Block : Iir; Origin : Iir); + procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir); + procedure Elab_Block_Declarations (Block : Iir; Base_Block : Iir); + + -- Generate code to instantiate an entity. + -- ASPECT must be an entity_aspect. + -- MAPPING must be a node with get_port/generic_map_aspect_list. + -- PARENT is the block in which the instantiation is done. + -- CONFIG_OVERRIDE, if set, is the configuration to use; if not set, the + -- configuration to use is determined from ASPECT. + procedure Translate_Entity_Instantiation + (Aspect : Iir; Mapping : Iir; Parent : Iir; Config_Override : Iir); + + end Chap9; + + package Rtis is + -- Run-Time Information (RTI) Kind. + Ghdl_Rtik : O_Tnode; + Ghdl_Rtik_Top : O_Cnode; + Ghdl_Rtik_Library : O_Cnode; + Ghdl_Rtik_Package : O_Cnode; + Ghdl_Rtik_Package_Body : O_Cnode; + Ghdl_Rtik_Entity : O_Cnode; + Ghdl_Rtik_Architecture : O_Cnode; + Ghdl_Rtik_Process : O_Cnode; + Ghdl_Rtik_Block : O_Cnode; + Ghdl_Rtik_If_Generate : O_Cnode; + Ghdl_Rtik_For_Generate : O_Cnode; + Ghdl_Rtik_Instance : O_Cnode; + Ghdl_Rtik_Constant : O_Cnode; + Ghdl_Rtik_Iterator : O_Cnode; + Ghdl_Rtik_Variable : O_Cnode; + Ghdl_Rtik_Signal : O_Cnode; + Ghdl_Rtik_File : O_Cnode; + Ghdl_Rtik_Port : O_Cnode; + Ghdl_Rtik_Generic : O_Cnode; + Ghdl_Rtik_Alias : O_Cnode; + Ghdl_Rtik_Guard : O_Cnode; + Ghdl_Rtik_Component : O_Cnode; + Ghdl_Rtik_Attribute : O_Cnode; + Ghdl_Rtik_Type_B1 : O_Cnode; + Ghdl_Rtik_Type_E8 : O_Cnode; + Ghdl_Rtik_Type_E32 : O_Cnode; + Ghdl_Rtik_Type_I32 : O_Cnode; + Ghdl_Rtik_Type_I64 : O_Cnode; + Ghdl_Rtik_Type_F64 : O_Cnode; + Ghdl_Rtik_Type_P32 : O_Cnode; + Ghdl_Rtik_Type_P64 : O_Cnode; + Ghdl_Rtik_Type_Access : O_Cnode; + Ghdl_Rtik_Type_Array : O_Cnode; + Ghdl_Rtik_Type_Record : O_Cnode; + Ghdl_Rtik_Type_File : O_Cnode; + Ghdl_Rtik_Subtype_Scalar : O_Cnode; + Ghdl_Rtik_Subtype_Array : O_Cnode; + Ghdl_Rtik_Subtype_Unconstrained_Array : O_Cnode; + Ghdl_Rtik_Subtype_Record : O_Cnode; + Ghdl_Rtik_Subtype_Access : O_Cnode; + Ghdl_Rtik_Type_Protected : O_Cnode; + Ghdl_Rtik_Element : O_Cnode; + Ghdl_Rtik_Unit64 : O_Cnode; + Ghdl_Rtik_Unitptr : O_Cnode; + 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. + Ghdl_Rti_Depth : O_Tnode; + Ghdl_Rti_U8 : O_Tnode; + + -- Common node. + Ghdl_Rti_Common : O_Tnode; + Ghdl_Rti_Common_Kind : O_Fnode; + Ghdl_Rti_Common_Depth : O_Fnode; + Ghdl_Rti_Common_Mode : O_Fnode; + Ghdl_Rti_Common_Max_Depth : O_Fnode; + + -- Node accesses and arrays. + Ghdl_Rti_Access : O_Tnode; + Ghdl_Rti_Array : O_Tnode; + Ghdl_Rti_Arr_Acc : O_Tnode; + + -- Instance link. + -- This is a structure at the beginning of each entity/architecture + -- instance. This allow the run-time to find the parent of an instance. + Ghdl_Entity_Link_Type : O_Tnode; + -- RTI for this instance. + Ghdl_Entity_Link_Rti : O_Fnode; + -- RTI of the parent, which has instancied the instance. + Ghdl_Entity_Link_Parent : O_Fnode; + + Ghdl_Component_Link_Type : O_Tnode; + -- Pointer to a Ghdl_Entity_Link_Type, which is the entity instantiated. + Ghdl_Component_Link_Instance : O_Fnode; + -- RTI for the component instantiation statement. + Ghdl_Component_Link_Stmt : O_Fnode; + + -- Access to Ghdl_Entity_Link_Type. + Ghdl_Entity_Link_Acc : O_Tnode; + -- Access to a Ghdl_Component_Link_Type. + Ghdl_Component_Link_Acc : O_Tnode; + + -- Generate initial rti declarations. + procedure Rti_Initialize; + + -- Get address (as Ghdl_Rti_Access) of constant RTI. + function New_Rti_Address (Rti : O_Dnode) return O_Cnode; + + -- Generate rtis for a library unit. + procedure Generate_Unit (Lib_Unit : Iir); + + -- Generate a constant declaration for SIG; but do not set its value. + procedure Generate_Signal_Rti (Sig : Iir); + + -- Generate RTIs for subprogram body BOD. + procedure Generate_Subprogram_Body (Bod : Iir); + + -- Generate RTI for LIB. If PUBLIC is FALSE, only generate the + -- declaration as external. + procedure Generate_Library (Lib : Iir_Library_Declaration; + Public : Boolean); + + -- Generate RTI for the top of the hierarchy. Return the maximum number + -- of packages. + procedure Generate_Top (Nbr_Pkgs : out Natural); + + -- Add two associations to ASSOC to add an rti_context for NODE. + procedure Associate_Rti_Context + (Assoc : in out O_Assoc_List; Node : Iir); + procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List); + + function Get_Context_Rti (Node : Iir) return O_Cnode; + function Get_Context_Addr (Node : Iir) return O_Enode; + end Rtis; + + type Ortho_Info_Kind is + ( + Kind_Type, + Kind_Incomplete_Type, + Kind_Index, + Kind_Expr, + Kind_Subprg, + Kind_Object, + Kind_Alias, + Kind_Iterator, + Kind_Interface, + Kind_Disconnect, + Kind_Process, + Kind_Psl_Directive, + Kind_Loop, + Kind_Block, + Kind_Component, + Kind_Field, + Kind_Package, + Kind_Package_Instance, + Kind_Config, + Kind_Assoc, + Kind_Str_Choice, + Kind_Design_File, + Kind_Library + ); + + type Ortho_Info_Type_Kind is + ( + Kind_Type_Scalar, + Kind_Type_Array, + Kind_Type_Record, + Kind_Type_File, + Kind_Type_Protected + ); + type O_Tnode_Array is array (Object_Kind_Type) of O_Tnode; + type O_Fnode_Array is array (Object_Kind_Type) of O_Fnode; + + type Rti_Depth_Type is new Natural range 0 .. 255; + + type Ortho_Info_Type_Type (Kind : Ortho_Info_Type_Kind := Kind_Type_Scalar) + is record + -- For all types: + -- This is the maximum depth of RTI, that is the max of the depth of + -- the type itself and every types it depends on. + Rti_Max_Depth : Rti_Depth_Type; + + case Kind is + when Kind_Type_Scalar => + -- For scalar types: + -- True if no need to check against low/high bound. + Nocheck_Low : Boolean := False; + Nocheck_Hi : Boolean := False; + + -- Ortho type for the range record type. + Range_Type : O_Tnode; + + -- Ortho type for an access to the range record type. + Range_Ptr_Type : O_Tnode; + + -- Tree for the range record declaration. + Range_Var : Var_Type; + + -- Fields of TYPE_RANGE_TYPE. + Range_Left : O_Fnode; + Range_Right : O_Fnode; + Range_Dir : O_Fnode; + Range_Length : O_Fnode; + + when Kind_Type_Array => + Base_Type : O_Tnode_Array; + Base_Ptr_Type : O_Tnode_Array; + Bounds_Type : O_Tnode; + Bounds_Ptr_Type : O_Tnode; + + Base_Field : O_Fnode_Array; + Bounds_Field : O_Fnode_Array; + + -- True if the array bounds are static. + Static_Bounds : Boolean; + + -- Variable containing the bounds for a constrained array. + Array_Bounds : Var_Type; + + -- Variable containing a 1 length bound for unidimensional + -- unconstrained arrays. + Array_1bound : Var_Type; + + -- Variable containing the description for each index. + Array_Index_Desc : Var_Type; + + when Kind_Type_Record => + -- Variable containing the description for each element. + Record_El_Desc : Var_Type; + + when Kind_Type_File => + -- Constant containing the signature of the file. + File_Signature : O_Dnode; + + when Kind_Type_Protected => + Prot_Scope : aliased Var_Scope_Type; + + -- Init procedure for the protected type. + Prot_Init_Subprg : O_Dnode; + Prot_Init_Instance : Chap2.Subprg_Instance_Type; + -- Final procedure. + Prot_Final_Subprg : O_Dnode; + Prot_Final_Instance : Chap2.Subprg_Instance_Type; + -- The outer instance, if any. + Prot_Subprg_Instance_Field : O_Fnode; + -- The LOCK field in the object type + Prot_Lock_Field : O_Fnode; + end case; + end record; + +-- Ortho_Info_Type_Scalar_Init : constant Ortho_Info_Type_Type := +-- (Kind => Kind_Type_Scalar, +-- Range_Type => O_Tnode_Null, +-- Range_Ptr_Type => O_Tnode_Null, +-- Range_Var => null, +-- Range_Left => O_Fnode_Null, +-- Range_Right => O_Fnode_Null, +-- Range_Dir => O_Fnode_Null, +-- Range_Length => O_Fnode_Null); + + Ortho_Info_Type_Array_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Array, + Rti_Max_Depth => 0, + Base_Type => (O_Tnode_Null, O_Tnode_Null), + Base_Ptr_Type => (O_Tnode_Null, O_Tnode_Null), + Bounds_Type => O_Tnode_Null, + Bounds_Ptr_Type => O_Tnode_Null, + Base_Field => (O_Fnode_Null, O_Fnode_Null), + Bounds_Field => (O_Fnode_Null, O_Fnode_Null), + Static_Bounds => False, + Array_Bounds => Null_Var, + Array_1bound => Null_Var, + Array_Index_Desc => Null_Var); + + Ortho_Info_Type_Record_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Record, + Rti_Max_Depth => 0, + Record_El_Desc => Null_Var); + + Ortho_Info_Type_File_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_File, + Rti_Max_Depth => 0, + File_Signature => O_Dnode_Null); + + Ortho_Info_Type_Prot_Init : constant Ortho_Info_Type_Type := + (Kind => Kind_Type_Protected, + Rti_Max_Depth => 0, + Prot_Scope => Null_Var_Scope, + Prot_Init_Subprg => O_Dnode_Null, + Prot_Init_Instance => Chap2.Null_Subprg_Instance, + Prot_Final_Subprg => O_Dnode_Null, + Prot_Subprg_Instance_Field => O_Fnode_Null, + Prot_Final_Instance => Chap2.Null_Subprg_Instance, + Prot_Lock_Field => O_Fnode_Null); + + -- Mode of the type; roughly speaking, this corresponds to its size + -- (for scalars) or its layout (for composite types). + -- Used to select library subprograms for signals. + type Type_Mode_Type is + ( + -- Unknown mode. + Type_Mode_Unknown, + -- Boolean type, with 2 elements. + Type_Mode_B1, + -- Enumeration with at most 256 elements. + Type_Mode_E8, + -- Enumeration with more than 256 elements. + Type_Mode_E32, + -- Integer types. + Type_Mode_I32, + Type_Mode_I64, + -- Physical types. + Type_Mode_P32, + Type_Mode_P64, + -- Floating point type. + Type_Mode_F64, + -- File type. + Type_Mode_File, + -- Thin access. + Type_Mode_Acc, + + -- Fat access. + Type_Mode_Fat_Acc, + + -- Record. + Type_Mode_Record, + -- Protected type + Type_Mode_Protected, + -- Constrained array type (length is known at compile-time). + Type_Mode_Array, + -- Fat array type (used for unconstrained array). + Type_Mode_Fat_Array); + + subtype Type_Mode_Scalar is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_F64; + + subtype Type_Mode_Non_Composite is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_Fat_Acc; + + -- Composite types, with the vhdl meaning: record and arrays. + subtype Type_Mode_Composite is Type_Mode_Type + range Type_Mode_Record .. Type_Mode_Fat_Array; + + -- Array types. + subtype Type_Mode_Arrays is Type_Mode_Type range + Type_Mode_Array .. Type_Mode_Fat_Array; + + -- Thin types, ie types whose length is a scalar. + subtype Type_Mode_Thin is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_Acc; + + -- Fat types, ie types whose length is longer than a scalar. + subtype Type_Mode_Fat is Type_Mode_Type + range Type_Mode_Fat_Acc .. Type_Mode_Fat_Array; + + -- These parameters are passed by value, ie the argument of the subprogram + -- is the value of the object. + subtype Type_Mode_By_Value is Type_Mode_Type + range Type_Mode_B1 .. Type_Mode_Acc; + + -- These parameters are passed by copy, ie a copy of the object is created + -- and the reference of the copy is passed. If the object is not + -- modified by the subprogram, the object could be passed by reference. + subtype Type_Mode_By_Copy is Type_Mode_Type + range Type_Mode_Fat_Acc .. Type_Mode_Fat_Acc; + + -- The parameters are passed by reference, ie the argument of the + -- subprogram is an address to the object. + subtype Type_Mode_By_Ref is Type_Mode_Type + range Type_Mode_Record .. Type_Mode_Fat_Array; + + -- Additional informations for a resolving function. + type Subprg_Resolv_Info is record + Resolv_Func : O_Dnode; + -- Parameter nodes. + Var_Instance : Chap2.Subprg_Instance_Type; + + -- Signals + Var_Vals : O_Dnode; + -- Driving vector. + Var_Vec : O_Dnode; + -- Length of Vector. + Var_Vlen : O_Dnode; + Var_Nbr_Drv : O_Dnode; + Var_Nbr_Ports : O_Dnode; + end record; + type Subprg_Resolv_Info_Acc is access Subprg_Resolv_Info; + + -- Complex types. + -- + -- A complex type is not a VHDL notion, but a translation notion. + -- A complex type is a composite type whose size is not known at compile + -- type. This happends in VHDL because a bound can be globally static. + -- Therefore, the length of an array may not be known at compile type, + -- and this propagates to composite types (record and array) if they + -- have such an element. This is different from unconstrained arrays. + -- + -- This occurs frequently in VHDL, and could even happen within + -- subprograms. + -- + -- Such types are always dynamically allocated (on the stack or on the + -- heap). They must be continuous in memory so that they could be copied + -- via memcpy/memmove. + -- + -- At runtime, the size of such type is computed. A builder procedure + -- is also created to setup inner pointers. This builder procedure should + -- be called at initialization, but also after a copy. + -- + -- Example: + -- 1) subtype bv_type is bit_vector (l to h); + -- variable a : bv_type + -- + -- This is represented by a pointer to an array of bit. No need for + -- builder procedure, as the element type is not complex. But there + -- is a size variable for the size of bv_type + -- + -- 2) type rec1_type is record + -- f1 : integer; + -- f2 : bv_type; + -- end record; + -- + -- This is represented by a pointer to a record. The 'f2' field is + -- an offset to an array of bit. The size of the object is the size + -- of the record (with f2 as a pointer) + the size of bv_type. + -- The alinment of the object is the maximum alignment of its sub- + -- objects: rec1 and bv_type. + -- A builder procedure is needed to initialize the 'f2' field. + -- The memory layout is: + -- +--------------+ + -- | rec1: f1 | + -- | f2 |---+ + -- +--------------+ | + -- | bv_type |<--+ + -- | ... | + -- +--------------+ + -- + -- 3) type rec2_type is record + -- g1: rec1_type; + -- g2: bv_type; + -- g3: bv_type; + -- end record; + -- + -- This is represented by a pointer to a record. All the three fields + -- are offset (relative to rec2). Alignment is the maximum alignment of + -- the sub-objects (rec2, rec1, bv_type x 3). + -- The memory layout is: + -- +--------------+ + -- | rec2: g1 |---+ + -- | g2 |---|---+ + -- | g3 |---|---|---+ + -- +--------------+ | | | + -- | rec1: f1 |<--+ | | + -- | f2 |---+ | | + -- +--------------+ | | | + -- | bv_type (f2) |<--+ | | + -- | ... | | | + -- +--------------+ | | + -- | bv_type (g2) |<------+ | + -- | ... | | + -- +--------------+ | + -- | bv_type (g3) |<----------+ + -- | ... | + -- +--------------+ + -- + -- 4) type bv_arr_type is array (natural range <>) of bv_type; + -- arr2 : bv_arr_type (1 to 4) + -- + -- This should be represented by a pointer to bv_type. + -- The memory layout is: + -- +--------------+ + -- | bv_type (1) | + -- | ... | + -- +--------------+ + -- | bv_type (2) | + -- | ... | + -- +--------------+ + -- | bv_type (3) | + -- | ... | + -- +--------------+ + -- | bv_type (4) | + -- | ... | + -- +--------------+ + + -- Additional info for complex types. + type Complex_Type_Info is record + -- Variable containing the size of the type. + -- This is defined only for types whose size is only known at + -- running time (and not a compile-time). + Size_Var : Var_Type; + + -- Variable containing the alignment of the type. + -- Only defined for recods and for Mode_Value. + -- Note: this is not optimal, because the alignment could be computed + -- at compile time, but there is no way to do that with ortho (no + -- operation on constants). Furthermore, the alignment is independent + -- of the instance, so there could be one global variable. But this + -- doesn't fit in the whole machinery (in particular, there is no + -- easy way to compute it once). As the overhead is very low, no need + -- to bother with this issue. + Align_Var : Var_Type; + + Builder_Need_Func : Boolean; + + -- Parameters for type builders. + -- NOTE: this is only set for types (and *not* for subtypes). + Builder_Instance : Chap2.Subprg_Instance_Type; + Builder_Base_Param : O_Dnode; + Builder_Bound_Param : O_Dnode; + Builder_Func : O_Dnode; + end record; + type Complex_Type_Arr_Info is array (Object_Kind_Type) of Complex_Type_Info; + type Complex_Type_Info_Acc is access Complex_Type_Arr_Info; + procedure Free_Complex_Type_Info is new Ada.Unchecked_Deallocation + (Complex_Type_Arr_Info, Complex_Type_Info_Acc); + + type Assoc_Conv_Info is record + -- The subprogram created to do the conversion. + Subprg : O_Dnode; + -- The local base block + Instance_Block : Iir; + -- and its address. + Instance_Field : O_Fnode; + -- The instantiated entity (if any). + Instantiated_Entity : Iir; + -- and its address. + Instantiated_Field : O_Fnode; + In_Field : O_Fnode; + Out_Field : O_Fnode; + Record_Type : O_Tnode; + Record_Ptr_Type : O_Tnode; + end record; + + type Direct_Driver_Type is record + Sig : Iir; + Var : Var_Type; + end record; + type Direct_Driver_Arr is array (Natural range <>) of Direct_Driver_Type; + type Direct_Drivers_Acc is access Direct_Driver_Arr; + + type Ortho_Info_Type; + type Ortho_Info_Acc is access Ortho_Info_Type; + + type Ortho_Info_Type (Kind : Ortho_Info_Kind) is record + case Kind is + when Kind_Type => + -- Mode of the type. + Type_Mode : Type_Mode_Type := Type_Mode_Unknown; + + -- If true, the type is (still) incomplete. + Type_Incomplete : Boolean := False; + + -- For array only. True if the type is constrained with locally + -- static bounds. May have non locally-static bounds in some + -- of its sub-element (ie being a complex type). + Type_Locally_Constrained : Boolean := False; + + -- Additionnal info for complex types. + C : Complex_Type_Info_Acc := null; + + -- Ortho node which represents the type. + -- Type -> Ortho type + -- scalar -> scalar + -- record (complex or not) -> record + -- constrained non-complex array -> constrained array + -- constrained complex array -> the element + -- unconstrained array -> fat pointer + -- access to unconstrained array -> fat pointer + -- access (others) -> access + -- file -> file_index_type + -- protected -> instance + Ortho_Type : O_Tnode_Array; + + -- Ortho pointer to the type. This is always an access to the + -- ortho_type. + Ortho_Ptr_Type : O_Tnode_Array; + + -- Chain of temporary types to be destroyed at end of scope. + Type_Transient_Chain : Iir := Null_Iir; + + -- More info according to the type. + T : Ortho_Info_Type_Type; + + -- Run-time information. + Type_Rti : O_Dnode := O_Dnode_Null; + + when Kind_Incomplete_Type => + -- The declaration of the incomplete type. + Incomplete_Type : Iir; + Incomplete_Array : Ortho_Info_Acc; + + when Kind_Index => + -- Field declaration for array dimension. + Index_Field : O_Fnode; + + when Kind_Expr => + -- Ortho tree which represents the expression, used for + -- enumeration literals. + Expr_Node : O_Cnode; + + when Kind_Subprg => + -- True if the function can return a value stored in the secondary + -- stack. In this case, the caller must deallocate the area + -- allocated by the callee when the value was used. + Use_Stack2 : Boolean := False; + + -- Subprogram declaration node. + Ortho_Func : O_Dnode; + + -- For a function: + -- If the return value is not composite, then this field + -- must be O_DNODE_NULL. + -- If the return value is a composite type, then the caller must + -- give to the callee an area to put the result. This area is + -- given via an (hidden to the user) interface. Furthermore, + -- the function is translated into a procedure. + -- For a procedure: + -- If there are copy-out interfaces, they are gathered in a + -- record and a pointer to the record is passed to the + -- procedure. RES_INTERFACE is the interface for this pointer. + Res_Interface : O_Dnode := O_Dnode_Null; + + -- Field in the frame for a pointer to the RESULT structure. + Res_Record_Var : Var_Type := Null_Var; + + -- For a subprogram with a result interface: + -- Type definition for the record. + Res_Record_Type : O_Tnode := O_Tnode_Null; + -- Type definition for access to the record. + Res_Record_Ptr : O_Tnode := O_Tnode_Null; + + -- Access to the declarations within this subprogram. + Subprg_Frame_Scope : aliased Var_Scope_Type; + + -- Instances for the subprograms. + Subprg_Instance : Chap2.Subprg_Instance_Type := + Chap2.Null_Subprg_Instance; + + Subprg_Resolv : Subprg_Resolv_Info_Acc := null; + + -- Local identifier number, set by spec, continued by body. + Subprg_Local_Id : Local_Identifier_Type; + + -- If set, return should be converted into exit out of the + -- SUBPRG_EXIT loop and the value should be assigned to + -- SUBPRG_RESULT, if any. + Subprg_Exit : O_Snode := O_Snode_Null; + Subprg_Result : O_Dnode := O_Dnode_Null; + + when Kind_Object => + -- For constants: set when the object is defined as a constant. + Object_Static : Boolean; + -- The object itself. + Object_Var : Var_Type; + -- Direct driver for signal (if any). + Object_Driver : Var_Type := Null_Var; + -- RTI constant for the object. + Object_Rti : O_Dnode := O_Dnode_Null; + -- Function to compute the value of object (used for implicit + -- guard signal declaration). + Object_Function : O_Dnode := O_Dnode_Null; + + when Kind_Alias => + Alias_Var : Var_Type; + Alias_Kind : Object_Kind_Type; + + when Kind_Iterator => + Iterator_Var : Var_Type; + + when Kind_Interface => + -- Ortho declaration for the interface. If not null, there is + -- a corresponding ortho parameter for the interface. While + -- translating nested subprograms (that are unnested), + -- Interface_Field may be set to the corresponding field in the + -- FRAME record. So: + -- Node: not null, Field: null: parameter + -- Node: not null, Field: not null: parameter with a copy in + -- the FRAME record. + -- Node: null, Field: null: not possible + -- Node: null, Field: not null: field in RESULT record + Interface_Node : O_Dnode := O_Dnode_Null; + -- Field of the result record for copy-out arguments of procedure. + -- In that case, Interface_Node must be null. + Interface_Field : O_Fnode; + -- Type of the interface. + Interface_Type : O_Tnode; + + when Kind_Disconnect => + -- Variable which contains the time_expression of the + -- disconnection specification + Disconnect_Var : Var_Type; + + when Kind_Process => + Process_Scope : aliased Var_Scope_Type; + + -- Subprogram for the process. + Process_Subprg : O_Dnode; + + -- List of drivers if Flag_Direct_Drivers. + Process_Drivers : Direct_Drivers_Acc := null; + + -- RTI for the process. + Process_Rti_Const : O_Dnode := O_Dnode_Null; + + when Kind_Psl_Directive => + Psl_Scope : aliased Var_Scope_Type; + + -- 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_Type; + + -- Boolean variable (for cover) + Psl_Bool_Var : Var_Type; + + -- 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. + Label_Exit : O_Snode; + -- Used to next from for-loop, with an exit statment. + Label_Next : O_Snode; + + when Kind_Block => + -- Access to declarations of this block. + Block_Scope : aliased Var_Scope_Type; + + -- Instance type (ortho record) for declarations contained in the + -- block/entity/architecture. + Block_Decls_Ptr_Type : O_Tnode; + + -- For Entity: field in the instance type containing link to + -- parent. + -- For an instantiation: link in the parent block to the instance. + Block_Link_Field : O_Fnode; + + -- For an entity: must be o_fnode_null. + -- For an architecture: the entity field. + -- For a block, a component or a generate block: field in the + -- parent instance which contains the declarations for this + -- block. + Block_Parent_Field : O_Fnode; + + -- For a generate block: field in the block providing a chain to + -- the previous block (note: this may not be the parent, but + -- is a parent). + Block_Origin_Field : O_Fnode; + -- For an iterative block: boolean field set when the block + -- is configured. This is used to check if the block was already + -- configured since index and slice are not compelled to be + -- locally static. + Block_Configured_Field : O_Fnode; + + -- For iterative generate block: array of instances. + Block_Decls_Array_Type : O_Tnode; + Block_Decls_Array_Ptr_Type : O_Tnode; + + -- Subprogram which elaborates the block (for entity or arch). + Block_Elab_Subprg : O_Dnode; + -- Size of the block instance. + Block_Instance_Size : O_Dnode; + + -- Only for an entity: procedure that elaborate the packages this + -- units depend on. That must be done before elaborating the + -- entity and before evaluating default expressions in generics. + Block_Elab_Pkg_Subprg : O_Dnode; + + -- RTI constant for the block. + Block_Rti_Const : O_Dnode := O_Dnode_Null; + + when Kind_Component => + -- How to access to component interfaces. + Comp_Scope : aliased Var_Scope_Type; + + -- Instance for the component. + Comp_Ptr_Type : O_Tnode; + -- Field containing a pointer to the instance link. + Comp_Link : O_Fnode; + -- RTI for the component. + Comp_Rti_Const : O_Dnode; + + when Kind_Config => + -- Subprogram that configure the block. + Config_Subprg : O_Dnode; + + when Kind_Field => + -- Node for a record element declaration. + Field_Node : O_Fnode_Array := (O_Fnode_Null, O_Fnode_Null); + + when Kind_Package => + -- Subprogram which elaborate the package spec/body. + -- External units should call the body elaborator. + -- The spec elaborator is called only from the body elaborator. + Package_Elab_Spec_Subprg : O_Dnode; + Package_Elab_Body_Subprg : O_Dnode; + + -- Instance for the elaborators. + Package_Elab_Spec_Instance : Chap2.Subprg_Instance_Type; + Package_Elab_Body_Instance : Chap2.Subprg_Instance_Type; + + -- Variable set to true when the package is elaborated. + Package_Elab_Var : Var_Type; + + -- RTI constant for the package. + Package_Rti_Const : O_Dnode; + + -- Access to declarations of the spec. + Package_Spec_Scope : aliased Var_Scope_Type; + + -- Instance type for uninstantiated package + Package_Spec_Ptr_Type : O_Tnode; + + Package_Body_Scope : aliased Var_Scope_Type; + Package_Body_Ptr_Type : O_Tnode; + + -- Field to the spec within the body. + Package_Spec_Field : O_Fnode; + + -- Local id, set by package declaration, continued by package + -- body. + Package_Local_Id : Local_Identifier_Type; + + when Kind_Package_Instance => + -- The variables containing the instance. There are two variables + -- for interface package: one for the spec, one for the body. + -- For package instantiation, only the variable for the body is + -- used. The variable for spec is added so that packages with + -- package interfaces don't need to know the body of their + -- interfaces. + Package_Instance_Spec_Var : Var_Type; + Package_Instance_Body_Var : Var_Type; + + -- Elaboration procedure for the instance. + Package_Instance_Elab_Subprg : O_Dnode; + + Package_Instance_Spec_Scope : aliased Var_Scope_Type; + Package_Instance_Body_Scope : aliased Var_Scope_Type; + + when Kind_Assoc => + -- 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 => + Library_Rti_Const : O_Dnode; + end case; + end record; + + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => Ortho_Info_Acc, Object => Ortho_Info_Type); + + subtype Type_Info_Acc is Ortho_Info_Acc (Kind_Type); + subtype Incomplete_Type_Info_Acc is Ortho_Info_Acc (Kind_Incomplete_Type); + subtype Index_Info_Acc is Ortho_Info_Acc (Kind_Index); + subtype Subprg_Info_Acc is Ortho_Info_Acc (Kind_Subprg); + 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_Directive); + 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); + subtype Field_Info_Acc is Ortho_Info_Acc (Kind_Field); + subtype Config_Info_Acc is Ortho_Info_Acc (Kind_Config); + subtype Assoc_Info_Acc is Ortho_Info_Acc (Kind_Assoc); + subtype Inter_Info_Acc is Ortho_Info_Acc (Kind_Interface); + subtype Design_File_Info_Acc is Ortho_Info_Acc (Kind_Design_File); + subtype Library_Info_Acc is Ortho_Info_Acc (Kind_Library); + + package Node_Infos is new GNAT.Table + (Table_Component_Type => Ortho_Info_Acc, + Table_Index_Type => Iir, + Table_Low_Bound => 0, + Table_Initial => 1024, + Table_Increment => 100); + + procedure Update_Node_Infos + is + use Nodes; + F, L : Iir; + begin + F := Node_Infos.Last; + L := Nodes.Get_Last_Node; + Node_Infos.Set_Last (L); + Node_Infos.Table (F + 1 .. L) := (others => null); + end Update_Node_Infos; + + procedure Set_Info (Target : Iir; Info : Ortho_Info_Acc) is + begin + if Node_Infos.Table (Target) /= null then + raise Internal_Error; + end if; + Node_Infos.Table (Target) := Info; + end Set_Info; + + procedure Clear_Info (Target : Iir) is + begin + Node_Infos.Table (Target) := null; + end Clear_Info; + + function Get_Info (Target : Iir) return Ortho_Info_Acc is + begin + return Node_Infos.Table (Target); + end Get_Info; + + -- Create an ortho_info field of kind KIND for iir node TARGET, and + -- return it. + function Add_Info (Target : Iir; Kind : Ortho_Info_Kind) + return Ortho_Info_Acc + is + Res : Ortho_Info_Acc; + begin + Res := new Ortho_Info_Type (Kind); + Set_Info (Target, Res); + return Res; + end Add_Info; + + procedure Free_Info (Target : Iir) + is + Info : Ortho_Info_Acc; + begin + Info := Get_Info (Target); + if Info /= null then + Unchecked_Deallocation (Info); + Clear_Info (Target); + end if; + end Free_Info; + + procedure Free_Type_Info (Info : in out Type_Info_Acc) is + begin + if Info.C /= null then + Free_Complex_Type_Info (Info.C); + end if; + Unchecked_Deallocation (Info); + end Free_Type_Info; + + procedure Set_Ortho_Expr (Target : Iir; Expr : O_Cnode) + is + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Target, Kind_Expr); + Info.Expr_Node := Expr; + end Set_Ortho_Expr; + + function Get_Ortho_Expr (Target : Iir) return O_Cnode is + begin + return Get_Info (Target).Expr_Node; + end Get_Ortho_Expr; + + function Get_Ortho_Type (Target : Iir; Is_Sig : Object_Kind_Type) + return O_Tnode is + begin + return Get_Info (Target).Ortho_Type (Is_Sig); + end Get_Ortho_Type; + + function Get_Ortho_Decl (Subprg : Iir) return O_Dnode + is + begin + return Get_Info (Subprg).Ortho_Func; + end Get_Ortho_Decl; + + function Get_Resolv_Ortho_Decl (Func : Iir) return O_Dnode + is + Info : Subprg_Resolv_Info_Acc; + begin + Info := Get_Info (Func).Subprg_Resolv; + if Info = null then + -- Maybe the resolver is not used. + return O_Dnode_Null; + else + return Info.Resolv_Func; + end if; + end Get_Resolv_Ortho_Decl; + + -- Return true is INFO is a type info for a composite type, ie: + -- * a record + -- * an array (fat or thin) + -- * a fat pointer. + function Is_Composite (Info : Type_Info_Acc) return Boolean; + pragma Inline (Is_Composite); + + function Is_Composite (Info : Type_Info_Acc) return Boolean is + begin + return Info.Type_Mode in Type_Mode_Fat; + end Is_Composite; + + function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean; + pragma Inline (Is_Complex_Type); + + function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean is + begin + return Tinfo.C /= null; + end Is_Complex_Type; + + -- In order to simplify the handling of Enode/Lnode, let's introduce + -- Mnode (yes, another node). + -- An Mnode is a typed union, containing either an Lnode or a Enode. + -- See Mstate for a description of the union. + -- The real data is contained insisde a record, so that the discriminant + -- can be changed. + type Mnode; + + -- State of an Mmode. + type Mstate is + ( + -- The Mnode contains an Enode, which can be either a value or a + -- pointer. + -- This Mnode can be used only once. + Mstate_E, + + -- The Mnode contains an Lnode representing a value. + -- This Lnode can be used only once. + Mstate_Lv, + + -- The Mnode contains an Lnode representing a pointer. + -- This Lnode can be used only once. + Mstate_Lp, + + -- The Mnode contains an Dnode for a variable representing a value. + -- This Dnode may be used several times. + Mstate_Dv, + + -- The Mnode contains an Dnode for a variable representing a pointer. + -- This Dnode may be used several times. + Mstate_Dp, + + -- Null Mnode. + Mstate_Null, + + -- The Mnode is invalid (such as already used). + Mstate_Bad); + + type Mnode1 (State : Mstate := Mstate_Bad) is record + -- True if the object is composite (its value cannot be read directly). + Comp : Boolean; + + -- Additionnal informations about the objects: kind and type. + K : Object_Kind_Type; + T : Type_Info_Acc; + + -- Ortho type of the object. + Vtype : O_Tnode; + + -- Type for a pointer to the object. + Ptype : O_Tnode; + + case State is + when Mstate_E => + E : O_Enode; + when Mstate_Lv => + Lv : O_Lnode; + when Mstate_Lp => + Lp : O_Lnode; + when Mstate_Dv => + Dv : O_Dnode; + when Mstate_Dp => + Dp : O_Dnode; + when Mstate_Bad + | Mstate_Null => + null; + end case; + end record; + --pragma Pack (Mnode1); + + type Mnode is record + M1 : Mnode1; + end record; + + -- Null Mnode. + Mnode_Null : constant Mnode := Mnode'(M1 => (State => Mstate_Null, + Comp => False, + K => Mode_Value, + Ptype => O_Tnode_Null, + Vtype => O_Tnode_Null, + T => null)); + + + -- Object kind of a Mnode + function Get_Object_Kind (M : Mnode) return Object_Kind_Type; + + -- Transform VAR to Mnode. + function Get_Var + (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode; + + -- Return a stabilized node for M. + -- The former M is not usuable anymore. + function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode; + + -- Stabilize M. + procedure Stabilize (M : in out Mnode); + + -- If M is not stable, create a variable containing the value of M. + -- M must be scalar (or access). + function Stabilize_Value (M : Mnode) return Mnode; + + -- Create a temporary of type INFO and kind KIND. + function Create_Temp (Info : Type_Info_Acc; + Kind : Object_Kind_Type := Mode_Value) + return Mnode; + + package Chap3 is + -- Translate the subtype of an object, since an object can define + -- a subtype. + -- This can be done only for a declaration. + -- DECL must have an identifier and a type. + procedure Translate_Object_Subtype + (Decl : Iir; With_Vars : Boolean := True); + procedure Elab_Object_Subtype (Def : Iir); + + -- Translate the subtype of a literal. + -- This can be done not at declaration time, ie no variables are created + -- for this subtype. + --procedure Translate_Literal_Subtype (Def : Iir); + + -- Translation of a type definition or subtype indication. + -- 1. Create corresponding Ortho type. + -- 2. Create bounds type + -- 3. Create bounds declaration + -- 4. Create bounds constructor + -- 5. Create type descriptor declaration + -- 6. Create type descriptor constructor + procedure Translate_Type_Definition + (Def : Iir; With_Vars : Boolean := True); + + procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id); + procedure Translate_Anonymous_Type_Definition + (Def : Iir; Transient : Boolean); + + -- Some expressions may be evaluated several times in different + -- contexts. Type info created for these expressions may not be + -- shared between these contexts. + procedure Destroy_Type_Info (Atype : Iir); + + -- Translate subprograms for types. + procedure Translate_Type_Subprograms (Decl : Iir); + + procedure Create_Type_Definition_Type_Range (Def : Iir); + function Create_Static_Array_Subtype_Bounds + (Def : Iir_Array_Subtype_Definition) + return O_Cnode; + + -- Same as Translate_type_definition only for std.standard.boolean and + -- std.standard.bit. + procedure Translate_Bool_Type_Definition (Def : Iir); + + -- Call lock or unlock on a protected object. + procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode); + + procedure Translate_Protected_Type_Body (Bod : Iir); + procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir); + + -- Translate_type_definition_Elab do 4 and 6. + -- It generates code to do type elaboration. + procedure Elab_Type_Declaration (Decl : Iir); + procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration); + + -- Builders. + -- A complex type is a type whose size is not locally static. + -- + -- The most simple example is an unidimensionnl array whose range + -- depends on generics. + -- + -- We call first order complex type any array whose bounds are not + -- locally static and whose sub-element size is locally static. + -- + -- First order complex type objects are represented by a pointer to an + -- array of sub-element, and the storage area for the array is + -- allocated at run-time. + -- + -- Since a sub-element type may be a complex type, a type may be + -- complex because one of its sub-element type is complex. + -- EG, a record type whose one element is a complex array. + -- + -- A type may be complex either because it is a first order complex + -- type (ie an array whose bounds are not locally static) or because + -- one of its sub-element type is such a type (this is recursive). + -- + -- We call second order complex type a complex type that is not of first + -- order. + -- We call third order complex type a second order complex type which is + -- an array whose bounds are not locally static. + -- + -- In a complex type, sub-element of first order complex type are + -- represented by a pointer. + -- Any complex type object (constant, signal, variable, port, generic) + -- is represented by a pointer. + -- + -- Creation of a second or third order complex type object consists in + -- allocating the memory and building the object. + -- Building a object consists in setting internal pointers. + -- + -- A complex type has always a non-null INFO.C, and its size is computed + -- during elaboration. + -- + -- For a second or third order complex type, INFO.C.BUILDER_NEED_FUNC + -- is set to TRUE. + + -- Call builder for variable pointed VAR of type VAR_TYPE. + procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir); + + -- Functions for fat array. + -- Fat array are array whose size is not known at compilation time. + -- This corresponds to an unconstrained array or a non locally static + -- constrained array. + -- A fat array is a structure containing 2 fields: + -- * base: a pointer to the data of the array. + -- * bounds: a pointer to a structure containing as many fields as + -- number of dimensions; these fields are a structure describing the + -- range of the dimension. + + -- Index array BASE of type ATYPE with INDEX. + -- INDEX must be of type ghdl_index_type, thus no bounds checks are + -- performed. + function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode; + + -- Same for for slicing. + function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode; + + -- Get the length of the array (the number of elements). + function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode; + + -- Get the number of elements for bounds BOUNDS. BOUNDS are + -- automatically stabilized if necessary. + function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode; + + -- Get the number of elements in array ATYPE. + function Get_Array_Type_Length (Atype : Iir) return O_Enode; + + -- Get the base of array ARR. + function Get_Array_Base (Arr : Mnode) return Mnode; + + -- Get the bounds of array ARR. + function Get_Array_Bounds (Arr : Mnode) return Mnode; + + -- Get the range ot ATYPE. + function Type_To_Range (Atype : Iir) return Mnode; + + -- Get length of range R. + function Range_To_Length (R : Mnode) return Mnode; + + -- Get direction of range R. + function Range_To_Dir (R : Mnode) return Mnode; + + -- Get left/right bounds for range R. + function Range_To_Left (R : Mnode) return Mnode; + function Range_To_Right (R : Mnode) return Mnode; + + -- Get range for dimension DIM (1 based) of array bounds B or type + -- ATYPE. + function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive) + return Mnode; + + -- Get the range of dimension DIM (1 based) of array ARR of type ATYPE. + function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive) + return Mnode; + + -- Get array bounds for type ATYPE. + function Get_Array_Type_Bounds (Atype : Iir) return Mnode; + + -- Deallocate OBJ. + procedure Gen_Deallocate (Obj : O_Enode); + + -- Performs deallocation of PARAM (the parameter of a deallocate call). + procedure Translate_Object_Deallocation (Param : Iir); + + -- Allocate an object of type OBJ_TYPE and set RES. + -- RES must be a stable access of type ortho_ptr_type. + -- For an unconstrained array, BOUNDS is a pointer to the boundaries of + -- the object, which are copied. + procedure Translate_Object_Allocation + (Res : in out Mnode; + Alloc_Kind : Allocation_Kind; + Obj_Type : Iir; + Bounds : Mnode); + + -- Copy SRC to DEST. + -- Both have the same type, OTYPE. + -- Furthermore, arrays are of the same length. + procedure Translate_Object_Copy + (Dest : Mnode; Src : O_Enode; Obj_Type : Iir); + + -- Get size (in bytes with type ghdl_index_type) of object OBJ. + -- For an unconstrained array, OBJ must be really an object, otherwise, + -- it may be a null_mnode, created by T2M. + function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) return O_Enode; + + -- Allocate the base of a fat array, whose length is determined from + -- the bounds. + -- RES_PTR is a pointer to the fat pointer (must be a variable that + -- can be referenced several times). + -- ARR_TYPE is the type of the array. + procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind; + Res : Mnode; + Arr_Type : Iir); + + -- Create the bounds for SUB_TYPE. + -- SUB_TYPE is expected to be a non-static, anonymous array type. + procedure Create_Array_Subtype (Sub_Type : Iir; Transient : Boolean); + + -- Return TRUE if VALUE is not is the range specified by ATYPE. + -- VALUE must be stable. + function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode; + + -- Return TRUE if base type of ATYPE is larger than its bounds, ie + -- if a value of type ATYPE may be out of range. + function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean; + + -- Generate an error if VALUE (computed from EXPR which may be NULL_IIR + -- if not from a tree) is not in range specified by ATYPE. + procedure Check_Range + (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir); + + -- Insert a scalar check for VALUE of type ATYPE. EXPR may be NULL_IIR. + function Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir) + return O_Enode; + + -- The base type of EXPR and the base type of ATYPE must be the same. + -- If the type is a scalar type, and if a range check is needed, this + -- function inserts the check. Otherwise, it returns VALUE. + function Maybe_Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir) + return O_Enode; + + -- Return True iff all indexes of L_TYPE and R_TYPE have the same + -- length. They must be locally static. + function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean; + + -- Check bounds length of L match bounds length of R. + -- If L_TYPE (resp. R_TYPE) is not a thin array, then L_NODE + -- (resp. R_NODE) are not used (and may be Mnode_Null). + -- If L_TYPE (resp. T_TYPE) is a fat array, then L_NODE (resp. R_NODE) + -- must designate the array. + procedure Check_Array_Match (L_Type : Iir; + L_Node : Mnode; + R_Type : Iir; + R_Node : Mnode; + Loc : Iir); + + -- Create a subtype range to be stored into the location pointed by + -- RANGE_PTR from length LENGTH, which is of type INDEX_TYPE. + -- This is done according to rules 7.2.4 of LRM93, ie: + -- direction and left bound of the range is the same of INDEX_TYPE. + -- LENGTH and RANGE_PTR are variables. LOC is the location in case of + -- error. + procedure Create_Range_From_Length + (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir); + + end Chap3; + + package Chap4 is + -- Translate of a type declaration corresponds to the translation of + -- its definition. + procedure Translate_Type_Declaration (Decl : Iir); + procedure Translate_Anonymous_Type_Declaration (Decl : Iir); + procedure Translate_Subtype_Declaration (Decl : Iir_Subtype_Declaration); + procedure Translate_Bool_Type_Declaration (Decl : Iir_Type_Declaration); + + -- Translate declaration DECL, which must not be a subprogram + -- specification. + procedure Translate_Declaration (Decl : Iir); + + -- Translate declarations, except subprograms spec and bodies. + procedure Translate_Declaration_Chain (Parent : Iir); + + -- Translate subprograms in declaration chain of PARENT. + procedure Translate_Declaration_Chain_Subprograms (Parent : Iir); + + -- Create subprograms for type/function conversion of signal + -- associations. + -- ENTITY is the entity instantiated, which can be either + -- an entity_declaration (for component configuration or direct + -- component instantiation), a component declaration (for a component + -- instantiation) or Null_Iir (for a block header). + -- BLOCK is the block/architecture containing the instantiation stmt. + -- STMT is either the instantiation stmt or the block header. + procedure Translate_Association_Subprograms + (Stmt : Iir; Block : Iir; Base_Block : Iir; Entity : Iir); + + -- Elaborate In/Out_Conversion for ASSOC (signals only). + -- NDEST is the data structure to be registered. + procedure Elab_In_Conversion (Assoc : Iir; Ndest : out Mnode); + procedure Elab_Out_Conversion (Assoc : Iir; Ndest : out Mnode); + + -- Create code to elaborate declarations. + -- NEED_FINAL is set when at least one declaration needs to be + -- finalized (eg: file declaration, protected objects). + procedure Elab_Declaration_Chain + (Parent : Iir; Need_Final : out Boolean); + + -- Finalize declarations. + procedure Final_Declaration_Chain (Parent : Iir; Deallocate : Boolean); + + -- Translate port or generic declarations of PARENT. + procedure Translate_Port_Chain (Parent : Iir); + procedure Translate_Generic_Chain (Parent : Iir); + + -- Elaborate signal subtypes and allocate the storage for the object. + procedure Elab_Signal_Declaration_Storage (Decl : Iir); + + -- Create signal object. + -- Note: SIG can be a signal sub-element (used when signals are + -- collapsed). + -- If CHECK_NULL is TRUE, create the signal only if it was not yet + -- created. + -- PARENT is used to link the signal to its parent by rti. + procedure Elab_Signal_Declaration_Object + (Sig : Iir; Parent : Iir; Check_Null : Boolean); + + -- True of SIG has a direct driver. + function Has_Direct_Driver (Sig : Iir) return Boolean; + + -- Allocate memory for direct driver if necessary. + procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir); + + -- Generate code to create object OBJ and initialize it with value VAL. + procedure Elab_Object_Value (Obj : Iir; Value : Iir); + + -- Allocate the storage for OBJ, if necessary. + procedure Elab_Object_Storage (Obj : Iir); + + -- Initialize NAME/OBJ with VALUE. + procedure Elab_Object_Init (Name : Mnode; Obj : Iir; Value : Iir); + + -- Get the ortho type for an object of type TINFO. + function Get_Object_Type (Tinfo : Type_Info_Acc; Kind : Object_Kind_Type) + return O_Tnode; + + -- Allocate (and build) a complex object of type OBJ_TYPE. + -- VAR is the object to be allocated. + procedure Allocate_Complex_Object (Obj_Type : Iir; + Alloc_Kind : Allocation_Kind; + Var : in out Mnode); + + --function Translate_Interface_Declaration + -- (Decl : Iir; Subprg : Iir) return Tree; + + -- Create a record that describe thes location of an IIR node and + -- returns the address of it. + function Get_Location (N : Iir) return O_Dnode; + + -- Set default value to OBJ. + procedure Init_Object (Obj : Mnode; Obj_Type : Iir); + end Chap4; + + package Chap6 is + -- Translate NAME. + -- RES contains a lnode for the result. This is the object. + -- RES can be a tree, so it may be referenced only once. + -- SIG is true if RES is a signal object. + function Translate_Name (Name : Iir) return Mnode; + + -- Translate signal NAME into its node (SIG) and its direct driver + -- node (DRV). + procedure Translate_Direct_Driver + (Name : Iir; Sig : out Mnode; Drv : out Mnode); + + -- Same as Translate_Name, but only for formal names. + -- If SCOPE_TYPE and SCOPE_PARAM are not null, use them for the scope + -- of the base name. + -- Indeed, for recursive instantiation, NAME can designates the actual + -- and the formal. +-- function Translate_Formal_Name (Scope_Type : O_Tnode; +-- Scope_Param : O_Lnode; +-- Name : Iir) +-- return Mnode; + + -- Get record element EL of PREFIX. + function Translate_Selected_Element (Prefix : Mnode; + El : Iir_Element_Declaration) + return Mnode; + + function Get_Array_Bound_Length (Arr : Mnode; + Arr_Type : Iir; + Dim : Natural) + return O_Enode; + + procedure Gen_Bound_Error (Loc : Iir); + + -- Generate code to emit a program error. + 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 + -- index violation for dimension DIM of an array. LOC is usually + -- the expression which has computed the index and is used only for + -- its location. + procedure Check_Bound_Error (Cond : O_Enode; Loc : Iir; Dim : Natural); + + -- Get the deepest range_expression of ATYPE. + -- This follows 'range and 'reverse_range. + -- Set IS_REVERSE to true if the range must be reversed. + procedure Get_Deep_Range_Expression + (Atype : Iir; Rng : out Iir; Is_Reverse : out Boolean); + + -- Get the offset of INDEX in the range RNG. + -- This checks INDEX belongs to the range. + -- RANGE_TYPE is the subtype of the array index (or the subtype of RNG). + -- For unconstrained ranges, INDEX_EXPR must be NULL_IIR and RANGE_TYPE + -- must be set. + function Translate_Index_To_Offset (Rng : Mnode; + Index : O_Enode; + Index_Expr : Iir; + Range_Type : Iir; + Loc : Iir) + return O_Enode; + end Chap6; + + package Chap7 is + -- Generic function to extract a value from a signal. + generic + with function Read_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + function Translate_Signal_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + + -- Extract the effective value of SIG. + function Translate_Signal_Effective_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + function Translate_Signal_Driving_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode; + + -- Directly set the effective value of SIG with VAL. + -- Used only by conversion. + procedure Set_Effective_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode); + + procedure Set_Driving_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode); + + -- Translate expression EXPR into ortho tree. + function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir) + return O_Enode; + + -- Translate call to function IMP. + -- ASSOC_CHAIN is the chain of a associations for this call. + -- OBJ, if not NULL_IIR is the protected object. + function Translate_Function_Call + (Imp : Iir; Assoc_Chain : Iir; Obj : Iir) + return O_Enode; + + -- Translate range and return an lvalue containing the range. + -- The node returned can be used only one time. + function Translate_Range (Arange : Iir; Range_Type : Iir) + return O_Lnode; + + -- Translate range expression EXPR and store the result into the node + -- pointed by RES_PTR, of type RANGE_TYPE. + procedure Translate_Range_Ptr + (Res_Ptr : O_Dnode; Arange : Iir; Range_Type : Iir); + function Translate_Static_Range (Arange : Iir; Range_Type : Iir) + return O_Cnode; + + -- Same as Translate_Range_Ptr, but for a discrete range (ie: ARANGE + -- can be a discrete subtype indication). + procedure Translate_Discrete_Range_Ptr (Res_Ptr : O_Dnode; Arange : Iir); + + -- Return TRUE iff constant declaration DECL can be staticly defined. + -- This is of course true if its expression is a locally static literal, + -- but can be true in a few cases for aggregates. + -- This function belongs to Translation, since it is defined along + -- with the translate_static_aggregate procedure. + function Is_Static_Constant (Decl : Iir_Constant_Declaration) + return Boolean; + + -- Translate the static expression EXPR into an ortho expression whose + -- type must be RES_TYPE. Therefore, an implicite conversion might + -- occurs. + function Translate_Static_Expression (Expr : Iir; Res_Type : Iir) + return O_Cnode; + function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode) + return O_Cnode; + + -- Convert (if necessary) EXPR of type EXPR_TYPE to type ATYPE. + function Translate_Implicit_Conv + (Expr : O_Enode; + Expr_Type : Iir; + Atype : Iir; + Is_Sig : Object_Kind_Type; + Loc : Iir) + return O_Enode; + + function Translate_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode; + + -- Convert range EXPR into ortho tree. + -- If RANGE_TYPE /= NULL_IIR, convert bounds to RANGE_TYPE. + --function Translate_Range (Expr : Iir; Range_Type : Iir) return O_Enode; + function Translate_Static_Range_Left + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode; + function Translate_Static_Range_Right + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode; + function Translate_Static_Range_Dir (Expr : Iir) return O_Cnode; + function Translate_Static_Range_Length (Expr : Iir) return O_Cnode; + + -- These functions evaluates left bound/right bound/length of the + -- range expression EXPR. + function Translate_Range_Expression_Left (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode; + function Translate_Range_Expression_Right (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode; + function Translate_Range_Expression_Length (Expr : Iir) return O_Enode; + + -- Get the length of any range expression (ie maybe an attribute). + function Translate_Range_Length (Expr : Iir) return O_Enode; + + -- Assign AGGR to TARGET of type TARGET_TYPE. + procedure Translate_Aggregate + (Target : Mnode; Target_Type : Iir; Aggr : Iir); + + -- Translate implicit functions defined by a type. + type Implicit_Subprogram_Infos is private; + procedure Init_Implicit_Subprogram_Infos + (Infos : out Implicit_Subprogram_Infos); + procedure Translate_Implicit_Subprogram + (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos); + + -- Assign EXPR to TARGET. LOC is the location used to report errors. + -- FIXME: do the checks. + procedure Translate_Assign + (Target : Mnode; Expr : Iir; Target_Type : Iir); + procedure Translate_Assign + (Target : Mnode; + Val: O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir); + + -- Find the declaration of the predefined function IMP in type + -- definition BASE_TYPE. + function Find_Predefined_Function + (Base_Type : Iir; Imp : Iir_Predefined_Functions) + return Iir; + + function Translate_Lib_Operator (Left, Right : O_Enode; Func : O_Dnode) + return O_Enode; + private + type Implicit_Subprogram_Infos is record + Arr_Eq_Info : Subprg_Info_Acc; + Rec_Eq_Info : Subprg_Info_Acc; + Arr_Cmp_Info : Subprg_Info_Acc; + Arr_Concat_Info : Subprg_Info_Acc; + Arr_Shl_Info : Subprg_Info_Acc; + Arr_Sha_Info : Subprg_Info_Acc; + Arr_Rot_Info : Subprg_Info_Acc; + end record; + end Chap7; + + package Chap14 is + function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode; + + -- Read signal value FIELD of signal SIG. + function Get_Signal_Value_Field + (Sig : O_Enode; Sig_Type : Iir; Field : O_Fnode) + return O_Lnode; + + function Get_Signal_Field (Sig : Mnode; Field : O_Fnode) return O_Lnode; + + function Translate_Length_Array_Attribute (Expr : Iir; Rtype : Iir) + return O_Enode; + function Translate_Low_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_High_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_Range_Array_Attribute (Expr : Iir) return O_Lnode; + function Translate_Right_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_Left_Array_Attribute (Expr : Iir) return O_Enode; + function Translate_Ascending_Array_Attribute (Expr : Iir) return O_Enode; + + function Translate_High_Low_Type_Attribute + (Atype : Iir; Is_High : Boolean) return O_Enode; + + -- Return the value of the left bound/right bound/direction of scalar + -- type ATYPE. + function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode; + function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode; + function Translate_Dir_Type_Attribute (Atype : Iir) return O_Enode; + + function Translate_Val_Attribute (Attr : Iir) return O_Enode; + function Translate_Pos_Attribute (Attr : Iir; Res_Type : Iir) + return O_Enode; + + function Translate_Succ_Pred_Attribute (Attr : Iir) return O_Enode; + + function Translate_Image_Attribute (Attr : Iir) return O_Enode; + function Translate_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Event_Attribute (Attr : Iir) return O_Enode; + function Translate_Active_Attribute (Attr : Iir) return O_Enode; + function Translate_Last_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Last_Time_Attribute (Prefix : Iir; Field : O_Fnode) + return O_Enode; + + function Translate_Driving_Value_Attribute (Attr : Iir) return O_Enode; + + function Translate_Driving_Attribute (Attr : Iir) return O_Enode; + + function Translate_Path_Instance_Name_Attribute (Attr : Iir) + return O_Enode; + end Chap14; + + package Helpers is + -- Return the value of field FIELD of lnode L that is contains + -- a pointer to a record. + -- This is equivalent to: + -- new_value (new_selected_element (new_access_element (new_value (l)), + -- field)) + function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Enode; + function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Lnode; + + function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode; + + -- Equivalent to new_access_element (new_value (l)) + function New_Acc_Value (L : O_Lnode) return O_Lnode; + + -- Copy a fat pointer. + -- D and S are stabilized fat pointers. + procedure Copy_Fat_Pointer (D : Mnode; S: Mnode); + + -- Generate code to initialize a ghdl_index_type variable V to 0. + procedure Init_Var (V : O_Dnode); + + -- Generate code to increment/decrement a ghdl_index_type variable V. + procedure Inc_Var (V : O_Dnode); + procedure Dec_Var (V : O_Dnode); + + -- Generate code to exit from loop LABEL iff COND is true. + 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. + procedure Open_Temp; + -- Create a temporary variable. + function Create_Temp (Atype : O_Tnode) return O_Dnode; + -- Create a temporary variable of ATYPE and initialize it with VALUE. + function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode) + return O_Dnode; + -- Create a temporary variable of ATYPE and initialize it with the + -- address of NAME. + function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode) + return O_Dnode; + -- Create a mark in the temporary region for the stack2. + -- FIXME: maybe a flag must be added to CLOSE_TEMP where it is known + -- stack2 can be released. + procedure Create_Temp_Stack2_Mark; + -- Add ATYPE in the chain of types to be destroyed at the end of the + -- temp scope. + procedure Add_Transient_Type_In_Temp (Atype : Iir); + -- Close the temporary region. + procedure Close_Temp; + + -- Like Open_Temp, but will never create a declare region. To be used + -- only within a subprogram, to use the declare region of the + -- subprogram. + procedure Open_Local_Temp; + -- Destroy transient types created in a temporary region. + procedure Destroy_Local_Transient_Types; + procedure Close_Local_Temp; + + -- Return TRUE if stack2 will be released. Used for fine-tuning only + -- (return statement). + function Has_Stack2_Mark return Boolean; + -- Manually release stack2. Used for fine-tuning only. + procedure Stack2_Release; + + -- Free all old temp. + -- 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; + + function Create_String (Str : String; Id : O_Ident; Storage : O_Storage) + return O_Dnode; + + function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage) + return O_Dnode; + + function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode; + + procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode); + + -- Allocate SIZE bytes aligned on the biggest alignment and return a + -- pointer of type PTYPE. + function Gen_Alloc + (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode) + return O_Enode; + + -- Allocate on the heap LENGTH bytes aligned on the biggest alignment, + -- and returns a pointer of type PTYPE. + --function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode; + + -- Handle a composite type TARG/TARG_TYPE and apply DO_NON_COMPOSITE + -- on each non composite type. + -- There is a generic parameter DATA which may be updated + -- before indexing an array by UPDATE_DATA_ARRAY. + generic + type Data_Type is private; + type Composite_Data_Type is private; + with procedure Do_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type); + + -- This function should extract the base of DATA. + with function Prepare_Data_Array (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) + return Composite_Data_Type; + + -- This function should index DATA. + with function Update_Data_Array (Data : Composite_Data_Type; + Targ_Type : Iir; + Index : O_Dnode) + return Data_Type; + + -- This function is called at the end of a record process. + with procedure Finish_Data_Array (Data : in out Composite_Data_Type); + + -- This function should stabilize DATA. + with function Prepare_Data_Record (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) + return Composite_Data_Type; + + -- This function should extract field EL of DATA. + with function Update_Data_Record (Data : Composite_Data_Type; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Data_Type; + + -- This function is called at the end of a record process. + with procedure Finish_Data_Record (Data : in out Composite_Data_Type); + + procedure Foreach_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type); + + -- Call a procedure (DATA_TYPE) for each signal of TARG. + procedure Register_Signal + (Targ : Mnode; Targ_Type : Iir; Proc : O_Dnode); + + -- Call PROC for each scalar signal of list LIST. + procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode); + + -- Often used subprograms for Foreach_non_composite + -- when DATA_TYPE is o_enode. + function Gen_Oenode_Prepare_Data_Composite + (Targ: Mnode; Targ_Type : Iir; Val : O_Enode) + return Mnode; + function Gen_Oenode_Update_Data_Array (Val : Mnode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Enode; + function Gen_Oenode_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Enode; + procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode); + + type Hexstr_Type is array (Integer range 0 .. 15) of Character; + N2hex : constant Hexstr_Type := "0123456789abcdef"; + + function Get_Line_Number (Target: Iir) return Natural; + + procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List; + Line : Natural); + private + end Helpers; + use Helpers; + + function Get_Type_Info (M : Mnode) return Type_Info_Acc is + begin + return M.M1.T; + end Get_Type_Info; + + function Get_Object_Kind (M : Mnode) return Object_Kind_Type is + begin + return M.M1.K; + end Get_Object_Kind; + + function E2M (E : O_Enode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_E, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, E => E, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end E2M; + + function Lv2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lv => L, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Lv2M; + + function Lv2M (L : O_Lnode; + Comp : Boolean; + Vtype : O_Tnode; + Ptype : O_Tnode; + T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => Comp, + K => Kind, T => T, Lv => L, + Vtype => Vtype, Ptype => Ptype)); + end Lv2M; + + function Lp2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lp => L, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Lp2M; + + function Lp2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lp => L, + Vtype => Vtype, Ptype => Ptype)); + end Lp2M; + + function Lv2M (L : O_Lnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lv => L, + Vtype => Vtype, Ptype => Ptype)); + end Lv2M; + + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dv => D, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Dv2M; + + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dv, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dv => D, + Vtype => Vtype, + Ptype => Ptype)); + end Dv2M; + + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dp => D, + Vtype => Vtype, Ptype => Ptype)); + end Dp2M; + + function Dp2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dp, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Dp => D, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Dp2M; + + function M2Lv (M : Mnode) return O_Lnode is + begin + case M.M1.State is + when Mstate_E => + case Get_Type_Info (M).Type_Mode is + when Type_Mode_Thin => + -- Scalar to var is not possible. + -- FIXME: This is not coherent with the fact that this + -- conversion is possible when M is stabilized. + raise Internal_Error; + when Type_Mode_Fat => + return New_Access_Element (M.M1.E); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + when Mstate_Lp => + return New_Acc_Value (M.M1.Lp); + when Mstate_Lv => + return M.M1.Lv; + when Mstate_Dp => + return New_Acc_Value (New_Obj (M.M1.Dp)); + when Mstate_Dv => + return New_Obj (M.M1.Dv); + when Mstate_Null + | Mstate_Bad => + raise Internal_Error; + end case; + end M2Lv; + + function M2Lp (M : Mnode) return O_Lnode is + begin + case M.M1.State is + when Mstate_E => + raise Internal_Error; + when Mstate_Lp => + return M.M1.Lp; + when Mstate_Dp => + return New_Obj (M.M1.Dp); + when Mstate_Lv => + if Get_Type_Info (M).Type_Mode in Type_Mode_Fat then + return New_Obj + (Create_Temp_Init (M.M1.Ptype, + New_Address (M.M1.Lv, M.M1.Ptype))); + else + raise Internal_Error; + end if; + when Mstate_Dv + | Mstate_Null + | Mstate_Bad => + raise Internal_Error; + end case; + end M2Lp; + + function M2Dp (M : Mnode) return O_Dnode is + begin + case M.M1.State is + when Mstate_Dp => + return M.M1.Dp; + when Mstate_Dv => + return Create_Temp_Init + (M.M1.Ptype, New_Address (New_Obj (M.M1.Dv), M.M1.Ptype)); + + when others => + raise Internal_Error; + end case; + end M2Dp; + + function M2Dv (M : Mnode) return O_Dnode is + begin + case M.M1.State is + when Mstate_Dv => + return M.M1.Dv; + when others => + raise Internal_Error; + end case; + end M2Dv; + + function T2M (Atype : Iir; Kind : Object_Kind_Type) return Mnode + is + T : Type_Info_Acc; + begin + T := Get_Info (Atype); + return Mnode'(M1 => (State => Mstate_Null, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end T2M; + + function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode + is + D : O_Dnode; + K : Object_Kind_Type; + begin + K := M.M1.K; + case M.M1.State is + when Mstate_E => + if M.M1.Comp then + D := Create_Temp_Init (M.M1.Ptype, M.M1.E); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + else + D := Create_Temp_Init (M.M1.Vtype, M.M1.E); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end if; + when Mstate_Lp => + D := Create_Temp_Init (M.M1.Ptype, New_Value (M.M1.Lp)); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + when Mstate_Lv => + if M.M1.Ptype = O_Tnode_Null then + if not Can_Copy then + raise Internal_Error; + end if; + D := Create_Temp_Init (M.M1.Vtype, New_Value (M.M1.Lv)); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + + else + D := Create_Temp_Ptr (M.M1.Ptype, M.M1.Lv); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end if; + when Mstate_Dp + | Mstate_Dv => + return M; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end Stabilize; + + procedure Stabilize (M : in out Mnode) is + begin + M := Stabilize (M); + end Stabilize; + + function Stabilize_Value (M : Mnode) return Mnode + is + D : O_Dnode; + E : O_Enode; + begin + -- M must be scalar or access. + if M.M1.Comp then + raise Internal_Error; + end if; + case M.M1.State is + when Mstate_E => + E := M.M1.E; + when Mstate_Lp => + E := New_Value (New_Acc_Value (M.M1.Lp)); + when Mstate_Lv => + E := New_Value (M.M1.Lv); + when Mstate_Dp + | Mstate_Dv => + return M; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + + D := Create_Temp_Init (M.M1.Vtype, E); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + K => M.M1.K, T => M.M1.T, Dv => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + end Stabilize_Value; + + function M2E (M : Mnode) return O_Enode is + begin + case M.M1.State is + when Mstate_E => + return M.M1.E; + when Mstate_Lp => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Acc_Value (M.M1.Lp)); + when Type_Mode_Fat => + return New_Value (M.M1.Lp); + end case; + when Mstate_Dp => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Acc_Value (New_Obj (M.M1.Dp))); + when Type_Mode_Fat => + return New_Value (New_Obj (M.M1.Dp)); + end case; + when Mstate_Lv => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (M.M1.Lv); + when Type_Mode_Fat => + return New_Address (M.M1.Lv, M.M1.Ptype); + end case; + when Mstate_Dv => + case M.M1.T.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_Thin => + return New_Value (New_Obj (M.M1.Dv)); + when Type_Mode_Fat => + return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype); + end case; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end M2E; + + function M2Addr (M : Mnode) return O_Enode is + begin + case M.M1.State is + when Mstate_Lp => + return New_Value (M.M1.Lp); + when Mstate_Dp => + return New_Value (New_Obj (M.M1.Dp)); + when Mstate_Lv => + return New_Address (M.M1.Lv, M.M1.Ptype); + when Mstate_Dv => + return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype); + when Mstate_E => + if M.M1.Comp then + return M.M1.E; + else + raise Internal_Error; + end if; + when Mstate_Bad + | Mstate_Null => + raise Internal_Error; + end case; + end M2Addr; + +-- function Is_Null (M : Mnode) return Boolean is +-- begin +-- return M.M1.State = Mstate_Null; +-- end Is_Null; + + function Is_Stable (M : Mnode) return Boolean is + begin + case M.M1.State is + when Mstate_Dp + | Mstate_Dv => + return True; + when others => + return False; + end case; + end Is_Stable; + +-- function Varv2M +-- (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) +-- return Mnode is +-- begin +-- return Lv2M (Get_Var (Var), Vtype, Mode); +-- end Varv2M; + + function Varv2M (Var : Var_Type; + Var_Type : Type_Info_Acc; + Mode : Object_Kind_Type; + Vtype : O_Tnode; + Ptype : O_Tnode) + return Mnode is + begin + return Lv2M (Get_Var (Var), Var_Type, Mode, Vtype, Ptype); + end Varv2M; + + -- Convert a Lnode for a sub object to an MNODE. + function Lo2M (L : O_Lnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode is + begin + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + return Lv2M (L, Vtype, Mode); + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Is_Complex_Type (Vtype) then + return Lp2M (L, Vtype, Mode); + else + return Lv2M (L, Vtype, Mode); + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Lo2M; + + function Lo2M (D : O_Dnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode is + begin + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + return Dv2M (D, Vtype, Mode); + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Is_Complex_Type (Vtype) then + return Dp2M (D, Vtype, Mode); + else + return Dv2M (D, Vtype, Mode); + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Lo2M; + + function Get_Var + (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + return Mnode + is + L : O_Lnode; + D : O_Dnode; + Stable : Boolean; + begin + -- FIXME: there may be Vv2M and Vp2M. + Stable := Is_Var_Stable (Var); + if Stable then + D := Get_Var_Label (Var); + else + L := Get_Var (Var); + end if; + case Vtype.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + if Stable then + return Dv2M (D, Vtype, Mode); + else + return Lv2M (L, Vtype, Mode); + end if; + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Protected => + if Is_Complex_Type (Vtype) then + if Stable then + return Dp2M (D, Vtype, Mode); + else + return Lp2M (L, Vtype, Mode); + end if; + else + if Stable then + return Dv2M (D, Vtype, Mode); + else + return Lv2M (L, Vtype, Mode); + end if; + end if; + when Type_Mode_Unknown => + raise Internal_Error; + end case; + end Get_Var; + + function Create_Temp (Info : Type_Info_Acc; + Kind : Object_Kind_Type := Mode_Value) + return Mnode is + begin + if Is_Complex_Type (Info) + and then Info.Type_Mode /= Type_Mode_Fat_Array + then + -- For a complex and constrained object, we just allocate + -- a pointer to the object. + return Dp2M (Create_Temp (Info.Ortho_Ptr_Type (Kind)), Info, Kind); + else + return Dv2M (Create_Temp (Info.Ortho_Type (Kind)), Info, Kind); + end if; + end Create_Temp; + + function Translate_Foreign_Id (Decl : Iir) return Foreign_Info_Type + is + use Name_Table; + Attr : Iir_Attribute_Value; + Spec : Iir_Attribute_Specification; + Attr_Decl : Iir; + Expr : Iir; + begin + -- Look for 'FOREIGN. + Attr := Get_Attribute_Value_Chain (Decl); + while Attr /= Null_Iir loop + Spec := Get_Attribute_Specification (Attr); + Attr_Decl := Get_Attribute_Designator (Spec); + exit when Get_Identifier (Attr_Decl) = Std_Names.Name_Foreign; + Attr := Get_Chain (Attr); + end loop; + if Attr = Null_Iir then + -- Not found. + raise Internal_Error; + end if; + Spec := Get_Attribute_Specification (Attr); + Expr := Get_Expression (Spec); + case Get_Kind (Expr) is + when Iir_Kind_String_Literal => + declare + Ptr : String_Fat_Acc; + begin + Ptr := Get_String_Fat_Acc (Expr); + Name_Length := Natural (Get_String_Length (Expr)); + for I in 1 .. Name_Length loop + Name_Buffer (I) := Ptr (Nat32 (I)); + end loop; + end; + when Iir_Kind_Simple_Aggregate => + declare + List : Iir_List; + El : Iir; + begin + List := Get_Simple_Aggregate_List (Expr); + Name_Length := 0; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + if Get_Kind (El) /= Iir_Kind_Enumeration_Literal then + raise Internal_Error; + end if; + Name_Length := Name_Length + 1; + Name_Buffer (Name_Length) := + Character'Val (Get_Enum_Pos (El)); + end loop; + end; + when Iir_Kind_Bit_String_Literal => + Error_Msg_Sem + ("value of FOREIGN attribute cannot be a bit string", Expr); + Name_Length := 0; + when others => + if Get_Expr_Staticness (Expr) /= Locally then + Error_Msg_Sem + ("value of FOREIGN attribute must be locally static", Expr); + Name_Length := 0; + else + raise Internal_Error; + end if; + end case; + + if Name_Length = 0 then + return Foreign_Bad; + end if; + + -- Only 'VHPIDIRECT' is recognized. + if Name_Length >= 10 + and then Name_Buffer (1 .. 10) = "VHPIDIRECT" + then + declare + P : Natural; + Sf, Sl : Natural; + Lf, Ll : Natural; + begin + P := 11; + + -- Skip spaces. + while P <= Name_Length and then Name_Buffer (P) = ' ' loop + P := P + 1; + end loop; + if P > Name_Length then + Error_Msg_Sem + ("missing subprogram/library name after VHPIDIRECT", Spec); + end if; + -- Extract library. + Lf := P; + while P < Name_Length and then Name_Buffer (P) /= ' ' loop + P := P + 1; + end loop; + Ll := P; + -- Extract subprogram. + P := P + 1; + while P <= Name_Length and then Name_Buffer (P) = ' ' loop + P := P + 1; + end loop; + Sf := P; + while P < Name_Length and then Name_Buffer (P) /= ' ' loop + P := P + 1; + end loop; + Sl := P; + if P < Name_Length then + Error_Msg_Sem ("garbage at end of VHPIDIRECT", Spec); + end if; + + -- Accept empty library. + if Sf > Name_Length then + Sf := Lf; + Sl := Ll; + Lf := 0; + Ll := 0; + end if; + + return Foreign_Info_Type' + (Kind => Foreign_Vhpidirect, + Lib_First => Lf, + Lib_Last => Ll, + Subprg_First => Sf, + Subprg_Last => Sl); + end; + elsif Name_Length = 14 + and then Name_Buffer (1 .. 14) = "GHDL intrinsic" + then + return Foreign_Info_Type'(Kind => Foreign_Intrinsic); + else + Error_Msg_Sem + ("value of 'FOREIGN attribute does not begin with VHPIDIRECT", + Spec); + return Foreign_Bad; + end if; + end Translate_Foreign_Id; + + package body Helpers is + function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Enode is + begin + return New_Value + (New_Selected_Element (New_Access_Element (New_Value (L)), Field)); + end New_Value_Selected_Acc_Value; + + function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) + return O_Lnode is + begin + return New_Selected_Element + (New_Access_Element (New_Value (L)), Field); + end New_Selected_Acc_Value; + + function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode + is + begin + return New_Indexed_Element (New_Access_Element (New_Value (L)), I); + end New_Indexed_Acc_Value; + + function New_Acc_Value (L : O_Lnode) return O_Lnode is + begin + return New_Access_Element (New_Value (L)); + end New_Acc_Value; + + procedure Copy_Fat_Pointer (D : Mnode; S: Mnode) + is + begin + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (D)), + M2Addr (Chap3.Get_Array_Base (S))); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (D)), + M2Addr (Chap3.Get_Array_Bounds (S))); + end Copy_Fat_Pointer; + + procedure Inc_Var (V : O_Dnode) is + begin + New_Assign_Stmt (New_Obj (V), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (V), + New_Lit (Ghdl_Index_1))); + end Inc_Var; + + procedure Dec_Var (V : O_Dnode) is + begin + New_Assign_Stmt (New_Obj (V), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (V), + New_Lit (Ghdl_Index_1))); + end Dec_Var; + + procedure Init_Var (V : O_Dnode) is + begin + New_Assign_Stmt (New_Obj (V), New_Lit (Ghdl_Index_0)); + end Init_Var; + + procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode) + is + If_Blk : O_If_Block; + begin + Start_If_Stmt (If_Blk, Cond); + New_Exit_Stmt (Label); + Finish_If_Stmt (If_Blk); + end Gen_Exit_When; + + Uniq_Id : Natural := 0; + + function Create_Uniq_Identifier return Uniq_Identifier_String + is + Str : Uniq_Identifier_String; + Val : Natural; + begin + Str (1 .. 3) := "_UI"; + Val := Uniq_Id; + Uniq_Id := Uniq_Id + 1; + for I in reverse 4 .. 11 loop + Str (I) := N2hex (Val mod 16); + Val := Val / 16; + end loop; + 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. + type Temp_Level_Type; + type Temp_Level_Acc is access Temp_Level_Type; + type Temp_Level_Type is record + Prev : Temp_Level_Acc; + Level : Natural; + Id : Natural; + Emitted : Boolean; + Stack2_Mark : O_Dnode; + Transient_Types : Iir; + end record; + -- Current level. + Temp_Level : Temp_Level_Acc := null; + + -- List of unused temp_level_type structures. To be faster, they are + -- never deallocated. + Old_Level : Temp_Level_Acc := null; + + -- If set, emit comments for open_temp/close_temp. + Flag_Debug_Temp : constant Boolean := False; + + procedure Open_Temp + is + L : Temp_Level_Acc; + begin + if Old_Level /= null then + L := Old_Level; + Old_Level := L.Prev; + else + L := new Temp_Level_Type; + end if; + L.all := (Prev => Temp_Level, + Level => 0, + Id => 0, + Emitted => False, + Stack2_Mark => O_Dnode_Null, + Transient_Types => Null_Iir); + if Temp_Level /= null then + L.Level := Temp_Level.Level + 1; + end if; + Temp_Level := L; + if Flag_Debug_Temp then + New_Debug_Comment_Stmt + ("Open_Temp level " & Natural'Image (L.Level)); + end if; + end Open_Temp; + + procedure Open_Local_Temp is + begin + Open_Temp; + Temp_Level.Emitted := True; + end Open_Local_Temp; + + procedure Add_Transient_Type_In_Temp (Atype : Iir) + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Atype); + Type_Info.Type_Transient_Chain := Temp_Level.Transient_Types; + Temp_Level.Transient_Types := Atype; + end Add_Transient_Type_In_Temp; + + procedure Release_Transient_Types (Chain : in out Iir) is + N_Atype : Iir; + begin + while Chain /= Null_Iir loop + N_Atype := Get_Info (Chain).Type_Transient_Chain; + Chap3.Destroy_Type_Info (Chain); + Chain := N_Atype; + end loop; + end Release_Transient_Types; + + procedure Destroy_Local_Transient_Types is + begin + Release_Transient_Types (Temp_Level.Transient_Types); + end Destroy_Local_Transient_Types; + + function Has_Stack2_Mark return Boolean is + begin + return Temp_Level.Stack2_Mark /= O_Dnode_Null; + end Has_Stack2_Mark; + + procedure Stack2_Release + is + Constr : O_Assoc_List; + begin + if Temp_Level.Stack2_Mark /= O_Dnode_Null then + Start_Association (Constr, Ghdl_Stack2_Release); + New_Association (Constr, + New_Value (New_Obj (Temp_Level.Stack2_Mark))); + New_Procedure_Call (Constr); + Temp_Level.Stack2_Mark := O_Dnode_Null; + end if; + end Stack2_Release; + + procedure Close_Temp + is + L : Temp_Level_Acc; + begin + if Temp_Level = null then + -- OPEN_TEMP was not called. + raise Internal_Error; + end if; + if Flag_Debug_Temp then + New_Debug_Comment_Stmt + ("Close_Temp level " & Natural'Image (Temp_Level.Level)); + end if; + + if Temp_Level.Stack2_Mark /= O_Dnode_Null then + Stack2_Release; + end if; + if Temp_Level.Emitted then + Finish_Declare_Stmt; + end if; + + -- Destroy transcient types. + Release_Transient_Types (Temp_Level.Transient_Types); + + -- Unlink temp_level. + L := Temp_Level; + Temp_Level := L.Prev; + L.Prev := Old_Level; + Old_Level := L; + end Close_Temp; + + procedure Close_Local_Temp is + begin + Temp_Level.Emitted := False; + Close_Temp; + end Close_Local_Temp; + + procedure Free_Old_Temp + is + procedure Free is new Ada.Unchecked_Deallocation + (Temp_Level_Type, Temp_Level_Acc); + T : Temp_Level_Acc; + begin + if Temp_Level /= null then + raise Internal_Error; + end if; + loop + T := Old_Level; + exit when T = null; + Old_Level := Old_Level.Prev; + Free (T); + end loop; + end Free_Old_Temp; + + procedure Create_Temp_Stack2_Mark + is + Constr : O_Assoc_List; + begin + if Temp_Level.Stack2_Mark /= O_Dnode_Null then + -- Only the first mark in a region is registred. + -- The release operation frees the memory allocated after the + -- first mark. + return; + end if; + Temp_Level.Stack2_Mark := Create_Temp (Ghdl_Ptr_Type); + Start_Association (Constr, Ghdl_Stack2_Mark); + New_Assign_Stmt (New_Obj (Temp_Level.Stack2_Mark), + New_Function_Call (Constr)); + end Create_Temp_Stack2_Mark; + + function Create_Temp (Atype : O_Tnode) return O_Dnode + is + Str : String (1 .. 12); + Val : Natural; + Res : O_Dnode; + P : Natural; + begin + if Temp_Level = null then + -- OPEN_TEMP was never called. + raise Internal_Error; + -- This is an hack, just to allow array subtype to array type + -- conversion. + --New_Var_Decl + -- (Res, Create_Uniq_Identifier, O_Storage_Private, Atype); + --return Res; + else + if not Temp_Level.Emitted then + Temp_Level.Emitted := True; + Start_Declare_Stmt; + end if; + end if; + Val := Temp_Level.Id; + Temp_Level.Id := Temp_Level.Id + 1; + P := Str'Last; + loop + Str (P) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + P := P - 1; + exit when Val = 0; + end loop; + Str (P) := '_'; + P := P - 1; + Val := Temp_Level.Level; + loop + Str (P) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + P := P - 1; + exit when Val = 0; + end loop; + Str (P) := 'T'; + --Str (12) := Nul; + New_Var_Decl + (Res, Get_Identifier (Str (P .. Str'Last)), O_Storage_Local, Atype); + return Res; + end Create_Temp; + + function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode) + return O_Dnode + is + Res : O_Dnode; + begin + Res := Create_Temp (Atype); + New_Assign_Stmt (New_Obj (Res), Value); + return Res; + end Create_Temp_Init; + + function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode) + return O_Dnode is + begin + return Create_Temp_Init (Atype, New_Address (Name, Atype)); + 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 + begin + return New_Constrained_Array_Type + (Chararray_Type, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Str'Length + 1))); + end Create_String_Type; + + procedure Create_String_Value + (Const : in out O_Dnode; Const_Type : O_Tnode; Str : String) + is + Res : O_Cnode; + List : O_Array_Aggr_List; + begin + Start_Const_Value (Const); + Start_Array_Aggr (List, Const_Type); + for I in Str'Range loop + New_Array_Aggr_El + (List, + New_Unsigned_Literal (Char_Type_Node, Character'Pos (Str (I)))); + end loop; + New_Array_Aggr_El (List, New_Unsigned_Literal (Char_Type_Node, 0)); + Finish_Array_Aggr (List, Res); + Finish_Const_Value (Const, Res); + end Create_String_Value; + + function Create_String (Str : String; Id : O_Ident) return O_Dnode + is + Atype : O_Tnode; + Const : O_Dnode; + begin + Atype := Create_String_Type (Str); + New_Const_Decl (Const, Id, O_Storage_Private, Atype); + Create_String_Value (Const, Atype, Str); + return Const; + end Create_String; + + function Create_String (Str : String; Id : O_Ident; Storage : O_Storage) + return O_Dnode + is + Atype : O_Tnode; + Const : O_Dnode; + begin + Atype := Create_String_Type (Str); + New_Const_Decl (Const, Id, Storage, Atype); + if Storage /= O_Storage_External then + Create_String_Value (Const, Atype, Str); + end if; + return Const; + end Create_String; + + function Create_String (Str : Name_Id; Id : O_Ident; Storage : O_Storage) + return O_Dnode + is + use Name_Table; + begin + if Name_Table.Is_Character (Str) then + raise Internal_Error; + end if; + Image (Str); + return Create_String (Name_Buffer (1 .. Name_Length), Id, Storage); + end Create_String; + + function Create_String_Len (Str : String; Id : O_Ident) return O_Cnode + is + Str_Cst : O_Dnode; + Str_Len : O_Cnode; + List : O_Record_Aggr_List; + Res : O_Cnode; + begin + Str_Cst := Create_String (Str, Id); + Str_Len := New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Str'Length)); + Start_Record_Aggr (List, Ghdl_Str_Len_Type_Node); + New_Record_Aggr_El (List, Str_Len); + New_Record_Aggr_El (List, New_Global_Address (Str_Cst, + Char_Ptr_Type)); + Finish_Record_Aggr (List, Res); + return Res; + end Create_String_Len; + + procedure Gen_Memcpy (Dest : O_Enode; Src : O_Enode; Length : O_Enode) + is + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Memcpy); + New_Association (Constr, New_Convert_Ov (Dest, Ghdl_Ptr_Type)); + New_Association (Constr, New_Convert_Ov (Src, Ghdl_Ptr_Type)); + New_Association (Constr, Length); + New_Procedure_Call (Constr); + end Gen_Memcpy; + +-- function Gen_Malloc (Length : O_Enode; Ptype : O_Tnode) return O_Enode +-- is +-- Constr : O_Assoc_List; +-- begin +-- Start_Association (Constr, Ghdl_Malloc); +-- New_Association (Constr, Length); +-- return New_Convert_Ov (New_Function_Call (Constr), Ptype); +-- end Gen_Malloc; + + function Gen_Alloc + (Kind : Allocation_Kind; Size : O_Enode; Ptype : O_Tnode) + return O_Enode + is + Constr : O_Assoc_List; + begin + case Kind is + when Alloc_Heap => + Start_Association (Constr, Ghdl_Malloc); + New_Association (Constr, Size); + return New_Convert_Ov (New_Function_Call (Constr), Ptype); + when Alloc_System => + Start_Association (Constr, Ghdl_Malloc0); + New_Association (Constr, Size); + return New_Convert_Ov (New_Function_Call (Constr), Ptype); + when Alloc_Stack => + return New_Alloca (Ptype, Size); + when Alloc_Return => + Start_Association (Constr, Ghdl_Stack2_Allocate); + New_Association (Constr, Size); + return New_Convert_Ov (New_Function_Call (Constr), Ptype); + end case; + end Gen_Alloc; + + procedure Foreach_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Data_Type) + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_Scalar => + Do_Non_Composite (Targ, Targ_Type, Data); + when Type_Mode_Fat_Array + | Type_Mode_Array => + declare + Var_Array : Mnode; + Var_Base : Mnode; + Var_Length : O_Dnode; + Var_I : O_Dnode; + Label : O_Snode; + Sub_Data : Data_Type; + Composite_Data : Composite_Data_Type; + begin + Open_Temp; + Var_Array := Stabilize (Targ); + Var_Length := Create_Temp (Ghdl_Index_Type); + Var_Base := Stabilize (Chap3.Get_Array_Base (Var_Array)); + New_Assign_Stmt + (New_Obj (Var_Length), + Chap3.Get_Array_Length (Var_Array, Targ_Type)); + Composite_Data := + Prepare_Data_Array (Var_Array, Targ_Type, Data); + if True then + Var_I := Create_Temp (Ghdl_Index_Type); + else + New_Var_Decl + (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + end if; + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, New_Compare_Op (ON_Ge, + New_Value (New_Obj (Var_I)), + New_Value (New_Obj (Var_Length)), + Ghdl_Bool_Type)); + Sub_Data := Update_Data_Array + (Composite_Data, Targ_Type, Var_I); + Foreach_Non_Composite + (Chap3.Index_Base (Var_Base, Targ_Type, + New_Value (New_Obj (Var_I))), + Get_Element_Subtype (Targ_Type), + Sub_Data); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Data_Array (Composite_Data); + Close_Temp; + end; + when Type_Mode_Record => + declare + Var_Record : Mnode; + Sub_Data : Data_Type; + Composite_Data : Composite_Data_Type; + List : Iir_List; + El : Iir_Element_Declaration; + begin + Open_Temp; + Var_Record := Stabilize (Targ); + Composite_Data := + Prepare_Data_Record (Var_Record, Targ_Type, Data); + List := Get_Elements_Declaration_List + (Get_Base_Type (Targ_Type)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Sub_Data := Update_Data_Record + (Composite_Data, Targ_Type, El); + Foreach_Non_Composite + (Chap6.Translate_Selected_Element (Var_Record, El), + Get_Type (El), + Sub_Data); + end loop; + Finish_Data_Record (Composite_Data); + Close_Temp; + end; + when others => + Error_Kind ("foreach_non_composite/" + & Type_Mode_Type'Image (Type_Info.Type_Mode), + Targ_Type); + end case; + end Foreach_Non_Composite; + + procedure Register_Non_Composite_Signal (Targ : Mnode; + Targ_Type : Iir; + Proc : O_Dnode) + is + pragma Unreferenced (Targ_Type); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Proc); + New_Association + (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + end Register_Non_Composite_Signal; + + function Register_Update_Data_Array + (Data : O_Dnode; Targ_Type : Iir; Index : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ_Type); + pragma Unreferenced (Index); + begin + return Data; + end Register_Update_Data_Array; + + function Register_Prepare_Data_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ); + pragma Unreferenced (Targ_Type); + begin + return Data; + end Register_Prepare_Data_Composite; + + function Register_Update_Data_Record + (Data : O_Dnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Dnode + is + pragma Unreferenced (Targ_Type); + pragma Unreferenced (El); + begin + return Data; + end Register_Update_Data_Record; + + procedure Register_Finish_Data_Composite (D : in out O_Dnode) + is + pragma Unreferenced (D); + begin + null; + end Register_Finish_Data_Composite; + + procedure Register_Signal_1 is new Foreach_Non_Composite + (Data_Type => O_Dnode, + Composite_Data_Type => O_Dnode, + Do_Non_Composite => Register_Non_Composite_Signal, + Prepare_Data_Array => Register_Prepare_Data_Composite, + Update_Data_Array => Register_Update_Data_Array, + Finish_Data_Array => Register_Finish_Data_Composite, + Prepare_Data_Record => Register_Prepare_Data_Composite, + Update_Data_Record => Register_Update_Data_Record, + Finish_Data_Record => Register_Finish_Data_Composite); + + procedure Register_Signal (Targ : Mnode; + Targ_Type : Iir; + Proc : O_Dnode) + renames Register_Signal_1; + + procedure Register_Signal_List (List : Iir_List; Proc : O_Dnode) + is + El : Iir; + Sig : Mnode; + begin + if List = Null_Iir_List then + return; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Open_Temp; + Sig := Chap6.Translate_Name (El); + Register_Signal (Sig, Get_Type (El), Proc); + Close_Temp; + end loop; + end Register_Signal_List; + + function Gen_Oenode_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : O_Enode) + return Mnode + is + pragma Unreferenced (Targ); + Res : Mnode; + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Targ_Type); + Res := E2M (Val, Type_Info, Mode_Value); + case Type_Info.Type_Mode is + when Type_Mode_Array + | Type_Mode_Fat_Array => + Res := Chap3.Get_Array_Base (Res); + when Type_Mode_Record => + Res := Stabilize (Res); + when others => + -- Not a composite type! + raise Internal_Error; + end case; + return Res; + end Gen_Oenode_Prepare_Data_Composite; + + function Gen_Oenode_Update_Data_Array (Val : Mnode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Enode + is + begin + return M2E (Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index))); + end Gen_Oenode_Update_Data_Array; + + function Gen_Oenode_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Enode + is + pragma Unreferenced (Targ_Type); + begin + return M2E (Chap6.Translate_Selected_Element (Val, El)); + end Gen_Oenode_Update_Data_Record; + + procedure Gen_Oenode_Finish_Data_Composite (Data : in out Mnode) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Oenode_Finish_Data_Composite; + + function Get_Line_Number (Target: Iir) return Natural + is + Line, Col: Natural; + Name : Name_Id; + begin + Files_Map.Location_To_Position + (Get_Location (Target), Name, Line, Col); + return Line; + end Get_Line_Number; + + procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List; + Line : Natural) is + begin + New_Association (Assoc, + New_Lit (New_Global_Address (Current_Filename_Node, + Char_Ptr_Type))); + New_Association (Assoc, New_Lit (New_Signed_Literal + (Ghdl_I32_Type, Integer_64 (Line)))); + end Assoc_Filename_Line; + end Helpers; + + package body Chap1 is + procedure Start_Block_Decl (Blk : Iir) + is + Info : constant Block_Info_Acc := Get_Info (Blk); + begin + Chap2.Declare_Inst_Type_And_Ptr + (Info.Block_Scope'Access, Info.Block_Decls_Ptr_Type); + end Start_Block_Decl; + + procedure Translate_Entity_Init (Entity : Iir) + is + El : Iir; + El_Type : Iir; + begin + Push_Local_Factory; + + -- Generics. + El := Get_Generic_Chain (Entity); + while El /= Null_Iir loop + Open_Temp; + Chap4.Elab_Object_Value (El, Get_Default_Value (El)); + Close_Temp; + El := Get_Chain (El); + end loop; + + -- Ports. + El := Get_Port_Chain (Entity); + while El /= Null_Iir loop + Open_Temp; + El_Type := Get_Type (El); + if not Is_Fully_Constrained_Type (El_Type) then + Chap5.Elab_Unconstrained_Port (El, Get_Default_Value (El)); + end if; + Chap4.Elab_Signal_Declaration_Storage (El); + Chap4.Elab_Signal_Declaration_Object (El, Entity, False); + Close_Temp; + + El := Get_Chain (El); + end loop; + + Pop_Local_Factory; + end Translate_Entity_Init; + + procedure Translate_Entity_Declaration (Entity : Iir_Entity_Declaration) + is + Info : Block_Info_Acc; + Interface_List : O_Inter_List; + Instance : Chap2.Subprg_Instance_Type; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Info := Add_Info (Entity, Kind_Block); + Chap1.Start_Block_Decl (Entity); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- Entity link (RTI and pointer to parent). + Info.Block_Link_Field := Add_Instance_Factory_Field + (Wki_Rti, Rtis.Ghdl_Entity_Link_Type); + + -- generics, ports. + Chap4.Translate_Generic_Chain (Entity); + Chap4.Translate_Port_Chain (Entity); + + Chap9.Translate_Block_Declarations (Entity, Entity); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, + Info.Block_Decls_Ptr_Type, + Wki_Instance, + Prev_Subprg_Instance); + + -- Entity elaborator. + Start_Procedure_Decl (Interface_List, Create_Identifier ("ELAB"), + Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces (Interface_List, Instance); + Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Subprg); + + -- Entity dependences elaborator. + Start_Procedure_Decl (Interface_List, Create_Identifier ("PKG_ELAB"), + Global_Storage); + Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Pkg_Subprg); + + -- Generate RTI. + if Flag_Rti then + Rtis.Generate_Unit (Entity); + end if; + + if Global_Storage = O_Storage_External then + -- Entity declaration subprograms. + Chap4.Translate_Declaration_Chain_Subprograms (Entity); + else + -- Entity declaration and process subprograms. + Chap9.Translate_Block_Subprograms (Entity, Entity); + + -- Package elaborator Body. + Start_Subprogram_Body (Info.Block_Elab_Pkg_Subprg); + Push_Local_Factory; + New_Debug_Line_Stmt (Get_Line_Number (Entity)); + Chap2.Elab_Dependence (Get_Design_Unit (Entity)); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- Elaborator Body. + Start_Subprogram_Body (Info.Block_Elab_Subprg); + Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Instance); + New_Debug_Line_Stmt (Get_Line_Number (Entity)); + + Chap9.Elab_Block_Declarations (Entity, Entity); + Chap2.Finish_Subprg_Instance_Use (Instance); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- Default value if any. + if False then --Is_Entity_Declaration_Top (Entity) then + declare + Init_Subprg : O_Dnode; + begin + Start_Procedure_Decl + (Interface_List, Create_Identifier ("_INIT"), + Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Instance); + Finish_Subprogram_Decl (Interface_List, Init_Subprg); + + Start_Subprogram_Body (Init_Subprg); + Chap2.Start_Subprg_Instance_Use (Instance); + Translate_Entity_Init (Entity); + Chap2.Finish_Subprg_Instance_Use (Instance); + Finish_Subprogram_Body; + end; + end if; + end if; + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end Translate_Entity_Declaration; + + -- Push scope for architecture ARCH via INSTANCE, and for its + -- entity via the entity field of the instance. + procedure Push_Architecture_Scope (Arch : Iir; Instance : O_Dnode) + is + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); + begin + Set_Scope_Via_Param_Ptr (Arch_Info.Block_Scope, Instance); + Set_Scope_Via_Field (Entity_Info.Block_Scope, + Arch_Info.Block_Parent_Field, + Arch_Info.Block_Scope'Access); + end Push_Architecture_Scope; + + -- Pop scopes created by Push_Architecture_Scope. + procedure Pop_Architecture_Scope (Arch : Iir) + is + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); + begin + Clear_Scope (Entity_Info.Block_Scope); + Clear_Scope (Arch_Info.Block_Scope); + end Pop_Architecture_Scope; + + procedure Translate_Architecture_Body (Arch : Iir) + is + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); + Info : Block_Info_Acc; + Interface_List : O_Inter_List; + Constr : O_Assoc_List; + Instance : O_Dnode; + Var_Arch_Instance : O_Dnode; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + if Get_Foreign_Flag (Arch) then + Error_Msg_Sem ("FOREIGN architectures are not yet handled", Arch); + end if; + + Info := Add_Info (Arch, Kind_Block); + Start_Block_Decl (Arch); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- We cannot use Add_Scope_Field here, because the entity is not a + -- child scope of the architecture. + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Get_Identifier ("ENTITY"), + Get_Scope_Type (Entity_Info.Block_Scope)); + + Chap9.Translate_Block_Declarations (Arch, Arch); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + -- Declare the constant containing the size of the instance. + New_Const_Decl + (Info.Block_Instance_Size, Create_Identifier ("INSTSIZE"), + Global_Storage, Ghdl_Index_Type); + if Global_Storage /= O_Storage_External then + Start_Const_Value (Info.Block_Instance_Size); + Finish_Const_Value + (Info.Block_Instance_Size, Get_Scope_Size (Info.Block_Scope)); + end if; + + -- Elaborator. + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB"), Global_Storage); + New_Interface_Decl + (Interface_List, Instance, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, Info.Block_Elab_Subprg); + + -- Generate RTI. + if Flag_Rti then + Rtis.Generate_Unit (Arch); + end if; + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Create process subprograms. + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, + Info.Block_Decls_Ptr_Type, + Wki_Instance, + Prev_Subprg_Instance); + Set_Scope_Via_Field (Entity_Info.Block_Scope, + Info.Block_Parent_Field, + Info.Block_Scope'Access); + + Chap9.Translate_Block_Subprograms (Arch, Arch); + + Clear_Scope (Entity_Info.Block_Scope); + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + + -- Elaborator body. + Start_Subprogram_Body (Info.Block_Elab_Subprg); + Push_Local_Factory; + + -- Create a variable for the architecture instance (with the right + -- type, instead of the entity instance type). + New_Var_Decl (Var_Arch_Instance, Wki_Arch_Instance, + O_Storage_Local, Info.Block_Decls_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Arch_Instance), + New_Convert_Ov (New_Value (New_Obj (Instance)), + Info.Block_Decls_Ptr_Type)); + + -- Set RTI. + if Flag_Rti then + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Acc_Value (New_Obj (Instance), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Rti), + New_Unchecked_Address (New_Obj (Info.Block_Rti_Const), + Rtis.Ghdl_Rti_Access)); + end if; + + -- Call entity elaborators. + Start_Association (Constr, Entity_Info.Block_Elab_Subprg); + New_Association (Constr, New_Value (New_Obj (Instance))); + New_Procedure_Call (Constr); + + Push_Architecture_Scope (Arch, Var_Arch_Instance); + + New_Debug_Line_Stmt (Get_Line_Number (Arch)); + Chap2.Elab_Dependence (Get_Design_Unit (Arch)); + + Chap9.Elab_Block_Declarations (Arch, Arch); + --Chap6.Leave_Simple_Name (Ghdl_Leave_Architecture); + + Pop_Architecture_Scope (Arch); + + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Architecture_Body; + + procedure Translate_Component_Configuration_Decl + (Cfg : Iir; Blk : Iir; Base_Block : Iir; Num : in out Iir_Int32) + is + Inter_List : O_Inter_List; + Comp : Iir_Component_Declaration; + Comp_Info : Comp_Info_Acc; + Info : Config_Info_Acc; + Instance : O_Dnode; + Mark, Mark2 : Id_Mark_Type; + + Base_Info : Block_Info_Acc; + Base_Instance : O_Dnode; + + Block : Iir_Block_Configuration; + Binding : Iir_Binding_Indication; + Entity_Aspect : Iir; + Conf_Override : Iir; + Conf_Info : Config_Info_Acc; + begin + -- Incremental binding. + if Get_Nbr_Elements (Get_Instantiation_List (Cfg)) = 0 then + -- This component configuration applies to no component + -- instantiation, so it is not translated. + return; + end if; + + Binding := Get_Binding_Indication (Cfg); + if Binding = Null_Iir then + -- This is an unbound component configuration, since this is a + -- no-op, it is not translated. + return; + end if; + + Entity_Aspect := Get_Entity_Aspect (Binding); + + Comp := Get_Named_Entity (Get_Component_Name (Cfg)); + Comp_Info := Get_Info (Comp); + + if Get_Kind (Cfg) = Iir_Kind_Component_Configuration then + Block := Get_Block_Configuration (Cfg); + else + Block := Null_Iir; + end if; + + Push_Identifier_Prefix (Mark, Get_Identifier (Comp), Num); + Num := Num + 1; + + if Block /= Null_Iir then + Push_Identifier_Prefix (Mark2, "CONFIG"); + Translate_Configuration_Declaration (Cfg); + Pop_Identifier_Prefix (Mark2); + Conf_Override := Cfg; + Conf_Info := Get_Info (Cfg); + Clear_Info (Cfg); + else + Conf_Info := null; + Conf_Override := Null_Iir; + end if; + Info := Add_Info (Cfg, Kind_Config); + + Base_Info := Get_Info (Base_Block); + + Chap4.Translate_Association_Subprograms + (Binding, Blk, Base_Block, + Get_Entity_From_Entity_Aspect (Entity_Aspect)); + + Start_Procedure_Decl + (Inter_List, Create_Identifier, O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Comp_Info.Comp_Ptr_Type); + New_Interface_Decl (Inter_List, Base_Instance, Get_Identifier ("BLK"), + Base_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Config_Subprg); + + -- Extract the entity/architecture. + + Start_Subprogram_Body (Info.Config_Subprg); + Push_Local_Factory; + + if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then + Push_Architecture_Scope (Base_Block, Base_Instance); + else + Set_Scope_Via_Param_Ptr (Base_Info.Block_Scope, Base_Instance); + end if; + + Set_Scope_Via_Param_Ptr (Comp_Info.Comp_Scope, Instance); + + if Conf_Info /= null then + Clear_Info (Cfg); + Set_Info (Cfg, Conf_Info); + end if; + Chap9.Translate_Entity_Instantiation + (Entity_Aspect, Binding, Comp, Conf_Override); + if Conf_Info /= null then + Clear_Info (Cfg); + Set_Info (Cfg, Info); + end if; + + Clear_Scope (Comp_Info.Comp_Scope); + + if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then + Pop_Architecture_Scope (Base_Block); + else + Clear_Scope (Base_Info.Block_Scope); + end if; + + Pop_Local_Factory; + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Mark); + end Translate_Component_Configuration_Decl; + + -- Create subprogram specifications for each configuration_specification + -- in BLOCK_CONFIG and its sub-blocks. + -- BLOCK is the block being configured (initially the architecture), + -- BASE_BLOCK is the root block giving the instance (initially the + -- architecture) + -- NUM is an integer used to generate uniq names. + procedure Translate_Block_Configuration_Decls + (Block_Config : Iir_Block_Configuration; + Block : Iir; + Base_Block : Iir; + Num : in out Iir_Int32) + is + El : Iir; + begin + El := Get_Configuration_Item_Chain (Block_Config); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Configuration + | Iir_Kind_Configuration_Specification => + Translate_Component_Configuration_Decl + (El, Block, Base_Block, Num); + when Iir_Kind_Block_Configuration => + declare + Mark : Id_Mark_Type; + Base_Info : constant Block_Info_Acc := + Get_Info (Base_Block); + Blk : constant Iir := Get_Block_From_Block_Specification + (Get_Block_Specification (El)); + Blk_Info : constant Block_Info_Acc := Get_Info (Blk); + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Blk)); + case Get_Kind (Blk) is + when Iir_Kind_Generate_Statement => + Set_Scope_Via_Field_Ptr + (Base_Info.Block_Scope, + Blk_Info.Block_Origin_Field, + Blk_Info.Block_Scope'Access); + Translate_Block_Configuration_Decls + (El, Blk, Blk, Num); + Clear_Scope (Base_Info.Block_Scope); + when Iir_Kind_Block_Statement => + Translate_Block_Configuration_Decls + (El, Blk, Base_Block, Num); + when others => + Error_Kind + ("translate_block_configuration_decls(2)", Blk); + end case; + Pop_Identifier_Prefix (Mark); + end; + when others => + Error_Kind ("translate_block_configuration_decls(1)", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Block_Configuration_Decls; + + procedure Translate_Component_Configuration_Call + (Cfg : Iir; Base_Block : Iir; Block_Info : Block_Info_Acc) + is + Cfg_Info : Config_Info_Acc; + Base_Info : Block_Info_Acc; + begin + if Get_Binding_Indication (Cfg) = Null_Iir then + -- Unbound component configuration, nothing to do. + return; + end if; + + Cfg_Info := Get_Info (Cfg); + Base_Info := Get_Info (Base_Block); + + -- Call the subprogram for the instantiation list. + declare + List : Iir_List; + El : Iir; + begin + List := Get_Instantiation_List (Cfg); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El := Get_Named_Entity (El); + case Get_Kind (El) is + when Iir_Kind_Component_Instantiation_Statement => + declare + Assoc : O_Assoc_List; + Info : constant Block_Info_Acc := Get_Info (El); + Comp_Info : constant Comp_Info_Acc := + Get_Info (Get_Named_Entity + (Get_Instantiated_Unit (El))); + V : O_Lnode; + begin + -- The component is really a component and not a + -- direct instance. + Start_Association (Assoc, Cfg_Info.Config_Subprg); + V := Get_Instance_Ref (Block_Info.Block_Scope); + V := New_Selected_Element (V, Info.Block_Link_Field); + New_Association + (Assoc, New_Address (V, Comp_Info.Comp_Ptr_Type)); + V := Get_Instance_Ref (Base_Info.Block_Scope); + New_Association + (Assoc, + New_Address (V, Base_Info.Block_Decls_Ptr_Type)); + New_Procedure_Call (Assoc); + end; + when others => + Error_Kind ("translate_component_configuration", El); + end case; + end loop; + end; + end Translate_Component_Configuration_Call; + + procedure Translate_Block_Configuration_Calls + (Block_Config : Iir_Block_Configuration; + Base_Block : Iir; + Base_Info : Block_Info_Acc); + + procedure Translate_Generate_Block_Configuration_Calls + (Block_Config : Iir_Block_Configuration; + Parent_Info : Block_Info_Acc) + is + Spec : constant Iir := Get_Block_Specification (Block_Config); + Block : constant Iir := Get_Block_From_Block_Specification (Spec); + Info : constant Block_Info_Acc := Get_Info (Block); + Scheme : constant Iir := Get_Generation_Scheme (Block); + + Type_Info : Type_Info_Acc; + Iter_Type : Iir; + + -- Generate a call for a iterative generate block whose index is + -- INDEX. + -- FAILS is true if it is an error if the block is already + -- configured. + procedure Gen_Subblock_Call (Index : O_Enode; Fails : Boolean) + is + Var_Inst : O_Dnode; + If_Blk : O_If_Block; + begin + Open_Temp; + Var_Inst := Create_Temp (Info.Block_Decls_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Inst), + New_Address (New_Indexed_Element + (New_Acc_Value + (New_Selected_Element + (Get_Instance_Ref (Parent_Info.Block_Scope), + Info.Block_Parent_Field)), + Index), + Info.Block_Decls_Ptr_Type)); + -- Configure only if not yet configured. + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Value_Selected_Acc_Value + (New_Obj (Var_Inst), + Info.Block_Configured_Field), + New_Lit (Ghdl_Bool_False_Node), + Ghdl_Bool_Type)); + -- Mark the block as configured. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Inst), + Info.Block_Configured_Field), + New_Lit (Ghdl_Bool_True_Node)); + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var_Inst); + Translate_Block_Configuration_Calls (Block_Config, Block, Info); + Clear_Scope (Info.Block_Scope); + + if Fails then + New_Else_Stmt (If_Blk); + -- Already configured. + Chap6.Gen_Program_Error + (Block_Config, Chap6.Prg_Err_Block_Configured); + end if; + + Finish_If_Stmt (If_Blk); + Close_Temp; + end Gen_Subblock_Call; + + procedure Apply_To_All_Others_Blocks (Is_All : Boolean) + is + Var_I : O_Dnode; + Label : O_Snode; + begin + 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_Eq, + New_Value (New_Obj (Var_I)), + New_Value + (New_Selected_Element + (Get_Var (Get_Info (Iter_Type).T.Range_Var), + Type_Info.T.Range_Length)), + Ghdl_Bool_Type)); + -- Selected_name is for default configurations, so + -- program should not fail if a block is already + -- configured but continue silently. + Gen_Subblock_Call (New_Value (New_Obj (Var_I)), Is_All); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + end Apply_To_All_Others_Blocks; + begin + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Iter_Type := Get_Type (Scheme); + Type_Info := Get_Info (Get_Base_Type (Iter_Type)); + case Get_Kind (Spec) is + when Iir_Kind_Generate_Statement + | Iir_Kind_Simple_Name => + Apply_To_All_Others_Blocks (True); + when Iir_Kind_Indexed_Name => + declare + Index_List : constant Iir_List := Get_Index_List (Spec); + Rng : Mnode; + begin + if Index_List = Iir_List_Others then + Apply_To_All_Others_Blocks (False); + else + Open_Temp; + Rng := Stabilize (Chap3.Type_To_Range (Iter_Type)); + Gen_Subblock_Call + (Chap6.Translate_Index_To_Offset + (Rng, + Chap7.Translate_Expression + (Get_Nth_Element (Index_List, 0), Iter_Type), + Scheme, Iter_Type, Spec), + True); + Close_Temp; + end if; + end; + when Iir_Kind_Slice_Name => + declare + Rng : Mnode; + Slice : O_Dnode; + Slice_Ptr : O_Dnode; + Left, Right : O_Dnode; + Index : O_Dnode; + High : O_Dnode; + If_Blk : O_If_Block; + Label : O_Snode; + begin + Open_Temp; + Rng := Stabilize (Chap3.Type_To_Range (Iter_Type)); + Slice := Create_Temp (Type_Info.T.Range_Type); + Slice_Ptr := Create_Temp_Ptr + (Type_Info.T.Range_Ptr_Type, New_Obj (Slice)); + Chap7.Translate_Discrete_Range_Ptr + (Slice_Ptr, Get_Suffix (Spec)); + Left := Create_Temp_Init + (Ghdl_Index_Type, + Chap6.Translate_Index_To_Offset + (Rng, + New_Value (New_Selected_Element + (New_Obj (Slice), Type_Info.T.Range_Left)), + Spec, Iter_Type, Spec)); + Right := Create_Temp_Init + (Ghdl_Index_Type, + Chap6.Translate_Index_To_Offset + (Rng, + New_Value (New_Selected_Element + (New_Obj (Slice), + Type_Info.T.Range_Right)), + Spec, Iter_Type, Spec)); + Index := Create_Temp (Ghdl_Index_Type); + High := Create_Temp (Ghdl_Index_Type); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Rng)), + New_Value + (New_Selected_Element + (New_Obj (Slice), + Type_Info.T.Range_Dir)), + Ghdl_Bool_Type)); + -- Same direction, so left to right. + New_Assign_Stmt (New_Obj (Index), + New_Value (New_Obj (Left))); + New_Assign_Stmt (New_Obj (High), + New_Value (New_Obj (Right))); + New_Else_Stmt (If_Blk); + -- Opposite direction, so right to left. + New_Assign_Stmt (New_Obj (Index), + New_Value (New_Obj (Right))); + New_Assign_Stmt (New_Obj (High), + New_Value (New_Obj (Left))); + Finish_If_Stmt (If_Blk); + + -- Loop. + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, New_Compare_Op (ON_Gt, + New_Value (New_Obj (Index)), + New_Value (New_Obj (High)), + Ghdl_Bool_Type)); + Open_Temp; + Gen_Subblock_Call (New_Value (New_Obj (Index)), True); + Close_Temp; + Inc_Var (Index); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + when others => + Error_Kind + ("translate_generate_block_configuration_calls", Spec); + end case; + else + -- Conditional generate statement. + declare + Var : O_Dnode; + If_Blk : O_If_Block; + begin + -- Configure the block only if it was created. + Open_Temp; + Var := Create_Temp_Init + (Info.Block_Decls_Ptr_Type, + New_Value (New_Selected_Element + (Get_Instance_Ref (Parent_Info.Block_Scope), + Info.Block_Parent_Field))); + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Neq, + New_Obj_Value (Var), + New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)), + Ghdl_Bool_Type)); + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + Translate_Block_Configuration_Calls (Block_Config, Block, Info); + Clear_Scope (Info.Block_Scope); + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + end if; + end Translate_Generate_Block_Configuration_Calls; + + procedure Translate_Block_Configuration_Calls + (Block_Config : Iir_Block_Configuration; + Base_Block : Iir; + Base_Info : Block_Info_Acc) + is + El : Iir; + begin + El := Get_Configuration_Item_Chain (Block_Config); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Component_Configuration + | Iir_Kind_Configuration_Specification => + Translate_Component_Configuration_Call + (El, Base_Block, Base_Info); + when Iir_Kind_Block_Configuration => + declare + Block : constant Iir := Strip_Denoting_Name + (Get_Block_Specification (El)); + begin + if Get_Kind (Block) = Iir_Kind_Block_Statement then + Translate_Block_Configuration_Calls + (El, Base_Block, Get_Info (Block)); + else + Translate_Generate_Block_Configuration_Calls + (El, Base_Info); + end if; + end; + when others => + Error_Kind ("translate_block_configuration_calls(2)", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Block_Configuration_Calls; + + procedure Translate_Configuration_Declaration (Config : Iir) + is + Block_Config : constant Iir_Block_Configuration := + Get_Block_Configuration (Config); + Arch : constant Iir_Architecture_Body := + Get_Block_Specification (Block_Config); + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); + Interface_List : O_Inter_List; + Config_Info : Config_Info_Acc; + Instance : O_Dnode; + Num : Iir_Int32; + Final : Boolean; + begin + if Get_Kind (Config) = Iir_Kind_Configuration_Declaration then + Chap4.Translate_Declaration_Chain (Config); + end if; + + Config_Info := Add_Info (Config, Kind_Config); + + -- Configurator. + Start_Procedure_Decl + (Interface_List, Create_Identifier, Global_Storage); + New_Interface_Decl (Interface_List, Instance, Wki_Instance, + Arch_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, Config_Info.Config_Subprg); + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Declare subprograms for configuration. + Num := 0; + Translate_Block_Configuration_Decls (Block_Config, Arch, Arch, Num); + + -- Body. + Start_Subprogram_Body (Config_Info.Config_Subprg); + Push_Local_Factory; + + Push_Architecture_Scope (Arch, Instance); + + if Get_Kind (Config) = Iir_Kind_Configuration_Declaration then + Open_Temp; + Chap4.Elab_Declaration_Chain (Config, Final); + Close_Temp; + if Final then + raise Internal_Error; + end if; + end if; + + Translate_Block_Configuration_Calls (Block_Config, Arch, Arch_Info); + + Pop_Architecture_Scope (Arch); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Configuration_Declaration; + end Chap1; + + package body Chap2 is + procedure Elab_Package (Spec : Iir_Package_Declaration); + + type Name_String_Xlat_Array is array (Name_Id range <>) of + String (1 .. 4); + Operator_String_Xlat : constant + Name_String_Xlat_Array (Std_Names.Name_Id_Operators) := + (Std_Names.Name_Op_Equality => "OPEq", + Std_Names.Name_Op_Inequality => "OPNe", + Std_Names.Name_Op_Less => "OPLt", + Std_Names.Name_Op_Less_Equal => "OPLe", + Std_Names.Name_Op_Greater => "OPGt", + Std_Names.Name_Op_Greater_Equal => "OPGe", + Std_Names.Name_Op_Plus => "OPPl", + Std_Names.Name_Op_Minus => "OPMi", + Std_Names.Name_Op_Mul => "OPMu", + Std_Names.Name_Op_Div => "OPDi", + Std_Names.Name_Op_Exp => "OPEx", + Std_Names.Name_Op_Concatenation => "OPCc", + Std_Names.Name_Op_Condition => "OPCd", + Std_Names.Name_Op_Match_Equality => "OPQe", + Std_Names.Name_Op_Match_Inequality => "OPQi", + Std_Names.Name_Op_Match_Less => "OPQL", + Std_Names.Name_Op_Match_Less_Equal => "OPQl", + Std_Names.Name_Op_Match_Greater => "OPQG", + Std_Names.Name_Op_Match_Greater_Equal => "OPQg"); + + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type) + is + Id : Name_Id; + begin + -- FIXME: name_shift_operators, name_logical_operators, + -- name_word_operators, name_mod, name_rem + Id := Get_Identifier (Spec); + if Id in Std_Names.Name_Id_Operators then + Push_Identifier_Prefix + (Mark, Operator_String_Xlat (Id), Get_Overload_Number (Spec)); + else + Push_Identifier_Prefix (Mark, Id, Get_Overload_Number (Spec)); + end if; + end Push_Subprg_Identifier; + + procedure Translate_Subprogram_Interfaces (Spec : Iir) + is + Inter : Iir; + Mark : Id_Mark_Type; + begin + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + Push_Subprg_Identifier (Spec, Mark); + + -- Translate interface types. + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Chap3.Translate_Object_Subtype (Inter); + Inter := Get_Chain (Inter); + end loop; + Pop_Identifier_Prefix (Mark); + end Translate_Subprogram_Interfaces; + + procedure Elab_Subprogram_Interfaces (Spec : Iir) + is + Inter : Iir; + begin + -- Translate interface types. + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Chap3.Elab_Object_Subtype (Get_Type (Inter)); + Inter := Get_Chain (Inter); + end loop; + end Elab_Subprogram_Interfaces; + + + -- Return the type of a subprogram interface. + -- Return O_Tnode_Null if the parameter is passed through the + -- interface record. + function Translate_Interface_Type (Inter : Iir) return O_Tnode + is + Mode : Object_Kind_Type; + Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (Inter)); + begin + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_File_Declaration => + Mode := Mode_Value; + when Iir_Kind_Interface_Signal_Declaration => + Mode := Mode_Signal; + when others => + Error_Kind ("translate_interface_type", Inter); + end case; + case Tinfo.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_By_Value => + return Tinfo.Ortho_Type (Mode); + when Type_Mode_By_Copy + | Type_Mode_By_Ref => + return Tinfo.Ortho_Ptr_Type (Mode); + end case; + end Translate_Interface_Type; + + procedure Translate_Subprogram_Declaration (Spec : Iir) + is + Info : constant Subprg_Info_Acc := Get_Info (Spec); + Is_Func : constant Boolean := + Get_Kind (Spec) = Iir_Kind_Function_Declaration; + Inter : Iir; + Inter_Type : Iir; + Arg_Info : Ortho_Info_Acc; + Tinfo : Type_Info_Acc; + Interface_List : O_Inter_List; + Has_Result_Record : Boolean; + El_List : O_Element_List; + Mark : Id_Mark_Type; + Rtype : Iir; + Id : O_Ident; + Storage : O_Storage; + Foreign : Foreign_Info_Type := Foreign_Bad; + begin + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + Push_Subprg_Identifier (Spec, Mark); + + if Get_Foreign_Flag (Spec) then + -- Special handling for foreign subprograms. + Foreign := Translate_Foreign_Id (Spec); + case Foreign.Kind is + when Foreign_Unknown => + Id := Create_Identifier; + when Foreign_Intrinsic => + Id := Create_Identifier; + when Foreign_Vhpidirect => + Id := Get_Identifier + (Name_Table.Name_Buffer (Foreign.Subprg_First + .. Foreign.Subprg_Last)); + end case; + Storage := O_Storage_External; + else + Id := Create_Identifier; + Storage := Global_Storage; + end if; + + if Is_Func then + -- If the result of a function is a composite type for ortho, + -- the result is allocated by the caller and an access to it is + -- given to the function. + Rtype := Get_Return_Type (Spec); + Info.Use_Stack2 := False; + Tinfo := Get_Info (Rtype); + + if Is_Composite (Tinfo) then + Start_Procedure_Decl (Interface_List, Id, Storage); + New_Interface_Decl + (Interface_List, Info.Res_Interface, + Get_Identifier ("RESULT"), + Tinfo.Ortho_Ptr_Type (Mode_Value)); + -- Furthermore, if the result type is unconstrained, the + -- function will allocate it on a secondary stack. + if not Is_Fully_Constrained_Type (Rtype) then + Info.Use_Stack2 := True; + end if; + else + -- Normal function. + Start_Function_Decl + (Interface_List, Id, Storage, Tinfo.Ortho_Type (Mode_Value)); + Info.Res_Interface := O_Dnode_Null; + end if; + else + -- Create info for each interface of the procedure. + -- For parameters passed via copy and that needs a copy-out, + -- gather them in a record. An access to the record is then + -- passed to the procedure. + Has_Result_Record := False; + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Arg_Info := Add_Info (Inter, Kind_Interface); + Inter_Type := Get_Type (Inter); + Tinfo := Get_Info (Inter_Type); + if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration + and then Get_Mode (Inter) in Iir_Out_Modes + and then Tinfo.Type_Mode not in Type_Mode_By_Ref + and then Tinfo.Type_Mode /= Type_Mode_File + then + -- This interface is done via the result record. + -- Note: file passed through variables are vhdl87 files, + -- which are initialized at elaboration and thus + -- behave like an IN parameter. + if not Has_Result_Record then + -- Create the record. + Start_Record_Type (El_List); + Has_Result_Record := True; + end if; + -- Add a field to the record. + New_Record_Field (El_List, Arg_Info.Interface_Field, + Create_Identifier_Without_Prefix (Inter), + Tinfo.Ortho_Type (Mode_Value)); + else + Arg_Info.Interface_Field := O_Fnode_Null; + end if; + Inter := Get_Chain (Inter); + end loop; + if Has_Result_Record then + -- Declare the record type and an access to the record. + Finish_Record_Type (El_List, Info.Res_Record_Type); + New_Type_Decl (Create_Identifier ("RESTYPE"), + Info.Res_Record_Type); + Info.Res_Record_Ptr := New_Access_Type (Info.Res_Record_Type); + New_Type_Decl (Create_Identifier ("RESPTR"), + Info.Res_Record_Ptr); + else + Info.Res_Interface := O_Dnode_Null; + end if; + + Start_Procedure_Decl (Interface_List, Id, Storage); + + if Has_Result_Record then + -- Add the record parameter. + New_Interface_Decl (Interface_List, Info.Res_Interface, + Get_Identifier ("RESULT"), + Info.Res_Record_Ptr); + end if; + end if; + + -- Instance parameter if any. + if not Get_Foreign_Flag (Spec) then + Chap2.Create_Subprg_Instance (Interface_List, Spec); + end if; + + -- Translate interfaces. + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + if Is_Func then + -- Create the info. + Arg_Info := Add_Info (Inter, Kind_Interface); + Arg_Info.Interface_Field := O_Fnode_Null; + else + -- The info was already created (just above) + Arg_Info := Get_Info (Inter); + end if; + + if Arg_Info.Interface_Field = O_Fnode_Null then + -- Not via the RESULT parameter. + Arg_Info.Interface_Type := Translate_Interface_Type (Inter); + New_Interface_Decl + (Interface_List, Arg_Info.Interface_Node, + Create_Identifier_Without_Prefix (Inter), + Arg_Info.Interface_Type); + end if; + Inter := Get_Chain (Inter); + end loop; + Finish_Subprogram_Decl (Interface_List, Info.Ortho_Func); + + -- Call the hook for foreign subprograms. + if Get_Foreign_Flag (Spec) and then Foreign_Hook /= null then + Foreign_Hook.all (Spec, Foreign, Info.Ortho_Func); + end if; + + Save_Local_Identifier (Info.Subprg_Local_Id); + Pop_Identifier_Prefix (Mark); + end Translate_Subprogram_Declaration; + + -- Return TRUE iff subprogram specification SPEC is translated in an + -- ortho function. + function Is_Subprogram_Ortho_Function (Spec : Iir) return Boolean + is + begin + if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then + return False; + end if; + if Get_Info (Spec).Res_Interface /= O_Dnode_Null then + return False; + end if; + return True; + end Is_Subprogram_Ortho_Function; + + -- Return TRUE iif SUBPRG_BODY declares explicitely or implicitely + -- (or even implicitely by translation) a subprogram. + function Has_Nested_Subprograms (Subprg_Body : Iir) return Boolean + is + Decl : Iir; + Atype : Iir; + begin + Decl := Get_Declaration_Chain (Subprg_Body); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + return True; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + -- The declaration preceed the body. + raise Internal_Error; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Atype := Get_Type_Definition (Decl); + case Iir_Kinds_Type_And_Subtype_Definition + (Get_Kind (Atype)) is + when Iir_Kinds_Scalar_Type_Definition => + null; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + null; + when Iir_Kind_File_Type_Definition => + return True; + when Iir_Kind_Protected_Type_Declaration => + raise Internal_Error; + when Iir_Kinds_Composite_Type_Definition => + -- At least for "=". + return True; + when Iir_Kind_Incomplete_Type_Definition => + null; + end case; + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + return False; + end Has_Nested_Subprograms; + + procedure Translate_Subprogram_Body (Subprg : Iir) + is + Spec : constant Iir := Get_Subprogram_Specification (Subprg); + Info : constant Ortho_Info_Acc := Get_Info (Spec); + + Old_Subprogram : Iir; + Mark : Id_Mark_Type; + Final : Boolean; + Is_Ortho_Func : Boolean; + + -- Set for a public method. In this case, the lock must be acquired + -- and retained. + Is_Prot : Boolean := False; + + -- True if the body has local (nested) subprograms. + Has_Nested : Boolean; + + Frame_Ptr_Type : O_Tnode; + Upframe_Field : O_Fnode; + + Frame : O_Dnode; + Frame_Ptr : O_Dnode; + + Has_Return : Boolean; + + Prev_Subprg_Instances : Chap2.Subprg_Instance_Stack; + begin + -- Do not translate body for foreign subprograms. + if Get_Foreign_Flag (Spec) then + return; + end if; + + -- Check if there are nested subprograms to unnest. In that case, + -- a frame record is created, which is less efficient than the + -- use of local variables. + if Flag_Unnest_Subprograms then + Has_Nested := Has_Nested_Subprograms (Subprg); + else + Has_Nested := False; + end if; + + -- Set the identifier prefix with the subprogram identifier and + -- overload number if any. + Push_Subprg_Identifier (Spec, Mark); + Restore_Local_Identifier (Info.Subprg_Local_Id); + + if Has_Nested then + -- Unnest subprograms. + -- Create an instance for the local declarations. + Push_Instance_Factory (Info.Subprg_Frame_Scope'Access); + Add_Subprg_Instance_Field (Upframe_Field); + + if Info.Res_Record_Ptr /= O_Tnode_Null then + Info.Res_Record_Var := + Create_Var (Create_Var_Identifier ("RESULT"), + Info.Res_Record_Ptr); + end if; + + -- Create fields for parameters. + -- FIXME: do it only if they are referenced in nested + -- subprograms. + declare + Inter : Iir; + Inter_Info : Inter_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Inter_Info := Get_Info (Inter); + if Inter_Info.Interface_Node /= O_Dnode_Null then + Inter_Info.Interface_Field := + Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inter), + Inter_Info.Interface_Type); + end if; + Inter := Get_Chain (Inter); + end loop; + end; + + Chap4.Translate_Declaration_Chain (Subprg); + Pop_Instance_Factory (Info.Subprg_Frame_Scope'Access); + + New_Type_Decl (Create_Identifier ("_FRAMETYPE"), + Get_Scope_Type (Info.Subprg_Frame_Scope)); + Declare_Scope_Acc + (Info.Subprg_Frame_Scope, + Create_Identifier ("_FRAMEPTR"), Frame_Ptr_Type); + + Rtis.Generate_Subprogram_Body (Subprg); + + -- Local frame + Chap2.Push_Subprg_Instance + (Info.Subprg_Frame_Scope'Access, Frame_Ptr_Type, + Wki_Upframe, Prev_Subprg_Instances); + -- Link to previous frame + Chap2.Start_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instances, Upframe_Field); + + Chap4.Translate_Declaration_Chain_Subprograms (Subprg); + + -- Link to previous frame + Chap2.Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instances, Upframe_Field); + -- Local frame + Chap2.Pop_Subprg_Instance (Wki_Upframe, Prev_Subprg_Instances); + end if; + + -- Create the body + + Start_Subprogram_Body (Info.Ortho_Func); + + Start_Subprg_Instance_Use (Spec); + + -- Variables will be created on the stack. + Push_Local_Factory; + + -- Code has access to local (and outer) variables. + -- FIXME: this is not necessary if Has_Nested is set + Chap2.Clear_Subprg_Instance (Prev_Subprg_Instances); + + -- There is a local scope for temporaries. + Open_Local_Temp; + + if not Has_Nested then + Chap4.Translate_Declaration_Chain (Subprg); + Rtis.Generate_Subprogram_Body (Subprg); + Chap4.Translate_Declaration_Chain_Subprograms (Subprg); + else + New_Var_Decl (Frame, Wki_Frame, O_Storage_Local, + Get_Scope_Type (Info.Subprg_Frame_Scope)); + + New_Var_Decl (Frame_Ptr, Get_Identifier ("FRAMEPTR"), + O_Storage_Local, Frame_Ptr_Type); + New_Assign_Stmt (New_Obj (Frame_Ptr), + New_Address (New_Obj (Frame), Frame_Ptr_Type)); + + -- FIXME: use direct reference (ie Frame instead of Frame_Ptr) + Set_Scope_Via_Param_Ptr (Info.Subprg_Frame_Scope, Frame_Ptr); + + -- Set UPFRAME. + Chap2.Set_Subprg_Instance_Field + (Frame_Ptr, Upframe_Field, Info.Subprg_Instance); + + if Info.Res_Record_Type /= O_Tnode_Null then + -- Initialize the RESULT field + New_Assign_Stmt (Get_Var (Info.Res_Record_Var), + New_Obj_Value (Info.Res_Interface)); + -- Do not reference the RESULT field in the subprogram body, + -- directly reference the RESULT parameter. + -- FIXME: has a flag (see below for parameters). + Info.Res_Record_Var := Null_Var; + end if; + + -- Copy parameters to FRAME. + declare + Inter : Iir; + Inter_Info : Inter_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + Inter_Info := Get_Info (Inter); + if Inter_Info.Interface_Node /= O_Dnode_Null then + New_Assign_Stmt + (New_Selected_Element (New_Obj (Frame), + Inter_Info.Interface_Field), + New_Obj_Value (Inter_Info.Interface_Node)); + + -- Forget the reference to the field in FRAME, so that + -- this subprogram will directly reference the parameter + -- (and not its copy in the FRAME). + Inter_Info.Interface_Field := O_Fnode_Null; + end if; + Inter := Get_Chain (Inter); + end loop; + end; + end if; + + -- Init out parameters passed by value/copy. + declare + Inter : Iir; + Inter_Type : Iir; + Type_Info : Type_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + if Get_Kind (Inter) = Iir_Kind_Interface_Variable_Declaration + and then Get_Mode (Inter) = Iir_Out_Mode + then + Inter_Type := Get_Type (Inter); + Type_Info := Get_Info (Inter_Type); + if (Type_Info.Type_Mode in Type_Mode_By_Value + or Type_Info.Type_Mode in Type_Mode_By_Copy) + and then Type_Info.Type_Mode /= Type_Mode_File + then + Chap4.Init_Object + (Chap6.Translate_Name (Inter), Inter_Type); + end if; + end if; + Inter := Get_Chain (Inter); + end loop; + end; + + Chap4.Elab_Declaration_Chain (Subprg, Final); + + -- If finalization is required, create a dummy loop around the + -- body and convert returns into exit out of this loop. + -- If the subprogram is a function, also create a variable for the + -- result. + Is_Prot := Is_Subprogram_Method (Spec); + if Final or Is_Prot then + if Is_Prot then + -- Lock the object. + Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), + Ghdl_Protected_Enter); + end if; + Is_Ortho_Func := Is_Subprogram_Ortho_Function (Spec); + if Is_Ortho_Func then + New_Var_Decl + (Info.Subprg_Result, Get_Identifier ("RESULT"), + O_Storage_Local, + Get_Ortho_Type (Get_Return_Type (Spec), Mode_Value)); + end if; + Start_Loop_Stmt (Info.Subprg_Exit); + end if; + + Old_Subprogram := Current_Subprogram; + Current_Subprogram := Spec; + Has_Return := Chap8.Translate_Statements_Chain_Has_Return + (Get_Sequential_Statement_Chain (Subprg)); + Current_Subprogram := Old_Subprogram; + + if Final or Is_Prot then + -- Create a barrier to catch missing return statement. + if Get_Kind (Spec) = Iir_Kind_Procedure_Declaration then + New_Exit_Stmt (Info.Subprg_Exit); + else + if not Has_Return then + -- Missing return + Chap6.Gen_Program_Error + (Subprg, Chap6.Prg_Err_Missing_Return); + end if; + end if; + Finish_Loop_Stmt (Info.Subprg_Exit); + Chap4.Final_Declaration_Chain (Subprg, False); + + if Is_Prot then + -- Unlock the object. + Chap3.Call_Ghdl_Protected_Procedure (Get_Method_Type (Spec), + Ghdl_Protected_Leave); + end if; + if Is_Ortho_Func then + New_Return_Stmt (New_Obj_Value (Info.Subprg_Result)); + end if; + else + if Get_Kind (Spec) = Iir_Kind_Function_Declaration + and then not Has_Return + then + -- Missing return + Chap6.Gen_Program_Error + (Subprg, Chap6.Prg_Err_Missing_Return); + end if; + end if; + + if Has_Nested then + Clear_Scope (Info.Subprg_Frame_Scope); + end if; + + Chap2.Pop_Subprg_Instance (O_Ident_Nul, Prev_Subprg_Instances); + Close_Local_Temp; + Pop_Local_Factory; + + Finish_Subprg_Instance_Use (Spec); + + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Mark); + end Translate_Subprogram_Body; + + procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration) + is + Header : constant Iir := Get_Package_Header (Decl); + Info : Ortho_Info_Acc; + Interface_List : O_Inter_List; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Info := Add_Info (Decl, Kind_Package); + + -- Translate declarations. + if Is_Uninstantiated_Package (Decl) then + -- Create an instance for the spec. + Push_Instance_Factory (Info.Package_Spec_Scope'Access); + Chap4.Translate_Generic_Chain (Header); + Chap4.Translate_Declaration_Chain (Decl); + Info.Package_Elab_Var := Create_Var + (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); + Pop_Instance_Factory (Info.Package_Spec_Scope'Access); + + -- Name the spec instance and create a pointer. + New_Type_Decl (Create_Identifier ("SPECINSTTYPE"), + Get_Scope_Type (Info.Package_Spec_Scope)); + Declare_Scope_Acc (Info.Package_Spec_Scope, + Create_Identifier ("SPECINSTPTR"), + Info.Package_Spec_Ptr_Type); + + -- Create an instance and its pointer for the body. + Chap2.Declare_Inst_Type_And_Ptr + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type); + + -- Each subprogram has a body instance argument. + Chap2.Push_Subprg_Instance + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + else + Chap4.Translate_Declaration_Chain (Decl); + Info.Package_Elab_Var := Create_Var + (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); + end if; + + -- Translate subprograms declarations. + Chap4.Translate_Declaration_Chain_Subprograms (Decl); + + -- Declare elaborator for the body. + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB_BODY"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.Package_Elab_Body_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Elab_Body_Subprg); + + if Is_Uninstantiated_Package (Decl) then + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + + -- The spec elaborator has a spec instance argument. + Chap2.Push_Subprg_Instance + (Info.Package_Spec_Scope'Access, Info.Package_Spec_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + end if; + + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB_SPEC"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.Package_Elab_Spec_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Elab_Spec_Subprg); + + if Flag_Rti then + -- Generate RTI. + Rtis.Generate_Unit (Decl); + end if; + + if Global_Storage = O_Storage_Public then + -- Create elaboration procedure for the spec + Elab_Package (Decl); + end if; + + if Is_Uninstantiated_Package (Decl) then + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end if; + Save_Local_Identifier (Info.Package_Local_Id); + end Translate_Package_Declaration; + + procedure Translate_Package_Body (Decl : Iir_Package_Body) + is + Spec : constant Iir_Package_Declaration := Get_Package (Decl); + Info : constant Ortho_Info_Acc := Get_Info (Spec); + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + -- Translate declarations. + if Is_Uninstantiated_Package (Spec) then + Push_Instance_Factory (Info.Package_Body_Scope'Access); + Info.Package_Spec_Field := Add_Instance_Factory_Field + (Get_Identifier ("SPEC"), + Get_Scope_Type (Info.Package_Spec_Scope)); + + Chap4.Translate_Declaration_Chain (Decl); + + Pop_Instance_Factory (Info.Package_Body_Scope'Access); + + if Global_Storage = O_Storage_External then + return; + end if; + else + -- May be called during elaboration to generate RTI. + if Global_Storage = O_Storage_External then + return; + end if; + + Restore_Local_Identifier (Get_Info (Spec).Package_Local_Id); + + Chap4.Translate_Declaration_Chain (Decl); + end if; + + if Flag_Rti then + Rtis.Generate_Unit (Decl); + end if; + + if Is_Uninstantiated_Package (Spec) then + Chap2.Push_Subprg_Instance + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + Set_Scope_Via_Field (Info.Package_Spec_Scope, + Info.Package_Spec_Field, + Info.Package_Body_Scope'Access); + end if; + + Chap4.Translate_Declaration_Chain_Subprograms (Decl); + + if Is_Uninstantiated_Package (Spec) then + Clear_Scope (Info.Package_Spec_Scope); + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end if; + + Elab_Package_Body (Spec, Decl); + end Translate_Package_Body; + + procedure Elab_Package (Spec : Iir_Package_Declaration) + is + Info : constant Ortho_Info_Acc := Get_Info (Spec); + Final : Boolean; + Constr : O_Assoc_List; + pragma Unreferenced (Final); + begin + Start_Subprogram_Body (Info.Package_Elab_Spec_Subprg); + Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); + + Elab_Dependence (Get_Design_Unit (Spec)); + + if not Is_Uninstantiated_Package (Spec) + and then Get_Kind (Get_Parent (Spec)) = Iir_Kind_Design_Unit + then + -- Register the top level package. This is done dynamically, as + -- we know only during elaboration that the design depends on a + -- package (a package maybe referenced by an entity which is never + -- instantiated due to generate statements). + Start_Association (Constr, Ghdl_Rti_Add_Package); + New_Association + (Constr, + New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const))); + New_Procedure_Call (Constr); + end if; + + Open_Temp; + Chap4.Elab_Declaration_Chain (Spec, Final); + Close_Temp; + + Chap2.Finish_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Elab_Package; + + procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir) + is + Info : constant Ortho_Info_Acc := Get_Info (Spec); + If_Blk : O_If_Block; + Constr : O_Assoc_List; + Final : Boolean; + begin + Start_Subprogram_Body (Info.Package_Elab_Body_Subprg); + Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); + + if Is_Uninstantiated_Package (Spec) then + Set_Scope_Via_Field (Info.Package_Spec_Scope, + Info.Package_Spec_Field, + Info.Package_Body_Scope'Access); + end if; + + -- If the package was already elaborated, return now, + -- else mark the package as elaborated. + Start_If_Stmt (If_Blk, New_Value (Get_Var (Info.Package_Elab_Var))); + New_Return_Stmt; + New_Else_Stmt (If_Blk); + New_Assign_Stmt (Get_Var (Info.Package_Elab_Var), + New_Lit (Ghdl_Bool_True_Node)); + Finish_If_Stmt (If_Blk); + + -- Elab Spec. + Start_Association (Constr, Info.Package_Elab_Spec_Subprg); + Add_Subprg_Instance_Assoc (Constr, Info.Package_Elab_Spec_Instance); + New_Procedure_Call (Constr); + + if Bod /= Null_Iir then + Elab_Dependence (Get_Design_Unit (Bod)); + Open_Temp; + Chap4.Elab_Declaration_Chain (Bod, Final); + Close_Temp; + end if; + + if Is_Uninstantiated_Package (Spec) then + Clear_Scope (Info.Package_Spec_Scope); + end if; + + Chap2.Finish_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Elab_Package_Body; + + procedure Instantiate_Iir_Info (N : Iir); + + procedure Instantiate_Iir_Chain_Info (Chain : Iir) + is + N : Iir; + begin + N := Chain; + while N /= Null_Iir loop + Instantiate_Iir_Info (N); + N := Get_Chain (N); + end loop; + end Instantiate_Iir_Chain_Info; + + procedure Instantiate_Iir_List_Info (L : Iir_List) + is + El : Iir; + begin + case L is + when Null_Iir_List + | Iir_List_All + | Iir_List_Others => + return; + when others => + for I in Natural loop + El := Get_Nth_Element (L, I); + exit when El = Null_Iir; + Instantiate_Iir_Info (El); + end loop; + end case; + end Instantiate_Iir_List_Info; + + procedure Copy_Info (Dest : Ortho_Info_Acc; Src : Ortho_Info_Acc) is + begin + case Src.Kind is + when Kind_Type => + Dest.all := (Kind => Kind_Type, + Type_Mode => Src.Type_Mode, + Type_Incomplete => Src.Type_Incomplete, + Type_Locally_Constrained => + Src.Type_Locally_Constrained, + C => null, + Ortho_Type => Src.Ortho_Type, + Ortho_Ptr_Type => Src.Ortho_Ptr_Type, + Type_Transient_Chain => Null_Iir, + T => Src.T, + Type_Rti => Src.Type_Rti); + pragma Assert (Src.C = null); + pragma Assert (Src.Type_Transient_Chain = Null_Iir); + when Kind_Object => + pragma Assert (Src.Object_Driver = Null_Var); + pragma Assert (Src.Object_Function = O_Dnode_Null); + Dest.all := + (Kind => Kind_Object, + Object_Static => Src.Object_Static, + Object_Var => Instantiate_Var (Src.Object_Var), + Object_Driver => Null_Var, + Object_Rti => Src.Object_Rti, + Object_Function => O_Dnode_Null); + when Kind_Subprg => + Dest.Subprg_Frame_Scope := + Instantiate_Var_Scope (Src.Subprg_Frame_Scope); + Dest.all := + (Kind => Kind_Subprg, + Use_Stack2 => Src.Use_Stack2, + Ortho_Func => Src.Ortho_Func, + Res_Interface => Src.Res_Interface, + Res_Record_Var => Instantiate_Var (Src.Res_Record_Var), + Res_Record_Type => Src.Res_Record_Type, + Res_Record_Ptr => Src.Res_Record_Ptr, + Subprg_Frame_Scope => Dest.Subprg_Frame_Scope, + Subprg_Instance => Instantiate_Subprg_Instance + (Src.Subprg_Instance), + Subprg_Resolv => null, + Subprg_Local_Id => Src.Subprg_Local_Id, + Subprg_Exit => Src.Subprg_Exit, + Subprg_Result => Src.Subprg_Result); + when Kind_Interface => + Dest.all := (Kind => Kind_Interface, + Interface_Node => Src.Interface_Node, + Interface_Field => Src.Interface_Field, + Interface_Type => Src.Interface_Type); + when Kind_Index => + Dest.all := (Kind => Kind_Index, + Index_Field => Src.Index_Field); + when Kind_Expr => + Dest.all := (Kind => Kind_Expr, + Expr_Node => Src.Expr_Node); + when others => + raise Internal_Error; + end case; + end Copy_Info; + + procedure Instantiate_Iir_Info (N : Iir) is + begin + -- Nothing to do for null node. + if N = Null_Iir then + return; + end if; + + declare + use Nodes_Meta; + Kind : constant Iir_Kind := Get_Kind (N); + Fields : constant Fields_Array := Get_Fields (Kind); + F : Fields_Enum; + Orig : constant Iir := Sem_Inst.Get_Origin (N); + pragma Assert (Orig /= Null_Iir); + Orig_Info : constant Ortho_Info_Acc := Get_Info (Orig); + Info : Ortho_Info_Acc; + begin + if Orig_Info /= null then + Info := Add_Info (N, Orig_Info.Kind); + + Copy_Info (Info, Orig_Info); + + case Info.Kind is + when Kind_Subprg => + Push_Instantiate_Var_Scope + (Info.Subprg_Frame_Scope'Access, + Orig_Info.Subprg_Frame_Scope'Access); + when others => + null; + end case; + end if; + + for I in Fields'Range loop + F := Fields (I); + case Get_Field_Type (F) is + when Type_Iir => + case Get_Field_Attribute (F) is + when Attr_None => + Instantiate_Iir_Info (Get_Iir (N, F)); + when Attr_Ref => + null; + when Attr_Maybe_Ref => + if not Get_Is_Ref (N) then + Instantiate_Iir_Info (Get_Iir (N, F)); + end if; + when Attr_Chain => + Instantiate_Iir_Chain_Info (Get_Iir (N, F)); + when Attr_Chain_Next => + null; + when Attr_Of_Ref => + raise Internal_Error; + end case; + when Type_Iir_List => + case Get_Field_Attribute (F) is + when Attr_None => + Instantiate_Iir_List_Info (Get_Iir_List (N, F)); + when Attr_Ref + | Attr_Of_Ref => + null; + when others => + raise Internal_Error; + end case; + when Type_PSL_NFA + | Type_PSL_Node => + -- TODO + raise Internal_Error; + when Type_Date_Type + | Type_Date_State_Type + | Type_Time_Stamp_Id => + -- Can this happen ? + raise Internal_Error; + when Type_String_Id + | Type_Source_Ptr + | Type_Base_Type + | Type_Iir_Constraint + | Type_Iir_Mode + | Type_Iir_Index32 + | Type_Iir_Int64 + | Type_Boolean + | Type_Iir_Staticness + | Type_Iir_All_Sensitized + | Type_Iir_Signal_Kind + | Type_Tri_State_Type + | Type_Iir_Pure_State + | Type_Iir_Delay_Mechanism + | Type_Iir_Lexical_Layout_Type + | Type_Iir_Predefined_Functions + | Type_Iir_Direction + | Type_Location_Type + | Type_Iir_Int32 + | Type_Int32 + | Type_Iir_Fp64 + | Type_Token_Type + | Type_Name_Id => + null; + end case; + end loop; + + if Info /= null then + case Info.Kind is + when Kind_Subprg => + Pop_Instantiate_Var_Scope + (Info.Subprg_Frame_Scope'Access); + when others => + null; + end case; + end if; + end; + end Instantiate_Iir_Info; + + procedure Instantiate_Iir_Generic_Chain_Info (Chain : Iir) + is + Inter : Iir; + Orig : Iir; + Orig_Info : Ortho_Info_Acc; + Info : Ortho_Info_Acc; + begin + Inter := Chain; + while Inter /= Null_Iir loop + case Get_Kind (Inter) is + when Iir_Kind_Interface_Constant_Declaration => + Orig := Sem_Inst.Get_Origin (Inter); + Orig_Info := Get_Info (Orig); + + Info := Add_Info (Inter, Orig_Info.Kind); + Copy_Info (Info, Orig_Info); + + when Iir_Kind_Interface_Package_Declaration => + null; + + when others => + raise Internal_Error; + end case; + + Inter := Get_Chain (Inter); + end loop; + end Instantiate_Iir_Generic_Chain_Info; + + -- Add info for an interface_package_declaration or a + -- package_instantiation_declaration + procedure Instantiate_Info_Package (Inst : Iir) + is + Spec : constant Iir := + Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst)); + Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec); + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Inst, Kind_Package_Instance); + + -- Create the info instances. + Push_Instantiate_Var_Scope + (Info.Package_Instance_Spec_Scope'Access, + Pkg_Info.Package_Spec_Scope'Access); + Push_Instantiate_Var_Scope + (Info.Package_Instance_Body_Scope'Access, + Pkg_Info.Package_Body_Scope'Access); + Instantiate_Iir_Generic_Chain_Info (Get_Generic_Chain (Inst)); + Instantiate_Iir_Chain_Info (Get_Declaration_Chain (Inst)); + Pop_Instantiate_Var_Scope + (Info.Package_Instance_Body_Scope'Access); + Pop_Instantiate_Var_Scope + (Info.Package_Instance_Spec_Scope'Access); + end Instantiate_Info_Package; + + procedure Translate_Package_Instantiation_Declaration (Inst : Iir) + is + Spec : constant Iir := + Get_Named_Entity (Get_Uninstantiated_Package_Name (Inst)); + Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec); + Info : Ortho_Info_Acc; + Interface_List : O_Inter_List; + Constr : O_Assoc_List; + begin + Instantiate_Info_Package (Inst); + Info := Get_Info (Inst); + + -- FIXME: if the instantiation occurs within a package declaration, + -- the variable must be declared extern (and public in the body). + Info.Package_Instance_Body_Var := Create_Var + (Create_Var_Identifier (Inst), + Get_Scope_Type (Pkg_Info.Package_Body_Scope)); + + -- FIXME: this is correct only for global instantiation, and only if + -- there is only one. + Set_Scope_Via_Decl (Info.Package_Instance_Body_Scope, + Get_Var_Label (Info.Package_Instance_Body_Var)); + Set_Scope_Via_Field (Info.Package_Instance_Spec_Scope, + Pkg_Info.Package_Spec_Field, + Info.Package_Instance_Body_Scope'Access); + + -- Declare elaboration procedure + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB"), Global_Storage); + -- Chap2.Add_Subprg_Instance_Interfaces + -- (Interface_List, Info.Package_Instance_Elab_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Instance_Elab_Subprg); + + if Global_Storage /= O_Storage_Public then + return; + end if; + + -- Elaborator: + Start_Subprogram_Body (Info.Package_Instance_Elab_Subprg); + -- Chap2.Start_Subprg_Instance_Use + -- (Info.Package_Instance_Elab_Instance); + + Elab_Dependence (Get_Design_Unit (Inst)); + + Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope, + Get_Var_Label (Info.Package_Instance_Body_Var)); + Set_Scope_Via_Field (Pkg_Info.Package_Spec_Scope, + Pkg_Info.Package_Spec_Field, + Pkg_Info.Package_Body_Scope'Access); + Chap5.Elab_Generic_Map_Aspect (Inst); + Clear_Scope (Pkg_Info.Package_Spec_Scope); + Clear_Scope (Pkg_Info.Package_Body_Scope); + + -- Call the elaborator of the generic. The generic must be + -- temporary associated with the instance variable. + Start_Association (Constr, Pkg_Info.Package_Elab_Body_Subprg); + Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope, + Get_Var_Label (Info.Package_Instance_Body_Var)); + Add_Subprg_Instance_Assoc + (Constr, Pkg_Info.Package_Elab_Body_Instance); + Clear_Scope (Pkg_Info.Package_Body_Scope); + New_Procedure_Call (Constr); + + -- Chap2.Finish_Subprg_Instance_Use + -- (Info.Package_Instance_Elab_Instance); + Finish_Subprogram_Body; + end Translate_Package_Instantiation_Declaration; + + procedure Elab_Dependence_Package (Pkg : Iir_Package_Declaration) + is + Info : Ortho_Info_Acc; + If_Blk : O_If_Block; + Constr : O_Assoc_List; + begin + -- Std.Standard is pre-elaborated. + if Pkg = Standard_Package then + return; + end if; + + -- Nothing to do for uninstantiated package. + if Is_Uninstantiated_Package (Pkg) then + return; + end if; + + -- Call the package elaborator only if not already elaborated. + Info := Get_Info (Pkg); + Start_If_Stmt + (If_Blk, + New_Monadic_Op (ON_Not, + New_Value (Get_Var (Info.Package_Elab_Var)))); + -- Elaborates only non-elaborated packages. + Start_Association (Constr, Info.Package_Elab_Body_Subprg); + New_Procedure_Call (Constr); + Finish_If_Stmt (If_Blk); + end Elab_Dependence_Package; + + procedure Elab_Dependence_Package_Instantiation (Pkg : Iir) + is + Info : constant Ortho_Info_Acc := Get_Info (Pkg); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Info.Package_Instance_Elab_Subprg); + New_Procedure_Call (Constr); + end Elab_Dependence_Package_Instantiation; + + procedure Elab_Dependence (Design_Unit: Iir_Design_Unit) + is + Depend_List: Iir_Design_Unit_List; + Design: Iir; + Library_Unit: Iir; + begin + Depend_List := Get_Dependence_List (Design_Unit); + + for I in Natural loop + Design := Get_Nth_Element (Depend_List, I); + exit when Design = Null_Iir; + if Get_Kind (Design) = Iir_Kind_Design_Unit then + Library_Unit := Get_Library_Unit (Design); + case Get_Kind (Library_Unit) is + when Iir_Kind_Package_Declaration => + Elab_Dependence_Package (Library_Unit); + when Iir_Kind_Package_Instantiation_Declaration => + Elab_Dependence_Package_Instantiation (Library_Unit); + when Iir_Kind_Entity_Declaration => + -- FIXME: architecture already elaborates its entity. + null; + when Iir_Kind_Configuration_Declaration => + null; + when Iir_Kind_Architecture_Body => + null; + when Iir_Kind_Package_Body => + -- A package instantiation depends on the body. + null; + when others => + Error_Kind ("elab_dependence", Library_Unit); + end case; + end if; + end loop; + end Elab_Dependence; + + procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc; + Ptr_Type : out O_Tnode) is + begin + Predeclare_Scope_Type (Scope, Create_Identifier ("INSTTYPE")); + Declare_Scope_Acc + (Scope.all, Create_Identifier ("INSTPTR"), Ptr_Type); + end Declare_Inst_Type_And_Ptr; + + procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack) is + begin + Prev := Current_Subprg_Instance; + Current_Subprg_Instance := Null_Subprg_Instance_Stack; + end Clear_Subprg_Instance; + + procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; + Ptr_Type : O_Tnode; + Ident : O_Ident; + Prev : out Subprg_Instance_Stack) + is + begin + Prev := Current_Subprg_Instance; + Current_Subprg_Instance := (Scope => Scope, + Ptr_Type => Ptr_Type, + Ident => Ident); + end Push_Subprg_Instance; + + function Has_Current_Subprg_Instance return Boolean is + begin + return Current_Subprg_Instance.Ptr_Type /= O_Tnode_Null; + end Has_Current_Subprg_Instance; + + procedure Pop_Subprg_Instance (Ident : O_Ident; + Prev : Subprg_Instance_Stack) + is + begin + if Is_Equal (Current_Subprg_Instance.Ident, Ident) then + Current_Subprg_Instance := Prev; + else + -- POP does not match with a push. + raise Internal_Error; + end if; + end Pop_Subprg_Instance; + + procedure Add_Subprg_Instance_Interfaces + (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type) + is + begin + if Has_Current_Subprg_Instance then + Vars.Scope := Current_Subprg_Instance.Scope; + Vars.Inter_Type := Current_Subprg_Instance.Ptr_Type; + New_Interface_Decl + (Interfaces, Vars.Inter, + Current_Subprg_Instance.Ident, + Current_Subprg_Instance.Ptr_Type); + else + Vars := Null_Subprg_Instance; + end if; + end Add_Subprg_Instance_Interfaces; + + procedure Add_Subprg_Instance_Field (Field : out O_Fnode) is + begin + if Has_Current_Subprg_Instance then + Field := Add_Instance_Factory_Field + (Current_Subprg_Instance.Ident, + Current_Subprg_Instance.Ptr_Type); + else + Field := O_Fnode_Null; + end if; + end Add_Subprg_Instance_Field; + + function Has_Subprg_Instance (Vars : Subprg_Instance_Type) + return Boolean is + begin + return Vars.Inter /= O_Dnode_Null; + end Has_Subprg_Instance; + + function Get_Subprg_Instance (Vars : Subprg_Instance_Type) + return O_Enode is + begin + pragma Assert (Has_Subprg_Instance (Vars)); + return New_Address (Get_Instance_Ref (Vars.Scope.all), + Vars.Inter_Type); + end Get_Subprg_Instance; + + procedure Add_Subprg_Instance_Assoc + (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type) is + begin + if Has_Subprg_Instance (Vars) then + New_Association (Assocs, Get_Subprg_Instance (Vars)); + end if; + end Add_Subprg_Instance_Assoc; + + procedure Set_Subprg_Instance_Field + (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type) + is + begin + if Has_Subprg_Instance (Vars) then + New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (Var), Field), + New_Obj_Value (Vars.Inter)); + end if; + end Set_Subprg_Instance_Field; + + procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is + begin + if Has_Subprg_Instance (Vars) then + Set_Scope_Via_Param_Ptr (Vars.Scope.all, Vars.Inter); + end if; + end Start_Subprg_Instance_Use; + + procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is + begin + if Has_Subprg_Instance (Vars) then + Clear_Scope (Vars.Scope.all); + end if; + end Finish_Subprg_Instance_Use; + + procedure Start_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode) is + begin + if Field /= O_Fnode_Null then + Set_Scope_Via_Field_Ptr (Prev.Scope.all, Field, + Current_Subprg_Instance.Scope); + end if; + end Start_Prev_Subprg_Instance_Use_Via_Field; + + procedure Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev : Subprg_Instance_Stack; Field : O_Fnode) is + begin + if Field /= O_Fnode_Null then + Clear_Scope (Prev.Scope.all); + end if; + end Finish_Prev_Subprg_Instance_Use_Via_Field; + + procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List; + Subprg : Iir) + is + begin + Add_Subprg_Instance_Interfaces + (Interfaces, Get_Info (Subprg).Subprg_Instance); + end Create_Subprg_Instance; + + procedure Start_Subprg_Instance_Use (Subprg : Iir) is + begin + Start_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance); + end Start_Subprg_Instance_Use; + + procedure Finish_Subprg_Instance_Use (Subprg : Iir) is + begin + Finish_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance); + end Finish_Subprg_Instance_Use; + + function Instantiate_Subprg_Instance (Inst : Subprg_Instance_Type) + return Subprg_Instance_Type is + begin + return Subprg_Instance_Type' + (Inter => Inst.Inter, + Inter_Type => Inst.Inter_Type, + Scope => Instantiated_Var_Scope (Inst.Scope)); + end Instantiate_Subprg_Instance; + end Chap2; + + package body Chap3 is + function Create_Static_Type_Definition_Type_Range (Def : Iir) + return O_Cnode; + procedure Create_Scalar_Type_Range (Def : Iir; Target : O_Lnode); + + -- For scalar subtypes: creates info from the base type. + procedure Create_Subtype_Info_From_Type (Def : Iir; + Subtype_Info : Type_Info_Acc; + Base_Info : Type_Info_Acc); + + -- Finish a type definition: declare the type, define and declare a + -- pointer to the type. + procedure Finish_Type_Definition + (Info : Type_Info_Acc; Completion : Boolean := False) + is + begin + -- Declare the type. + if not Completion then + New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value)); + end if; + + -- Create an access to the type and declare it. + Info.Ortho_Ptr_Type (Mode_Value) := + New_Access_Type (Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier ("PTR"), + Info.Ortho_Ptr_Type (Mode_Value)); + + -- Signal type. + if Info.Type_Mode in Type_Mode_Scalar then + Info.Ortho_Type (Mode_Signal) := + New_Access_Type (Info.Ortho_Type (Mode_Value)); + end if; + if Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null then + New_Type_Decl (Create_Identifier ("SIG"), + Info.Ortho_Type (Mode_Signal)); + end if; + + -- Signal pointer type. + if Info.Type_Mode in Type_Mode_Composite + and then Info.Ortho_Type (Mode_Signal) /= O_Tnode_Null + then + Info.Ortho_Ptr_Type (Mode_Signal) := + New_Access_Type (Info.Ortho_Type (Mode_Signal)); + New_Type_Decl (Create_Identifier ("SIGPTR"), + Info.Ortho_Ptr_Type (Mode_Signal)); + else + Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; + end if; + end Finish_Type_Definition; + + procedure Create_Size_Var (Def : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Def); + begin + Info.C := new Complex_Type_Arr_Info; + Info.C (Mode_Value).Size_Var := Create_Var + (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type); + if Get_Has_Signal_Flag (Def) then + Info.C (Mode_Signal).Size_Var := Create_Var + (Create_Var_Identifier ("SIGSIZE"), Ghdl_Index_Type); + end if; + end Create_Size_Var; + + -- A builder set internal fields of object pointed by BASE_PTR, using + -- memory from BASE_PTR and returns a pointer to the next memory byte + -- to be used. + procedure Create_Builder_Subprogram_Decl (Info : Type_Info_Acc; + Name : Name_Id; + Kind : Object_Kind_Type) + is + Interface_List : O_Inter_List; + Ident : O_Ident; + Ptype : O_Tnode; + begin + case Kind is + when Mode_Value => + Ident := Create_Identifier (Name, "_BUILDER"); + when Mode_Signal => + Ident := Create_Identifier (Name, "_SIGBUILDER"); + end case; + -- FIXME: return the same type as its first parameter ??? + Start_Function_Decl + (Interface_List, Ident, Global_Storage, Ghdl_Index_Type); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.C (Kind).Builder_Instance); + case Info.Type_Mode is + when Type_Mode_Fat_Array => + Ptype := Info.T.Base_Ptr_Type (Kind); + when Type_Mode_Record => + Ptype := Info.Ortho_Ptr_Type (Kind); + when others => + raise Internal_Error; + end case; + New_Interface_Decl + (Interface_List, Info.C (Kind).Builder_Base_Param, + Get_Identifier ("base_ptr"), Ptype); + -- Add parameter for array bounds. + if Info.Type_Mode = Type_Mode_Fat_Array then + New_Interface_Decl + (Interface_List, Info.C (Kind).Builder_Bound_Param, + Get_Identifier ("bound"), Info.T.Bounds_Ptr_Type); + end if; + Finish_Subprogram_Decl (Interface_List, Info.C (Kind).Builder_Func); + end Create_Builder_Subprogram_Decl; + + function Gen_Call_Type_Builder (Var_Ptr : O_Dnode; + Var_Type : Iir; + Kind : Object_Kind_Type) + return O_Enode + is + Tinfo : constant Type_Info_Acc := Get_Info (Var_Type); + Binfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Var_Type)); + Assoc : O_Assoc_List; + begin + -- Build the field + Start_Association (Assoc, Binfo.C (Kind).Builder_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assoc, Binfo.C (Kind).Builder_Instance); + + case Tinfo.Type_Mode is + when Type_Mode_Record + | Type_Mode_Array => + New_Association (Assoc, New_Obj_Value (Var_Ptr)); + when Type_Mode_Fat_Array => + -- Note: a fat array can only be at the top of a complex type; + -- the bounds must have been set. + New_Association + (Assoc, New_Value_Selected_Acc_Value + (New_Obj (Var_Ptr), Tinfo.T.Base_Field (Kind))); + when others => + raise Internal_Error; + end case; + + if Tinfo.Type_Mode in Type_Mode_Arrays then + declare + Arr : Mnode; + begin + case Type_Mode_Arrays (Tinfo.Type_Mode) is + when Type_Mode_Array => + Arr := T2M (Var_Type, Kind); + when Type_Mode_Fat_Array => + Arr := Dp2M (Var_Ptr, Tinfo, Kind); + end case; + New_Association + (Assoc, M2Addr (Chap3.Get_Array_Bounds (Arr))); + end; + end if; + + return New_Function_Call (Assoc); + end Gen_Call_Type_Builder; + + procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir) + is + Mem : O_Dnode; + V : Mnode; + begin + Open_Temp; + V := Stabilize (Var); + Mem := Create_Temp (Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Mem), + Gen_Call_Type_Builder (M2Dp (V), Var_Type, Get_Object_Kind (Var))); + Close_Temp; + end Gen_Call_Type_Builder; + + ------------------ + -- Enumeration -- + ------------------ + + function Translate_Enumeration_Literal (Lit : Iir_Enumeration_Literal) + return O_Ident + is + El_Str : String (1 .. 4); + Id : Name_Id; + N : Integer; + C : Character; + begin + Id := Get_Identifier (Lit); + if Name_Table.Is_Character (Id) then + C := Name_Table.Get_Character (Id); + El_Str (1) := 'C'; + case C is + when 'A' .. 'Z' + | 'a' .. 'z' + | '0' .. '9' => + El_Str (2) := '_'; + El_Str (3) := C; + when others => + N := Character'Pos (Name_Table.Get_Character (Id)); + El_Str (2) := N2hex (N / 16); + El_Str (3) := N2hex (N mod 16); + end case; + return Get_Identifier (El_Str (1 .. 3)); + else + return Create_Identifier_Without_Prefix (Lit); + end if; + end Translate_Enumeration_Literal; + + procedure Translate_Enumeration_Type + (Def : Iir_Enumeration_Type_Definition) + is + El_List : Iir_List; + El : Iir_Enumeration_Literal; + Constr : O_Enum_List; + Lit_Name : O_Ident; + Val : O_Cnode; + Info : Type_Info_Acc; + Nbr : Natural; + Size : Natural; + begin + El_List := Get_Enumeration_Literal_List (Def); + Nbr := Get_Nbr_Elements (El_List); + if Nbr <= 256 then + Size := 8; + else + Size := 32; + end if; + Start_Enum_Type (Constr, Size); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + + Lit_Name := Translate_Enumeration_Literal (El); + New_Enum_Literal (Constr, Lit_Name, Val); + Set_Ortho_Expr (El, Val); + end loop; + Info := Get_Info (Def); + Finish_Enum_Type (Constr, Info.Ortho_Type (Mode_Value)); + if Nbr <= 256 then + Info.Type_Mode := Type_Mode_E8; + else + Info.Type_Mode := Type_Mode_E32; + end if; + -- Enumerations are always in their range. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + Finish_Type_Definition (Info); + end Translate_Enumeration_Type; + + procedure Translate_Bool_Type (Def : Iir_Enumeration_Type_Definition) + is + Info : Type_Info_Acc; + El_List : Iir_List; + True_Lit, False_Lit : Iir_Enumeration_Literal; + False_Node, True_Node : O_Cnode; + begin + Info := Get_Info (Def); + El_List := Get_Enumeration_Literal_List (Def); + if Get_Nbr_Elements (El_List) /= 2 then + raise Internal_Error; + end if; + False_Lit := Get_Nth_Element (El_List, 0); + True_Lit := Get_Nth_Element (El_List, 1); + New_Boolean_Type + (Info.Ortho_Type (Mode_Value), + Translate_Enumeration_Literal (False_Lit), False_Node, + Translate_Enumeration_Literal (True_Lit), True_Node); + Info.Type_Mode := Type_Mode_B1; + Set_Ortho_Expr (False_Lit, False_Node); + Set_Ortho_Expr (True_Lit, True_Node); + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + Finish_Type_Definition (Info); + end Translate_Bool_Type; + + --------------- + -- Integer -- + --------------- + + -- Return the number of bits (32 or 64) required to represent the + -- (integer or physical) type definition DEF. + type Type_Precision is (Precision_32, Precision_64); + function Get_Type_Precision (Def : Iir) return Type_Precision + is + St : Iir; + L, H : Iir; + Lv, Hv : Iir_Int64; + begin + St := Get_Subtype_Definition (Get_Type_Declarator (Def)); + Get_Low_High_Limit (Get_Range_Constraint (St), L, H); + Lv := Get_Value (L); + Hv := Get_Value (H); + if Lv >= -(2 ** 31) and then Hv <= (2 ** 31 - 1) then + return Precision_32; + else + if Flag_Only_32b then + Error_Msg_Sem + ("range of " & Disp_Node (Get_Type_Declarator (St)) + & " is too large", St); + return Precision_32; + end if; + return Precision_64; + end if; + end Get_Type_Precision; + + procedure Translate_Integer_Type + (Def : Iir_Integer_Type_Definition) + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Def); + case Get_Type_Precision (Def) is + when Precision_32 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); + Info.Type_Mode := Type_Mode_I32; + when Precision_64 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); + Info.Type_Mode := Type_Mode_I64; + end case; + -- Integers are always in their ranges. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + + Finish_Type_Definition (Info); + end Translate_Integer_Type; + + ---------------------- + -- Floating types -- + ---------------------- + + procedure Translate_Floating_Type (Def : Iir_Floating_Type_Definition) + is + Info : Type_Info_Acc; + begin + -- FIXME: should check precision + Info := Get_Info (Def); + Info.Type_Mode := Type_Mode_F64; + Info.Ortho_Type (Mode_Value) := New_Float_Type; + -- Reals are always in their ranges. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + + Finish_Type_Definition (Info); + end Translate_Floating_Type; + + ---------------- + -- Physical -- + ---------------- + + procedure Translate_Physical_Type (Def : Iir_Physical_Type_Definition) + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Def); + case Get_Type_Precision (Def) is + when Precision_32 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (32); + Info.Type_Mode := Type_Mode_P32; + when Precision_64 => + Info.Ortho_Type (Mode_Value) := New_Signed_Type (64); + Info.Type_Mode := Type_Mode_P64; + end case; + -- Phyiscals are always in their ranges. + Info.T.Nocheck_Low := True; + Info.T.Nocheck_Hi := True; + + Finish_Type_Definition (Info); + end Translate_Physical_Type; + + procedure Translate_Physical_Units (Def : Iir_Physical_Type_Definition) + is + Phy_Type : constant O_Tnode := Get_Ortho_Type (Def, Mode_Value); + Unit : Iir; + Info : Object_Info_Acc; + begin + Unit := Get_Unit_Chain (Def); + while Unit /= Null_Iir loop + Info := Add_Info (Unit, Kind_Object); + Info.Object_Var := + Create_Var (Create_Var_Identifier (Unit), Phy_Type); + Unit := Get_Chain (Unit); + end loop; + end Translate_Physical_Units; + + ------------ + -- File -- + ------------ + + procedure Translate_File_Type (Def : Iir_File_Type_Definition) + is + Info : Type_Info_Acc; + begin + Info := Get_Info (Def); + Info.Ortho_Type (Mode_Value) := Ghdl_File_Index_Type; + Info.Ortho_Ptr_Type (Mode_Value) := Ghdl_File_Index_Ptr_Type; + Info.Type_Mode := Type_Mode_File; + end Translate_File_Type; + + function Get_File_Signature_Length (Def : Iir) return Natural is + begin + case Get_Kind (Def) is + when Iir_Kinds_Scalar_Type_Definition => + return 1; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + return 2 + + Get_File_Signature_Length (Get_Element_Subtype (Def)); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + El : Iir; + Res : Natural; + List : Iir_List; + begin + Res := 2; + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Res := Res + Get_File_Signature_Length (Get_Type (El)); + end loop; + return Res; + end; + when others => + Error_Kind ("get_file_signature_length", Def); + end case; + end Get_File_Signature_Length; + + procedure Get_File_Signature (Def : Iir; + Res : in out String; + Off : in out Natural) + is + Scalar_Map : constant array (Type_Mode_Scalar) of Character + := "beEiIpPF"; + begin + case Get_Kind (Def) is + when Iir_Kinds_Scalar_Type_Definition => + Res (Off) := Scalar_Map (Get_Info (Def).Type_Mode); + Off := Off + 1; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + Res (Off) := '['; + Off := Off + 1; + Get_File_Signature (Get_Element_Subtype (Def), Res, Off); + Res (Off) := ']'; + Off := Off + 1; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + declare + El : Iir; + List : Iir_List; + begin + Res (Off) := '<'; + Off := Off + 1; + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Get_File_Signature (Get_Type (El), Res, Off); + end loop; + Res (Off) := '>'; + Off := Off + 1; + end; + when others => + Error_Kind ("get_file_signature", Def); + end case; + end Get_File_Signature; + + procedure Create_File_Type_Var (Def : Iir_File_Type_Definition) + is + Type_Name : constant Iir := Get_Type (Get_File_Type_Mark (Def)); + Info : Type_Info_Acc; + begin + if Get_Kind (Type_Name) in Iir_Kinds_Scalar_Type_Definition then + return; + end if; + declare + Len : constant Natural := Get_File_Signature_Length (Type_Name); + Sig : String (1 .. Len + 2); + Off : Natural := Sig'First; + begin + Get_File_Signature (Type_Name, Sig, Off); + Sig (Len + 1) := '.'; + Sig (Len + 2) := Character'Val (10); + Info := Get_Info (Def); + Info.T.File_Signature := Create_String + (Sig, Create_Identifier ("FILESIG"), Global_Storage); + end; + end Create_File_Type_Var; + + ------------- + -- Array -- + ------------- + + function Type_To_Last_Object_Kind (Def : Iir) return Object_Kind_Type is + begin + if Get_Has_Signal_Flag (Def) then + return Mode_Signal; + else + return Mode_Value; + end if; + end Type_To_Last_Object_Kind; + + procedure Create_Array_Fat_Pointer + (Info : Type_Info_Acc; Kind : Object_Kind_Type) + is + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field + (Constr, Info.T.Base_Field (Kind), Get_Identifier ("BASE"), + Info.T.Base_Ptr_Type (Kind)); + New_Record_Field + (Constr, Info.T.Bounds_Field (Kind), Get_Identifier ("BOUNDS"), + Info.T.Bounds_Ptr_Type); + Finish_Record_Type (Constr, Info.Ortho_Type (Kind)); + end Create_Array_Fat_Pointer; + + procedure Translate_Incomplete_Array_Type + (Def : Iir_Array_Type_Definition) + is + Arr_Info : Incomplete_Type_Info_Acc; + Info : Type_Info_Acc; + begin + Arr_Info := Get_Info (Def); + if Arr_Info.Incomplete_Array /= null then + -- This (incomplete) array type was already translated. + -- This is the case for a second access type definition to this + -- still incomplete array type. + return; + end if; + Info := new Ortho_Info_Type (Kind_Type); + Info.Type_Mode := Type_Mode_Fat_Array; + Info.Type_Incomplete := True; + Arr_Info.Incomplete_Array := Info; + + Info.T := Ortho_Info_Type_Array_Init; + Info.T.Bounds_Type := O_Tnode_Null; + + Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); + New_Type_Decl (Create_Identifier ("BOUNDP"), + Info.T.Bounds_Ptr_Type); + + Info.T.Base_Ptr_Type (Mode_Value) := New_Access_Type (O_Tnode_Null); + New_Type_Decl (Create_Identifier ("BASEP"), + Info.T.Base_Ptr_Type (Mode_Value)); + + Create_Array_Fat_Pointer (Info, Mode_Value); + + New_Type_Decl + (Create_Identifier, Info.Ortho_Type (Mode_Value)); + end Translate_Incomplete_Array_Type; + + -- Declare the bounds types for DEF. + procedure Translate_Array_Type_Bounds + (Def : Iir_Array_Type_Definition; + Info : Type_Info_Acc; + Complete : Boolean) + is + Indexes_List : constant Iir_List := + Get_Index_Subtype_Definition_List (Def); + Constr : O_Element_List; + Dim : String (1 .. 8); + N : Natural; + P : Natural; + Index : Iir; + Index_Info : Index_Info_Acc; + Index_Type_Mark : Iir; + begin + Start_Record_Type (Constr); + for I in Natural loop + Index_Type_Mark := Get_Nth_Element (Indexes_List, I); + exit when Index_Type_Mark = Null_Iir; + Index := Get_Index_Type (Index_Type_Mark); + + -- Index comes from a type mark. + pragma Assert (not Is_Anonymous_Type_Definition (Index)); + + Index_Info := Add_Info (Index_Type_Mark, Kind_Index); + + -- Build the name + N := I + 1; + P := Dim'Last; + loop + Dim (P) := Character'Val (Character'Pos ('0') + N mod 10); + P := P - 1; + N := N / 10; + exit when N = 0; + end loop; + P := P - 3; + Dim (P .. P + 3) := "dim_"; + + New_Record_Field (Constr, Index_Info.Index_Field, + Get_Identifier (Dim (P .. Dim'Last)), + Get_Info (Get_Base_Type (Index)).T.Range_Type); + end loop; + Finish_Record_Type (Constr, Info.T.Bounds_Type); + New_Type_Decl (Create_Identifier ("BOUND"), + Info.T.Bounds_Type); + if Complete then + Finish_Access_Type (Info.T.Bounds_Ptr_Type, Info.T.Bounds_Type); + else + Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); + New_Type_Decl (Create_Identifier ("BOUNDP"), + Info.T.Bounds_Ptr_Type); + end if; + end Translate_Array_Type_Bounds; + + procedure Translate_Array_Type_Base + (Def : Iir_Array_Type_Definition; + Info : Type_Info_Acc; + Complete : Boolean) + is + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + Id, Idptr : O_Ident; + begin + El_Type := Get_Element_Subtype (Def); + Translate_Type_Definition (El_Type, True); + El_Tinfo := Get_Info (El_Type); + + if Is_Complex_Type (El_Tinfo) then + if El_Tinfo.Type_Mode = Type_Mode_Array then + Info.T.Base_Type := El_Tinfo.T.Base_Ptr_Type; + Info.T.Base_Ptr_Type := El_Tinfo.T.Base_Ptr_Type; + else + Info.T.Base_Type := El_Tinfo.Ortho_Ptr_Type; + Info.T.Base_Ptr_Type := El_Tinfo.Ortho_Ptr_Type; + end if; + else + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + case Kind is + when Mode_Value => + -- For the values. + Id := Create_Identifier ("BASE"); + if not Complete then + Idptr := Create_Identifier ("BASEP"); + else + Idptr := O_Ident_Nul; + end if; + when Mode_Signal => + -- For the signals + Id := Create_Identifier ("SIGBASE"); + Idptr := Create_Identifier ("SIGBASEP"); + end case; + Info.T.Base_Type (Kind) := + New_Array_Type (El_Tinfo.Ortho_Type (Kind), + Ghdl_Index_Type); + New_Type_Decl (Id, Info.T.Base_Type (Kind)); + if Is_Equal (Idptr, O_Ident_Nul) then + Finish_Access_Type (Info.T.Base_Ptr_Type (Kind), + Info.T.Base_Type (Kind)); + else + Info.T.Base_Ptr_Type (Kind) := + New_Access_Type (Info.T.Base_Type (Kind)); + New_Type_Decl (Idptr, Info.T.Base_Ptr_Type (Kind)); + end if; + end loop; + end if; + end Translate_Array_Type_Base; + + -- For unidimensional arrays: create a constant bounds whose length + -- is 1, for concatenation with element. + procedure Translate_Static_Unidimensional_Array_Length_One + (Def : Iir_Array_Type_Definition) + is + Indexes : constant Iir_List := Get_Index_Subtype_List (Def); + Index_Type : Iir; + Index_Base_Type : Iir; + Constr : O_Record_Aggr_List; + Constr1 : O_Record_Aggr_List; + Arr_Info : Type_Info_Acc; + Tinfo : Type_Info_Acc; + Irange : Iir; + Res1 : O_Cnode; + Res : O_Cnode; + begin + if Get_Nbr_Elements (Indexes) /= 1 then + -- Not a one-dimensional array. + return; + end if; + Index_Type := Get_Index_Type (Indexes, 0); + Arr_Info := Get_Info (Def); + if Get_Type_Staticness (Index_Type) = Locally then + if Global_Storage /= O_Storage_External then + Index_Base_Type := Get_Base_Type (Index_Type); + Tinfo := Get_Info (Index_Base_Type); + Irange := Get_Range_Constraint (Index_Type); + Start_Record_Aggr (Constr, Arr_Info.T.Bounds_Type); + Start_Record_Aggr (Constr1, Tinfo.T.Range_Type); + New_Record_Aggr_El + (Constr1, + Chap7.Translate_Static_Range_Left (Irange, Index_Base_Type)); + New_Record_Aggr_El + (Constr1, + Chap7.Translate_Static_Range_Left (Irange, Index_Base_Type)); + New_Record_Aggr_El + (Constr1, Chap7.Translate_Static_Range_Dir (Irange)); + New_Record_Aggr_El + (Constr1, Ghdl_Index_1); + Finish_Record_Aggr (Constr1, Res1); + New_Record_Aggr_El (Constr, Res1); + Finish_Record_Aggr (Constr, Res); + else + Res := O_Cnode_Null; + end if; + Arr_Info.T.Array_1bound := Create_Global_Const + (Create_Identifier ("BR1"), + Arr_Info.T.Bounds_Type, Global_Storage, Res); + else + Arr_Info.T.Array_1bound := Create_Var + (Create_Var_Identifier ("BR1"), + Arr_Info.T.Bounds_Type, Global_Storage); + end if; + end Translate_Static_Unidimensional_Array_Length_One; + + procedure Translate_Dynamic_Unidimensional_Array_Length_One + (Def : Iir_Array_Type_Definition) + is + Indexes : constant Iir_List := Get_Index_Subtype_List (Def); + Index_Type : Iir; + Arr_Info : Type_Info_Acc; + Bound1, Rng : Mnode; + begin + if Get_Nbr_Elements (Indexes) /= 1 then + return; + end if; + Index_Type := Get_Index_Type (Indexes, 0); + if Get_Type_Staticness (Index_Type) = Locally then + return; + end if; + Arr_Info := Get_Info (Def); + Open_Temp; + Bound1 := Varv2M (Arr_Info.T.Array_1bound, Arr_Info, Mode_Value, + Arr_Info.T.Bounds_Type, Arr_Info.T.Bounds_Ptr_Type); + Bound1 := Bounds_To_Range (Bound1, Def, 1); + Stabilize (Bound1); + Rng := Type_To_Range (Index_Type); + Stabilize (Rng); + New_Assign_Stmt (M2Lv (Range_To_Dir (Bound1)), + M2E (Range_To_Dir (Rng))); + New_Assign_Stmt (M2Lv (Range_To_Left (Bound1)), + M2E (Range_To_Left (Rng))); + New_Assign_Stmt (M2Lv (Range_To_Right (Bound1)), + M2E (Range_To_Left (Rng))); + New_Assign_Stmt (M2Lv (Range_To_Length (Bound1)), + New_Lit (Ghdl_Index_1)); + Close_Temp; + end Translate_Dynamic_Unidimensional_Array_Length_One; + + procedure Translate_Array_Type_Definition + (Def : Iir_Array_Type_Definition) + is + Info : constant Type_Info_Acc := Get_Info (Def); + -- If true, INFO was already partially filled, by a previous access + -- type definition to this incomplete array type. + Completion : constant Boolean := Info.Type_Mode = Type_Mode_Fat_Array; + El_Tinfo : Type_Info_Acc; + begin + if not Completion then + Info.Type_Mode := Type_Mode_Fat_Array; + Info.T := Ortho_Info_Type_Array_Init; + end if; + Translate_Array_Type_Base (Def, Info, Completion); + Translate_Array_Type_Bounds (Def, Info, Completion); + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + if not Completion then + Create_Array_Fat_Pointer (Info, Mode_Value); + end if; + if Get_Has_Signal_Flag (Def) then + Create_Array_Fat_Pointer (Info, Mode_Signal); + end if; + Finish_Type_Definition (Info, Completion); + + Translate_Static_Unidimensional_Array_Length_One (Def); + + El_Tinfo := Get_Info (Get_Element_Subtype (Def)); + if Is_Complex_Type (El_Tinfo) then + -- This is a complex type. + Info.C := new Complex_Type_Arr_Info; + -- No size variable for unconstrained array type. + for Mode in Object_Kind_Type loop + Info.C (Mode).Size_Var := Null_Var; + Info.C (Mode).Builder_Need_Func := + El_Tinfo.C (Mode).Builder_Need_Func; + end loop; + end if; + Info.Type_Incomplete := False; + end Translate_Array_Type_Definition; + + -- Get the length of DEF, ie the number of elements. + -- If the length is not statically defined, returns -1. + function Get_Array_Subtype_Length (Def : Iir_Array_Subtype_Definition) + return Iir_Int64 + is + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); + Index : Iir; + Len : Iir_Int64; + begin + -- Check if the bounds of the array are locally static. + Len := 1; + for I in Natural loop + Index := Get_Index_Type (Indexes_List, I); + exit when Index = Null_Iir; + + if Get_Type_Staticness (Index) /= Locally then + return -1; + end if; + Len := Len * Eval_Discrete_Type_Length (Index); + end loop; + return Len; + end Get_Array_Subtype_Length; + + procedure Translate_Array_Subtype_Definition + (Def : Iir_Array_Subtype_Definition) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base_Type : constant Iir := Get_Base_Type (Def); + Binfo : constant Type_Info_Acc := Get_Info (Base_Type); + + Len : Iir_Int64; + + Id : O_Ident; + begin + -- Note: info of indexes subtype are not created! + + Len := Get_Array_Subtype_Length (Def); + Info.Type_Mode := Type_Mode_Array; + Info.Type_Locally_Constrained := (Len >= 0); + if Is_Complex_Type (Binfo) + or else not Info.Type_Locally_Constrained + then + -- This is a complex type as the size is not known at compile + -- time. + Info.Ortho_Type := Binfo.T.Base_Ptr_Type; + Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type; + + Create_Size_Var (Def); + + for Mode in Object_Kind_Type loop + Info.C (Mode).Builder_Need_Func := + Is_Complex_Type (Binfo) + and then Binfo.C (Mode).Builder_Need_Func; + end loop; + else + -- Length is known. Create a constrained array. + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + Info.Ortho_Ptr_Type := Binfo.T.Base_Ptr_Type; + for I in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + case I is + when Mode_Value => + Id := Create_Identifier; + when Mode_Signal => + Id := Create_Identifier ("SIG"); + end case; + Info.Ortho_Type (I) := New_Constrained_Array_Type + (Binfo.T.Base_Type (I), + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Len))); + New_Type_Decl (Id, Info.Ortho_Type (I)); + end loop; + end if; + end Translate_Array_Subtype_Definition; + + procedure Translate_Array_Subtype_Element_Subtype + (Def : Iir_Array_Subtype_Definition) + is + El_Type : constant Iir := Get_Element_Subtype (Def); + Type_Mark : constant Iir := Get_Denoted_Type_Mark (Def); + Tm_El_Type : Iir; + begin + if Type_Mark = Null_Iir then + -- Array subtype for constained array definition. Same element + -- subtype as the base type. + return; + end if; + + Tm_El_Type := Get_Element_Subtype (Type_Mark); + if El_Type = Tm_El_Type then + -- Same element subtype as the type mark. + return; + end if; + + case Get_Kind (El_Type) is + when Iir_Kinds_Scalar_Subtype_Definition => + declare + El_Info : Ortho_Info_Acc; + begin + El_Info := Add_Info (El_Type, Kind_Type); + Create_Subtype_Info_From_Type + (El_Type, El_Info, Get_Info (Tm_El_Type)); + end; + when others => + Error_Kind ("translate_array_subtype_element_subtype", El_Type); + end case; + end Translate_Array_Subtype_Element_Subtype; + + function Create_Static_Array_Subtype_Bounds + (Def : Iir_Array_Subtype_Definition) + return O_Cnode + is + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); + Baseinfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Def)); + Index : Iir; + List : O_Record_Aggr_List; + Res : O_Cnode; + begin + Start_Record_Aggr (List, Baseinfo.T.Bounds_Type); + for I in Natural loop + Index := Get_Index_Type (Indexes_List, I); + exit when Index = Null_Iir; + New_Record_Aggr_El + (List, Create_Static_Type_Definition_Type_Range (Index)); + end loop; + Finish_Record_Aggr (List, Res); + return Res; + end Create_Static_Array_Subtype_Bounds; + + procedure Create_Array_Subtype_Bounds + (Def : Iir_Array_Subtype_Definition; Target : O_Lnode) + is + Base_Type : constant Iir := Get_Base_Type (Def); + Baseinfo : constant Type_Info_Acc := Get_Info (Base_Type); + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Def); + Indexes_Def_List : constant Iir_List := + Get_Index_Subtype_Definition_List (Base_Type); + Index : Iir; + Targ : Mnode; + begin + Targ := Lv2M (Target, True, + Baseinfo.T.Bounds_Type, + Baseinfo.T.Bounds_Ptr_Type, + null, Mode_Value); + Open_Temp; + if Get_Nbr_Elements (Indexes_List) > 1 then + Targ := Stabilize (Targ); + end if; + for I in Natural loop + Index := Get_Index_Type (Indexes_List, I); + exit when Index = Null_Iir; + declare + Index_Type : constant Iir := Get_Base_Type (Index); + Index_Info : constant Type_Info_Acc := Get_Info (Index_Type); + Base_Index_Info : constant Index_Info_Acc := + Get_Info (Get_Nth_Element (Indexes_Def_List, I)); + D : O_Dnode; + begin + Open_Temp; + D := Create_Temp_Ptr + (Index_Info.T.Range_Ptr_Type, + New_Selected_Element (M2Lv (Targ), + Base_Index_Info.Index_Field)); + Chap7.Translate_Discrete_Range_Ptr (D, Index); + Close_Temp; + end; + end loop; + Close_Temp; + end Create_Array_Subtype_Bounds; + + -- Get staticness of the array bounds. + function Get_Array_Bounds_Staticness (Def : Iir) return Iir_Staticness + is + List : constant Iir_List := Get_Index_Subtype_List (Def); + Idx_Type : Iir; + begin + for I in Natural loop + Idx_Type := Get_Index_Type (List, I); + exit when Idx_Type = Null_Iir; + if Get_Type_Staticness (Idx_Type) /= Locally then + return Globally; + end if; + end loop; + return Locally; + end Get_Array_Bounds_Staticness; + + -- Create a variable containing the bounds for array subtype DEF. + procedure Create_Array_Subtype_Bounds_Var + (Def : Iir; Elab_Now : Boolean) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base_Info : Type_Info_Acc; + Val : O_Cnode; + begin + if Info.T.Array_Bounds /= Null_Var then + return; + end if; + Base_Info := Get_Info (Get_Base_Type (Def)); + case Get_Array_Bounds_Staticness (Def) is + when None + | Globally => + Info.T.Static_Bounds := False; + Info.T.Array_Bounds := Create_Var + (Create_Var_Identifier ("STB"), Base_Info.T.Bounds_Type); + if Elab_Now then + Create_Array_Subtype_Bounds + (Def, Get_Var (Info.T.Array_Bounds)); + end if; + when Locally => + Info.T.Static_Bounds := True; + if Global_Storage = O_Storage_External then + -- Do not create the value of the type desc, since it + -- is never dereferenced in a static type desc. + Val := O_Cnode_Null; + else + Val := Create_Static_Array_Subtype_Bounds (Def); + end if; + Info.T.Array_Bounds := Create_Global_Const + (Create_Identifier ("STB"), + Base_Info.T.Bounds_Type, Global_Storage, Val); + + when Unknown => + raise Internal_Error; + end case; + end Create_Array_Subtype_Bounds_Var; + + procedure Create_Array_Type_Builder + (Def : Iir_Array_Type_Definition; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param; + Bound : constant O_Dnode := Info.C (Kind).Builder_Bound_Param; + Var_Off : O_Dnode; + Var_Mem : O_Dnode; + Var_Length : O_Dnode; + El_Type : Iir; + El_Info : Type_Info_Acc; + Label : O_Snode; + begin + Start_Subprogram_Body (Info.C (Kind).Builder_Func); + Chap2.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + + -- Compute length of the array. + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_Mem, Get_Identifier ("mem"), O_Storage_Local, + Info.T.Base_Ptr_Type (Kind)); + New_Var_Decl (Var_Off, Get_Identifier ("off"), O_Storage_Local, + Ghdl_Index_Type); + + El_Type := Get_Element_Subtype (Def); + El_Info := Get_Info (El_Type); + + New_Assign_Stmt + (New_Obj (Var_Length), + New_Dyadic_Op (ON_Mul_Ov, + New_Value (Get_Var (El_Info.C (Kind).Size_Var)), + Get_Bounds_Length (Dp2M (Bound, Info, + Mode_Value, + Info.T.Bounds_Type, + Info.T.Bounds_Ptr_Type), + Def))); + + -- Find the innermost non-array element. + while El_Info.Type_Mode = Type_Mode_Array loop + El_Type := Get_Element_Subtype (El_Type); + El_Info := Get_Info (El_Type); + end loop; + + -- Set each index of the array. + Init_Var (Var_Off); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Off), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + + New_Assign_Stmt + (New_Obj (Var_Mem), + New_Unchecked_Address + (New_Slice (New_Access_Element + (New_Convert_Ov (New_Obj_Value (Base), + Char_Ptr_Type)), + Chararray_Type, + New_Obj_Value (Var_Off)), + Info.T.Base_Ptr_Type (Kind))); + + New_Assign_Stmt + (New_Obj (Var_Off), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Off), + Gen_Call_Type_Builder (Var_Mem, El_Type, Kind))); + Finish_Loop_Stmt (Label); + + New_Return_Stmt (New_Obj_Value (Var_Off)); + + Chap2.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + Finish_Subprogram_Body; + end Create_Array_Type_Builder; + + -------------- + -- record -- + -------------- + + -- Get the alignment mask for *ortho* type ATYPE. + function Get_Type_Alignmask (Atype : O_Tnode) return O_Enode is + begin + return New_Dyadic_Op + (ON_Sub_Ov, + New_Lit (New_Alignof (Atype, Ghdl_Index_Type)), + New_Lit (Ghdl_Index_1)); + end Get_Type_Alignmask; + + -- Get the alignment mask for type INFO (Mode_Value). + function Get_Type_Alignmask (Info : Type_Info_Acc) return O_Enode is + begin + if Is_Complex_Type (Info) then + if Info.Type_Mode /= Type_Mode_Record then + raise Internal_Error; + end if; + return New_Value (Get_Var (Info.C (Mode_Value).Align_Var)); + else + return Get_Type_Alignmask (Info.Ortho_Type (Mode_Value)); + end if; + end Get_Type_Alignmask; + + -- Align VALUE (of unsigned type) for type ATYPE. + -- The formulae is: (V + (A - 1)) and not (A - 1), where A is the + -- alignment for ATYPE in bytes. + function Realign (Value : O_Enode; Atype : Iir) return O_Enode + is + Tinfo : constant Type_Info_Acc := Get_Info (Atype); + begin + return New_Dyadic_Op + (ON_And, + New_Dyadic_Op (ON_Add_Ov, Value, Get_Type_Alignmask (Tinfo)), + New_Monadic_Op (ON_Not, Get_Type_Alignmask (Tinfo))); + end Realign; + + function Realign (Value : O_Enode; Mask : O_Dnode) return O_Enode is + begin + return New_Dyadic_Op + (ON_And, + New_Dyadic_Op (ON_Add_Ov, Value, New_Obj_Value (Mask)), + New_Monadic_Op (ON_Not, New_Obj_Value (Mask))); + end Realign; + + -- Find the innermost non-array element. + function Get_Innermost_Non_Array_Element (Atype : Iir) return Iir + is + Res : Iir := Atype; + begin + while Get_Kind (Res) in Iir_Kinds_Array_Type_Definition loop + Res := Get_Element_Subtype (Res); + end loop; + return Res; + end Get_Innermost_Non_Array_Element; + + procedure Translate_Record_Type (Def : Iir_Record_Type_Definition) + is + El_List : O_Element_List; + List : Iir_List; + El : Iir_Element_Declaration; + Info : Type_Info_Acc; + Field_Info : Ortho_Info_Acc; + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + El_Tnode : O_Tnode; + + -- True if a size variable will be created since the size of + -- the record is not known at compile-time. + Need_Size : Boolean; + + Mark : Id_Mark_Type; + begin + Info := Get_Info (Def); + Need_Size := False; + List := Get_Elements_Declaration_List (Def); + + -- First, translate the anonymous type of the elements. + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El_Type := Get_Type (El); + if Get_Info (El_Type) = null then + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + Translate_Type_Definition (El_Type); + Pop_Identifier_Prefix (Mark); + end if; + if not Need_Size and then Is_Complex_Type (Get_Info (El_Type)) then + Need_Size := True; + end if; + Field_Info := Add_Info (El, Kind_Field); + end loop; + + -- Then create the record type. + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + Start_Record_Type (El_List); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Field_Info := Get_Info (El); + El_Tinfo := Get_Info (Get_Type (El)); + if Is_Complex_Type (El_Tinfo) then + -- Always use an offset for a complex type. + El_Tnode := Ghdl_Index_Type; + else + El_Tnode := El_Tinfo.Ortho_Type (Kind); + end if; + + New_Record_Field (El_List, Field_Info.Field_Node (Kind), + Create_Identifier_Without_Prefix (El), + El_Tnode); + end loop; + Finish_Record_Type (El_List, Info.Ortho_Type (Kind)); + end loop; + Info.Type_Mode := Type_Mode_Record; + Finish_Type_Definition (Info); + + if Need_Size then + Create_Size_Var (Def); + Info.C (Mode_Value).Align_Var := Create_Var + (Create_Var_Identifier ("ALIGNMSK"), Ghdl_Index_Type); + Info.C (Mode_Value).Builder_Need_Func := True; + Info.C (Mode_Signal).Builder_Need_Func := True; + end if; + end Translate_Record_Type; + + procedure Create_Record_Type_Builder + (Def : Iir_Record_Type_Definition; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param; + List : Iir_List; + El : Iir_Element_Declaration; + + Off_Var : O_Dnode; + Ptr_Var : O_Dnode; + Off_Val : O_Enode; + El_Type : Iir; + Inner_Type : Iir; + El_Tinfo : Type_Info_Acc; + begin + Start_Subprogram_Body (Info.C (Kind).Builder_Func); + Chap2.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + + New_Var_Decl (Off_Var, Get_Identifier ("off"), O_Storage_Local, + Ghdl_Index_Type); + + -- Reserve memory for the record, ie: + -- OFF = SIZEOF (record). + New_Assign_Stmt + (New_Obj (Off_Var), + New_Lit (New_Sizeof (Info.Ortho_Type (Kind), + Ghdl_Index_Type))); + + -- Set memory for each complex element. + List := Get_Elements_Declaration_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El_Type := Get_Type (El); + El_Tinfo := Get_Info (El_Type); + if Is_Complex_Type (El_Tinfo) then + -- Complex type. + + -- Align on the innermost array element (which should be + -- a record) for Mode_Value. No need to align for signals, + -- as all non-composite elements are accesses. + Inner_Type := Get_Innermost_Non_Array_Element (El_Type); + Off_Val := New_Obj_Value (Off_Var); + if Kind = Mode_Value then + Off_Val := Realign (Off_Val, Inner_Type); + end if; + New_Assign_Stmt (New_Obj (Off_Var), Off_Val); + + -- Set the offset. + New_Assign_Stmt + (New_Selected_Element (New_Acc_Value (New_Obj (Base)), + Get_Info (El).Field_Node (Kind)), + New_Obj_Value (Off_Var)); + + if El_Tinfo.C (Kind).Builder_Need_Func then + -- This type needs a builder, call it. + Start_Declare_Stmt; + New_Var_Decl + (Ptr_Var, Get_Identifier ("var_ptr"), + O_Storage_Local, El_Tinfo.Ortho_Ptr_Type (Kind)); + + New_Assign_Stmt + (New_Obj (Ptr_Var), + M2E (Chap6.Translate_Selected_Element + (Dp2M (Base, Info, Kind), El))); + + New_Assign_Stmt + (New_Obj (Off_Var), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Off_Var), + Gen_Call_Type_Builder + (Ptr_Var, El_Type, Kind))); + + Finish_Declare_Stmt; + else + -- Allocate memory. + New_Assign_Stmt + (New_Obj (Off_Var), + New_Dyadic_Op + (ON_Add_Ov, + New_Obj_Value (Off_Var), + New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var)))); + end if; + end if; + end loop; + New_Return_Stmt (New_Value (Get_Var (Info.C (Kind).Size_Var))); + Chap2.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance); + Finish_Subprogram_Body; + end Create_Record_Type_Builder; + + -------------- + -- Access -- + -------------- + procedure Translate_Access_Type (Def : Iir_Access_Type_Definition) + is + D_Type : constant Iir := Get_Designated_Type (Def); + D_Info : constant Ortho_Info_Acc := Get_Info (D_Type); + Def_Info : constant Type_Info_Acc := Get_Info (Def); + Dtype : O_Tnode; + Arr_Info : Type_Info_Acc; + begin + if not Is_Fully_Constrained_Type (D_Type) then + -- An access type to an unconstrained type definition is a fat + -- pointer. + Def_Info.Type_Mode := Type_Mode_Fat_Acc; + if D_Info.Kind = Kind_Incomplete_Type then + Translate_Incomplete_Array_Type (D_Type); + Arr_Info := D_Info.Incomplete_Array; + Def_Info.Ortho_Type := Arr_Info.Ortho_Type; + Def_Info.T := Arr_Info.T; + else + Def_Info.Ortho_Type := D_Info.Ortho_Type; + Def_Info.T := D_Info.T; + end if; + Def_Info.Ortho_Ptr_Type (Mode_Value) := + New_Access_Type (Def_Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier ("PTR"), + Def_Info.Ortho_Ptr_Type (Mode_Value)); + else + -- Otherwise, it is a thin pointer. + Def_Info.Type_Mode := Type_Mode_Acc; + -- No access types for signals. + Def_Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + + if D_Info.Kind = Kind_Incomplete_Type then + Dtype := O_Tnode_Null; + elsif Is_Complex_Type (D_Info) then + -- FIXME: clean here when the ortho_type of a array + -- complex_type is correctly set (not a pointer). + Def_Info.Ortho_Type (Mode_Value) := + D_Info.Ortho_Ptr_Type (Mode_Value); + Finish_Type_Definition (Def_Info, True); + return; + elsif D_Info.Type_Mode in Type_Mode_Arrays then + -- The designated type cannot be a sub array inside ortho. + -- FIXME: lift this restriction. + Dtype := D_Info.T.Base_Type (Mode_Value); + else + Dtype := D_Info.Ortho_Type (Mode_Value); + end if; + Def_Info.Ortho_Type (Mode_Value) := New_Access_Type (Dtype); + Finish_Type_Definition (Def_Info); + end if; + end Translate_Access_Type; + + ------------------------ + -- Incomplete types -- + ------------------------ + procedure Translate_Incomplete_Type (Def : Iir) + is +-- Ftype : Iir; +-- Info : Type_Info_Acc; + Info : Incomplete_Type_Info_Acc; + Ctype : Iir; + begin + if Get_Nbr_Elements (Get_Incomplete_Type_List (Def)) = 0 then + -- FIXME: + -- This is a work-around for dummy incomplete type (ie incomplete + -- types not used before the full type declaration). + return; + end if; + Ctype := Get_Type (Get_Type_Declarator (Def)); + Info := Add_Info (Ctype, Kind_Incomplete_Type); + Info.Incomplete_Type := Def; + Info.Incomplete_Array := null; + end Translate_Incomplete_Type; + + -- CTYPE is the type which has been completed. + procedure Translate_Complete_Type + (Incomplete_Info : in out Incomplete_Type_Info_Acc; Ctype : Iir) + is + List : Iir_List; + Atype : Iir; + Def_Info : Type_Info_Acc; + C_Info : Type_Info_Acc; + Dtype : O_Tnode; + begin + C_Info := Get_Info (Ctype); + List := Get_Incomplete_Type_List (Incomplete_Info.Incomplete_Type); + for I in Natural loop + Atype := Get_Nth_Element (List, I); + exit when Atype = Null_Iir; + if Get_Kind (Atype) /= Iir_Kind_Access_Type_Definition then + raise Internal_Error; + end if; + Def_Info := Get_Info (Atype); + case C_Info.Type_Mode is + when Type_Mode_Arrays => + Dtype := C_Info.T.Base_Type (Mode_Value); + when others => + Dtype := C_Info.Ortho_Type (Mode_Value); + end case; + Finish_Access_Type (Def_Info.Ortho_Type (Mode_Value), Dtype); + end loop; + Unchecked_Deallocation (Incomplete_Info); + end Translate_Complete_Type; + + ----------------- + -- protected -- + ----------------- + + procedure Translate_Protected_Type (Def : Iir_Protected_Type_Declaration) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Mark : Id_Mark_Type; + begin + New_Uncomplete_Record_Type (Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier, Info.Ortho_Type (Mode_Value)); + + Info.Ortho_Ptr_Type (Mode_Value) := + New_Access_Type (Info.Ortho_Type (Mode_Value)); + New_Type_Decl (Create_Identifier ("PTR"), + Info.Ortho_Ptr_Type (Mode_Value)); + + Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + Info.Ortho_Ptr_Type (Mode_Signal) := O_Tnode_Null; + + Info.Type_Mode := Type_Mode_Protected; + + -- A protected type is a complex type, as its size is not known + -- at definition point (will be known at body declaration). + Info.C := new Complex_Type_Arr_Info; + Info.C (Mode_Value).Builder_Need_Func := False; + + -- This is just use to set overload number on subprograms, and to + -- translate interfaces. + Push_Identifier_Prefix + (Mark, Get_Identifier (Get_Type_Declarator (Def))); + Chap4.Translate_Declaration_Chain (Def); + Pop_Identifier_Prefix (Mark); + end Translate_Protected_Type; + + procedure Translate_Protected_Type_Subprograms + (Def : Iir_Protected_Type_Declaration) + is + Info : constant Type_Info_Acc := Get_Info (Def); + El : Iir; + Inter_List : O_Inter_List; + Mark : Id_Mark_Type; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Push_Identifier_Prefix + (Mark, Get_Identifier (Get_Type_Declarator (Def))); + + -- Init. + Start_Function_Decl + (Inter_List, Create_Identifier ("INIT"), Global_Storage, + Info.Ortho_Ptr_Type (Mode_Value)); + Chap2.Add_Subprg_Instance_Interfaces + (Inter_List, Info.T.Prot_Init_Instance); + Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Init_Subprg); + + -- Use the object as instance. + Chap2.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, + Info.Ortho_Ptr_Type (Mode_Value), + Wki_Obj, + Prev_Subprg_Instance); + + -- Final. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("FINI"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Inter_List, Info.T.Prot_Final_Instance); + Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Final_Subprg); + + -- Methods. + El := Get_Declaration_Chain (Def); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- Translate only if used. + if Get_Info (El) /= null then + Chap2.Translate_Subprogram_Declaration (El); + end if; + when others => + Error_Kind ("translate_protected_type_subprograms", El); + end case; + El := Get_Chain (El); + end loop; + + Chap2.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance); + + Pop_Identifier_Prefix (Mark); + end Translate_Protected_Type_Subprograms; + + procedure Translate_Protected_Type_Body (Bod : Iir) + is + Decl : constant Iir_Protected_Type_Declaration := + Get_Protected_Type_Declaration (Bod); + Info : constant Type_Info_Acc := Get_Info (Decl); + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); + + -- Create the object type + Push_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access); + -- First, the previous instance. + Chap2.Add_Subprg_Instance_Field (Info.T.Prot_Subprg_Instance_Field); + -- Then the object lock + Info.T.Prot_Lock_Field := Add_Instance_Factory_Field + (Get_Identifier ("LOCK"), Ghdl_Ptr_Type); + + -- Translate declarations. + Chap4.Translate_Declaration_Chain (Bod); + + Pop_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access); + Info.Ortho_Type (Mode_Value) := Get_Scope_Type (Info.T.Prot_Scope); + + Pop_Identifier_Prefix (Mark); + end Translate_Protected_Type_Body; + + procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode) + is + Info : constant Type_Info_Acc := Get_Info (Type_Def); + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Proc); + New_Association + (Assoc, + New_Unchecked_Address + (New_Selected_Element + (Get_Instance_Ref (Info.T.Prot_Scope), + Info.T.Prot_Lock_Field), + Ghdl_Ptr_Type)); + New_Procedure_Call (Assoc); + end Call_Ghdl_Protected_Procedure; + + procedure Translate_Protected_Type_Body_Subprograms (Bod : Iir) + is + Mark : Id_Mark_Type; + Decl : constant Iir := Get_Protected_Type_Declaration (Bod); + Info : constant Type_Info_Acc := Get_Info (Decl); + Final : Boolean; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); + + -- Subprograms of BOD. + Chap2.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, + Info.Ortho_Ptr_Type (Mode_Value), + Wki_Obj, + Prev_Subprg_Instance); + Chap2.Start_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); + + Chap4.Translate_Declaration_Chain_Subprograms (Bod); + + Chap2.Finish_Prev_Subprg_Instance_Use_Via_Field + (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); + Chap2.Pop_Subprg_Instance (Wki_Obj, Prev_Subprg_Instance); + + Pop_Identifier_Prefix (Mark); + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Init subprogram + declare + Var_Obj : O_Dnode; + begin + Start_Subprogram_Body (Info.T.Prot_Init_Subprg); + Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Init_Instance); + New_Var_Decl (Var_Obj, Wki_Obj, O_Storage_Local, + Info.Ortho_Ptr_Type (Mode_Value)); + + -- Allocate the object + New_Assign_Stmt + (New_Obj (Var_Obj), + Gen_Alloc (Alloc_System, + New_Lit (New_Sizeof (Info.Ortho_Type (Mode_Value), + Ghdl_Index_Type)), + Info.Ortho_Ptr_Type (Mode_Value))); + + Chap2.Set_Subprg_Instance_Field + (Var_Obj, Info.T.Prot_Subprg_Instance_Field, + Info.T.Prot_Init_Instance); + + Set_Scope_Via_Param_Ptr (Info.T.Prot_Scope, Var_Obj); + + -- Create lock. + Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Init); + + -- Elaborate fields. + Open_Temp; + Chap4.Elab_Declaration_Chain (Bod, Final); + Close_Temp; + + Clear_Scope (Info.T.Prot_Scope); + + New_Return_Stmt (New_Obj_Value (Var_Obj)); + Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Init_Instance); + + Finish_Subprogram_Body; + end; + + -- Fini subprogram + begin + Start_Subprogram_Body (Info.T.Prot_Final_Subprg); + Chap2.Start_Subprg_Instance_Use (Info.T.Prot_Final_Instance); + + -- Deallocate fields. + if Final or True then + Chap4.Final_Declaration_Chain (Bod, True); + end if; + + -- Destroy lock. + Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Fini); + + Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Final_Instance); + Finish_Subprogram_Body; + end; + end Translate_Protected_Type_Body_Subprograms; + + --------------- + -- Scalars -- + --------------- + + -- Create a type_range structure. + procedure Create_Scalar_Type_Range (Def : Iir; Target : O_Lnode) + is + T_Info : Type_Info_Acc; + Base_Type : Iir; + Expr : Iir; + V : O_Dnode; + begin + Base_Type := Get_Base_Type (Def); + T_Info := Get_Info (Base_Type); + Expr := Get_Range_Constraint (Def); + Open_Temp; + V := Create_Temp_Ptr (T_Info.T.Range_Ptr_Type, Target); + Chap7.Translate_Range_Ptr (V, Expr, Def); + Close_Temp; + end Create_Scalar_Type_Range; + + function Create_Static_Scalar_Type_Range (Def : Iir) return O_Cnode is + begin + return Chap7.Translate_Static_Range (Get_Range_Constraint (Def), + Get_Base_Type (Def)); + end Create_Static_Scalar_Type_Range; + + procedure Create_Scalar_Type_Range_Type + (Def : Iir; With_Length : Boolean) + is + Constr : O_Element_List; + Info : Ortho_Info_Acc; + begin + Info := Get_Info (Def); + Start_Record_Type (Constr); + New_Record_Field + (Constr, Info.T.Range_Left, Wki_Left, + Info.Ortho_Type (Mode_Value)); + New_Record_Field + (Constr, Info.T.Range_Right, Wki_Right, + Info.Ortho_Type (Mode_Value)); + New_Record_Field + (Constr, Info.T.Range_Dir, Wki_Dir, Ghdl_Dir_Type_Node); + if With_Length then + New_Record_Field + (Constr, Info.T.Range_Length, Wki_Length, Ghdl_Index_Type); + else + Info.T.Range_Length := O_Fnode_Null; + end if; + Finish_Record_Type (Constr, Info.T.Range_Type); + New_Type_Decl (Create_Identifier ("TRT"), Info.T.Range_Type); + Info.T.Range_Ptr_Type := New_Access_Type (Info.T.Range_Type); + New_Type_Decl (Create_Identifier ("TRPTR"), + Info.T.Range_Ptr_Type); + end Create_Scalar_Type_Range_Type; + + function Create_Static_Type_Definition_Type_Range (Def : Iir) + return O_Cnode + is + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kinds_Scalar_Subtype_Definition => + return Create_Static_Scalar_Type_Range (Def); + + when Iir_Kind_Array_Subtype_Definition => + return Create_Static_Array_Subtype_Bounds (Def); + + when Iir_Kind_Array_Type_Definition => + return O_Cnode_Null; + + when others => + Error_Kind ("create_static_type_definition_type_range", Def); + end case; + end Create_Static_Type_Definition_Type_Range; + + procedure Create_Type_Definition_Type_Range (Def : Iir) + is + Target : O_Lnode; + Info : Type_Info_Acc; + begin + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kinds_Scalar_Subtype_Definition => + Target := Get_Var (Get_Info (Def).T.Range_Var); + Create_Scalar_Type_Range (Def, Target); + + when Iir_Kind_Array_Subtype_Definition => + if Get_Constraint_State (Def) = Fully_Constrained then + Info := Get_Info (Def); + if not Info.T.Static_Bounds then + Target := Get_Var (Info.T.Array_Bounds); + Create_Array_Subtype_Bounds (Def, Target); + end if; + end if; + + when Iir_Kind_Array_Type_Definition => + declare + Index_List : constant Iir_List := + Get_Index_Subtype_List (Def); + Index : Iir; + begin + for I in Natural loop + Index := Get_Index_Type (Index_List, I); + exit when Index = Null_Iir; + if Is_Anonymous_Type_Definition (Index) then + Create_Type_Definition_Type_Range (Index); + end if; + end loop; + end; + Translate_Dynamic_Unidimensional_Array_Length_One (Def); + return; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition + | Iir_Kind_File_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Protected_Type_Declaration => + return; + + when others => + Error_Kind ("create_type_definition_type_range", Def); + end case; + end Create_Type_Definition_Type_Range; + + -- Return TRUE iff LIT is equal to the high (IS_HI=TRUE) or low + -- (IS_HI=false) limit of the base type of DEF. MODE is the mode of + -- DEF. + function Is_Equal_Limit (Lit : Iir; + Is_Hi : Boolean; + Def : Iir; + Mode : Type_Mode_Type) return Boolean + is + begin + case Mode is + when Type_Mode_B1 => + declare + V : Iir_Int32; + begin + V := Iir_Int32 (Eval_Pos (Lit)); + if Is_Hi then + return V = 1; + else + return V = 0; + end if; + end; + when Type_Mode_E8 => + declare + V : Iir_Int32; + Base_Type : Iir; + begin + V := Iir_Int32 (Eval_Pos (Lit)); + if Is_Hi then + Base_Type := Get_Base_Type (Def); + return V = Iir_Int32 + (Get_Nbr_Elements + (Get_Enumeration_Literal_List (Base_Type))) - 1; + else + return V = 0; + end if; + end; + when Type_Mode_I32 => + declare + V : Iir_Int32; + begin + V := Iir_Int32 (Get_Value (Lit)); + if Is_Hi then + return V = Iir_Int32'Last; + else + return V = Iir_Int32'First; + end if; + end; + when Type_Mode_P32 => + declare + V : Iir_Int32; + begin + V := Iir_Int32 (Get_Physical_Value (Lit)); + if Is_Hi then + return V = Iir_Int32'Last; + else + return V = Iir_Int32'First; + end if; + end; + when Type_Mode_I64 => + declare + V : Iir_Int64; + begin + V := Get_Value (Lit); + if Is_Hi then + return V = Iir_Int64'Last; + else + return V = Iir_Int64'First; + end if; + end; + when Type_Mode_P64 => + declare + V : Iir_Int64; + begin + V := Get_Physical_Value (Lit); + if Is_Hi then + return V = Iir_Int64'Last; + else + return V = Iir_Int64'First; + end if; + end; + when Type_Mode_F64 => + declare + V : Iir_Fp64; + begin + V := Get_Fp_Value (Lit); + if Is_Hi then + return V = Iir_Fp64'Last; + else + return V = Iir_Fp64'First; + end if; + end; + when others => + Error_Kind ("is_equal_limit " & Type_Mode_Type'Image (Mode), + Lit); + end case; + end Is_Equal_Limit; + + -- For scalar subtypes: creates info from the base type. + procedure Create_Subtype_Info_From_Type (Def : Iir; + Subtype_Info : Type_Info_Acc; + Base_Info : Type_Info_Acc) + is + Rng : Iir; + Lo, Hi : Iir; + begin + Subtype_Info.Ortho_Type := Base_Info.Ortho_Type; + Subtype_Info.Ortho_Ptr_Type := Base_Info.Ortho_Ptr_Type; + Subtype_Info.Type_Mode := Base_Info.Type_Mode; + Subtype_Info.T := Base_Info.T; + + Rng := Get_Range_Constraint (Def); + if Get_Expr_Staticness (Rng) /= Locally then + -- Bounds are not known. + -- Do the checks. + Subtype_Info.T.Nocheck_Hi := False; + Subtype_Info.T.Nocheck_Low := False; + else + -- Bounds are locally static. + Get_Low_High_Limit (Rng, Lo, Hi); + Subtype_Info.T.Nocheck_Hi := + Is_Equal_Limit (Hi, True, Def, Base_Info.Type_Mode); + Subtype_Info.T.Nocheck_Low := + Is_Equal_Limit (Lo, False, Def, Base_Info.Type_Mode); + end if; + end Create_Subtype_Info_From_Type; + + procedure Create_Record_Size_Var (Def : Iir; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + List : constant Iir_List := + Get_Elements_Declaration_List (Get_Base_Type (Def)); + El : Iir_Element_Declaration; + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + Inner_Type : Iir; + Inner_Tinfo : Type_Info_Acc; + Res : O_Enode; + Align_Var : O_Dnode; + If_Blk : O_If_Block; + begin + Open_Temp; + + -- Start with the size of the 'base' record, that + -- contains all non-complex types and an offset for + -- each complex types. + Res := New_Lit (New_Sizeof (Info.Ortho_Type (Kind), Ghdl_Index_Type)); + + -- Start with alignment of the record. + -- ALIGN = ALIGNOF (record) + if Kind = Mode_Value then + Align_Var := Create_Temp (Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Align_Var), + Get_Type_Alignmask (Info.Ortho_Type (Kind))); + end if; + + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + El_Type := Get_Type (El); + El_Tinfo := Get_Info (El_Type); + if Is_Complex_Type (El_Tinfo) then + Inner_Type := Get_Innermost_Non_Array_Element (El_Type); + + -- Align (only for Mode_Value) the size, + -- and add the size of the element. + if Kind = Mode_Value then + Inner_Tinfo := Get_Info (Inner_Type); + -- If alignmask (Inner_Type) > alignmask then + -- alignmask = alignmask (Inner_type); + -- end if; + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Gt, + Get_Type_Alignmask (Inner_Tinfo), + New_Obj_Value (Align_Var), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Align_Var), Get_Type_Alignmask (Inner_Tinfo)); + Finish_If_Stmt (If_Blk); + Res := Realign (Res, Inner_Type); + end if; + Res := New_Dyadic_Op + (ON_Add_Ov, + New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var)), + Res); + end if; + end loop; + if Kind = Mode_Value then + Res := Realign (Res, Align_Var); + end if; + New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res); + Close_Temp; + end Create_Record_Size_Var; + + procedure Create_Array_Size_Var (Def : Iir; Kind : Object_Kind_Type) + is + Info : constant Type_Info_Acc := Get_Info (Def); + El_Type : constant Iir := Get_Element_Subtype (Def); + Res : O_Enode; + begin + Res := New_Dyadic_Op + (ON_Mul_Ov, + Get_Array_Type_Length (Def), + Chap3.Get_Object_Size (T2M (El_Type, Kind), El_Type)); + New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res); + end Create_Array_Size_Var; + + procedure Create_Type_Definition_Size_Var (Def : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Def); + begin + if not Is_Complex_Type (Info) then + return; + end if; + + for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop + if Info.C (Kind).Size_Var /= Null_Var then + case Info.Type_Mode is + when Type_Mode_Non_Composite + | Type_Mode_Fat_Array + | Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + when Type_Mode_Record => + Create_Record_Size_Var (Def, Kind); + when Type_Mode_Array => + Create_Array_Size_Var (Def, Kind); + end case; + end if; + end loop; + end Create_Type_Definition_Size_Var; + + procedure Create_Type_Range_Var (Def : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Def); + Base_Info : Type_Info_Acc; + Val : O_Cnode; + Suffix : String (1 .. 3) := "xTR"; + begin + case Get_Kind (Def) is + when Iir_Kinds_Subtype_Definition => + Suffix (1) := 'S'; -- "STR"; + when Iir_Kind_Enumeration_Type_Definition => + Suffix (1) := 'B'; -- "BTR"; + when others => + raise Internal_Error; + end case; + Base_Info := Get_Info (Get_Base_Type (Def)); + case Get_Type_Staticness (Def) is + when None + | Globally => + Info.T.Range_Var := Create_Var + (Create_Var_Identifier (Suffix), Base_Info.T.Range_Type); + when Locally => + if Global_Storage = O_Storage_External then + -- Do not create the value of the type desc, since it + -- is never dereferenced in a static type desc. + Val := O_Cnode_Null; + else + Val := Create_Static_Type_Definition_Type_Range (Def); + end if; + Info.T.Range_Var := Create_Global_Const + (Create_Identifier (Suffix), + Base_Info.T.Range_Type, Global_Storage, Val); + when Unknown => + raise Internal_Error; + end case; + end Create_Type_Range_Var; + + + -- Call HANDLE_A_SUBTYPE for all type/subtypes declared with DEF + -- (of course, this is a noop if DEF is not a composite type). + generic + with procedure Handle_A_Subtype (Atype : Iir); + procedure Handle_Anonymous_Subtypes (Def : Iir); + + procedure Handle_Anonymous_Subtypes (Def : Iir) is + begin + case Get_Kind (Def) is + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Array_Subtype_Definition => + declare + Asub : Iir; + begin + Asub := Get_Element_Subtype (Def); + if Is_Anonymous_Type_Definition (Asub) then + Handle_A_Subtype (Asub); + end if; + end; + when Iir_Kind_Record_Type_Definition => + declare + El : Iir; + Asub : Iir; + List : Iir_List; + begin + List := Get_Elements_Declaration_List (Def); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Asub := Get_Type (El); + if Is_Anonymous_Type_Definition (Asub) then + Handle_A_Subtype (Asub); + end if; + end loop; + end; + when others => + null; + end case; + end Handle_Anonymous_Subtypes; + + -- Note: boolean types are translated by translate_bool_type_definition! + procedure Translate_Type_Definition + (Def : Iir; With_Vars : Boolean := True) + is + Info : Ortho_Info_Acc; + Base_Info : Type_Info_Acc; + Base_Type : Iir; + Complete_Info : Incomplete_Type_Info_Acc; + begin + -- Handle the special case of incomplete type. + if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then + Translate_Incomplete_Type (Def); + return; + end if; + + -- If the definition is already translated, return now. + Info := Get_Info (Def); + if Info /= null then + if Info.Kind = Kind_Type then + -- The subtype was already translated. + return; + end if; + if Info.Kind = Kind_Incomplete_Type then + -- Type is being completed. + Complete_Info := Info; + Clear_Info (Def); + if Complete_Info.Incomplete_Array /= null then + Info := Complete_Info.Incomplete_Array; + Set_Info (Def, Info); + Unchecked_Deallocation (Complete_Info); + else + Info := Add_Info (Def, Kind_Type); + end if; + else + raise Internal_Error; + end if; + else + Complete_Info := null; + Info := Add_Info (Def, Kind_Type); + end if; + + Base_Type := Get_Base_Type (Def); + Base_Info := Get_Info (Base_Type); + + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition => + Translate_Enumeration_Type (Def); + Create_Scalar_Type_Range_Type (Def, True); + Create_Type_Range_Var (Def); + --Create_Type_Desc_Var (Def); + + when Iir_Kind_Integer_Type_Definition => + Translate_Integer_Type (Def); + Create_Scalar_Type_Range_Type (Def, True); + + when Iir_Kind_Physical_Type_Definition => + Translate_Physical_Type (Def); + Create_Scalar_Type_Range_Type (Def, False); + if With_Vars and Get_Type_Staticness (Def) /= Locally then + Translate_Physical_Units (Def); + else + Info.T.Range_Var := Null_Var; + end if; + + when Iir_Kind_Floating_Type_Definition => + Translate_Floating_Type (Def); + Create_Scalar_Type_Range_Type (Def, False); + + when Iir_Kinds_Scalar_Subtype_Definition => + Create_Subtype_Info_From_Type (Def, Info, Base_Info); + if With_Vars then + Create_Type_Range_Var (Def); + else + Info.T.Range_Var := Null_Var; + end if; + + when Iir_Kind_Array_Type_Definition => + declare + El_Type : Iir; + Mark : Id_Mark_Type; + begin + El_Type := Get_Element_Subtype (Def); + if Get_Info (El_Type) = null then + Push_Identifier_Prefix (Mark, "ET"); + Translate_Type_Definition (El_Type); + Pop_Identifier_Prefix (Mark); + end if; + end; + Translate_Array_Type_Definition (Def); + + when Iir_Kind_Array_Subtype_Definition => + if Get_Index_Constraint_Flag (Def) then + if Base_Info = null or else Base_Info.Type_Incomplete then + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, "BT"); + Translate_Type_Definition (Base_Type); + Pop_Identifier_Prefix (Mark); + Base_Info := Get_Info (Base_Type); + end; + end if; + Translate_Array_Subtype_Definition (Def); + Info.T := Base_Info.T; + --Info.Type_Range_Type := Base_Info.Type_Range_Type; + if With_Vars then + Create_Array_Subtype_Bounds_Var (Def, False); + end if; + else + -- An unconstrained array subtype. Use same infos as base + -- type. + Free_Info (Def); + Set_Info (Def, Base_Info); + end if; + Translate_Array_Subtype_Element_Subtype (Def); + + when Iir_Kind_Record_Type_Definition => + Translate_Record_Type (Def); + Info.T := Ortho_Info_Type_Record_Init; + + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition => + Free_Info (Def); + Set_Info (Def, Base_Info); + + when Iir_Kind_Access_Type_Definition => + declare + Dtype : constant Iir := Get_Designated_Type (Def); + begin + -- Translate the subtype + if Is_Anonymous_Type_Definition (Dtype) then + Translate_Type_Definition (Dtype); + end if; + Translate_Access_Type (Def); + end; + + when Iir_Kind_File_Type_Definition => + Translate_File_Type (Def); + Info.T := Ortho_Info_Type_File_Init; + if With_Vars then + Create_File_Type_Var (Def); + end if; + + when Iir_Kind_Protected_Type_Declaration => + Translate_Protected_Type (Def); + Info.T := Ortho_Info_Type_Prot_Init; + + when others => + Error_Kind ("translate_type_definition", Def); + end case; + + if Complete_Info /= null then + Translate_Complete_Type (Complete_Info, Def); + end if; + end Translate_Type_Definition; + + procedure Translate_Bool_Type_Definition (Def : Iir) + is + Info : Type_Info_Acc; + begin + -- If the definition is already translated, return now. + Info := Get_Info (Def); + if Info /= null then + raise Internal_Error; + end if; + + Info := Add_Info (Def, Kind_Type); + + if Get_Kind (Def) /= Iir_Kind_Enumeration_Type_Definition then + raise Internal_Error; + end if; + Translate_Bool_Type (Def); + + -- This is usually done in translate_type_definition, but boolean + -- types are not handled by translate_type_definition. + Create_Scalar_Type_Range_Type (Def, True); + end Translate_Bool_Type_Definition; + + procedure Translate_Type_Subprograms (Decl : Iir) + is + Def : Iir; + Tinfo : Type_Info_Acc; + Id : Name_Id; + begin + Def := Get_Type_Definition (Decl); + + if Get_Kind (Def) in Iir_Kinds_Subtype_Definition then + -- Also elaborate the base type, iff DEF and its BASE_TYPE have + -- been declared by the same type declarator. This avoids several + -- elaboration of the same type. + Def := Get_Base_Type (Def); + if Get_Type_Declarator (Def) /= Decl then + -- Can this happen ?? + raise Internal_Error; + end if; + elsif Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then + return; + end if; + + if Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration then + Translate_Protected_Type_Subprograms (Def); + end if; + + Tinfo := Get_Info (Def); + if not Is_Complex_Type (Tinfo) + or else Tinfo.C (Mode_Value).Builder_Need_Func = False + then + return; + end if; + + -- Declare subprograms. + Id := Get_Identifier (Decl); + Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Value); + if Get_Has_Signal_Flag (Def) then + Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Signal); + end if; + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Define subprograms. + case Get_Kind (Def) is + when Iir_Kind_Array_Type_Definition => + Create_Array_Type_Builder (Def, Mode_Value); + if Get_Has_Signal_Flag (Def) then + Create_Array_Type_Builder (Def, Mode_Signal); + end if; + when Iir_Kind_Record_Type_Definition => + Create_Record_Type_Builder (Def, Mode_Value); + if Get_Has_Signal_Flag (Def) then + Create_Record_Type_Builder (Def, Mode_Signal); + end if; + when others => + Error_Kind ("translate_type_subprograms", Def); + end case; + end Translate_Type_Subprograms; + + -- Initialize the objects related to a type (type range and type + -- descriptor). + procedure Elab_Type_Definition (Def : Iir); + procedure Elab_Type_Definition_Depend is new Handle_Anonymous_Subtypes + (Handle_A_Subtype => Elab_Type_Definition); + procedure Elab_Type_Definition (Def : Iir) is + begin + case Get_Kind (Def) is + when Iir_Kind_Incomplete_Type_Definition => + -- Nothing to do. + return; + when Iir_Kind_Protected_Type_Declaration => + -- Elaboration subprograms interfaces. + declare + Final : Boolean; + begin + Chap4.Elab_Declaration_Chain (Def, Final); + if Final then + raise Internal_Error; + end if; + end; + return; + when others => + null; + end case; + + if Get_Type_Staticness (Def) = Locally then + return; + end if; + + Elab_Type_Definition_Depend (Def); + + Create_Type_Definition_Type_Range (Def); + Create_Type_Definition_Size_Var (Def); + end Elab_Type_Definition; + + procedure Translate_Named_Type_Definition (Def : Iir; Id : Name_Id) + is + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Id); + Chap3.Translate_Type_Definition (Def); + Pop_Identifier_Prefix (Mark); + end Translate_Named_Type_Definition; + + procedure Translate_Anonymous_Type_Definition + (Def : Iir; Transient : Boolean) + is + Mark : Id_Mark_Type; + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Def); + if Type_Info /= null then + return; + end if; + Push_Identifier_Prefix_Uniq (Mark); + Chap3.Translate_Type_Definition (Def, False); + if Transient then + Add_Transient_Type_In_Temp (Def); + end if; + Pop_Identifier_Prefix (Mark); + end Translate_Anonymous_Type_Definition; + + procedure Destroy_Type_Info (Atype : Iir) + is + Type_Info : Type_Info_Acc; + begin + Type_Info := Get_Info (Atype); + Free_Type_Info (Type_Info); + Clear_Info (Atype); + end Destroy_Type_Info; + + procedure Translate_Object_Subtype (Decl : Iir; + With_Vars : Boolean := True) + is + Mark : Id_Mark_Type; + Mark2 : Id_Mark_Type; + Def : Iir; + begin + Def := Get_Type (Decl); + if Is_Anonymous_Type_Definition (Def) then + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Push_Identifier_Prefix (Mark2, "OT"); + Chap3.Translate_Type_Definition (Def, With_Vars); + Pop_Identifier_Prefix (Mark2); + Pop_Identifier_Prefix (Mark); + end if; + end Translate_Object_Subtype; + + procedure Elab_Object_Subtype (Def : Iir) is + begin + if Is_Anonymous_Type_Definition (Def) then + Elab_Type_Definition (Def); + end if; + end Elab_Object_Subtype; + + procedure Elab_Type_Declaration (Decl : Iir) + is + begin + Elab_Type_Definition (Get_Type_Definition (Decl)); + end Elab_Type_Declaration; + + procedure Elab_Subtype_Declaration (Decl : Iir_Subtype_Declaration) + is + begin + Elab_Type_Definition (Get_Type (Decl)); + end Elab_Subtype_Declaration; + + function Get_Thin_Array_Length (Atype : Iir) return O_Cnode + is + Indexes_List : constant Iir_List := Get_Index_Subtype_List (Atype); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Indexes_List); + Index : Iir; + Val : Iir_Int64; + Rng : Iir; + begin + Val := 1; + for I in 0 .. Nbr_Dim - 1 loop + Index := Get_Index_Type (Indexes_List, I); + Rng := Get_Range_Constraint (Index); + Val := Val * Eval_Discrete_Range_Length (Rng); + end loop; + return New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Val)); + end Get_Thin_Array_Length; + + function Bounds_To_Range (B : Mnode; Atype : Iir; Dim : Positive) + return Mnode + is + Indexes_List : constant Iir_List := + Get_Index_Subtype_Definition_List (Get_Base_Type (Atype)); + Index_Type_Mark : constant Iir := + Get_Nth_Element (Indexes_List, Dim - 1); + Index_Type : constant Iir := Get_Index_Type (Index_Type_Mark); + Base_Index_Info : constant Index_Info_Acc := + Get_Info (Index_Type_Mark); + Iinfo : constant Type_Info_Acc := + Get_Info (Get_Base_Type (Index_Type)); + begin + return Lv2M (New_Selected_Element (M2Lv (B), + Base_Index_Info.Index_Field), + Iinfo, + Get_Object_Kind (B), + Iinfo.T.Range_Type, + Iinfo.T.Range_Ptr_Type); + end Bounds_To_Range; + + function Type_To_Range (Atype : Iir) return Mnode + is + Info : constant Type_Info_Acc := Get_Info (Atype); + begin + return Varv2M (Info.T.Range_Var, Info, Mode_Value, + Info.T.Range_Type, Info.T.Range_Ptr_Type); + end Type_To_Range; + + function Range_To_Length (R : Mnode) return Mnode + is + Tinfo : constant Type_Info_Acc := Get_Type_Info (R); + begin + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Length), + Tinfo, + Mode_Value); + end Range_To_Length; + + function Range_To_Dir (R : Mnode) return Mnode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (R); + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Dir), + Tinfo, + Mode_Value); + end Range_To_Dir; + + function Range_To_Left (R : Mnode) return Mnode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (R); + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Left), + Tinfo, + Mode_Value); + end Range_To_Left; + + function Range_To_Right (R : Mnode) return Mnode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (R); + return Lv2M (New_Selected_Element (M2Lv (R), + Tinfo.T.Range_Right), + Tinfo, + Mode_Value); + end Range_To_Right; + + function Get_Array_Type_Bounds (Info : Type_Info_Acc) return Mnode + is + begin + case Info.Type_Mode is + when Type_Mode_Fat_Array => + raise Internal_Error; + when Type_Mode_Array => + return Varv2M (Info.T.Array_Bounds, + Info, Mode_Value, + Info.T.Bounds_Type, + Info.T.Bounds_Ptr_Type); + when others => + raise Internal_Error; + end case; + end Get_Array_Type_Bounds; + + function Get_Array_Type_Bounds (Atype : Iir) return Mnode is + begin + return Get_Array_Type_Bounds (Get_Info (Atype)); + end Get_Array_Type_Bounds; + + function Get_Array_Bounds (Arr : Mnode) return Mnode + is + Info : constant Type_Info_Acc := Get_Type_Info (Arr); + begin + case Info.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + declare + Kind : Object_Kind_Type; + begin + Kind := Get_Object_Kind (Arr); + return Lp2M + (New_Selected_Element (M2Lv (Arr), + Info.T.Bounds_Field (Kind)), + Info, + Mode_Value, + Info.T.Bounds_Type, + Info.T.Bounds_Ptr_Type); + end; + when Type_Mode_Array => + return Get_Array_Type_Bounds (Info); + when others => + raise Internal_Error; + end case; + end Get_Array_Bounds; + + function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive) + return Mnode is + begin + return Bounds_To_Range (Get_Array_Bounds (Arr), Atype, Dim); + end Get_Array_Range; + + function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Info (Atype); + Index_List : constant Iir_List := Get_Index_Subtype_List (Atype); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); + Dim_Length : O_Enode; + Res : O_Enode; + Bounds_Stable : Mnode; + begin + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + end if; + + if Nbr_Dim > 1 then + Bounds_Stable := Stabilize (Bounds); + else + Bounds_Stable := Bounds; + end if; + + for Dim in 1 .. Nbr_Dim loop + Dim_Length := + M2E (Range_To_Length + (Bounds_To_Range (Bounds_Stable, Atype, Dim))); + if Dim = 1 then + Res := Dim_Length; + else + Res := New_Dyadic_Op (ON_Mul_Ov, Res, Dim_Length); + end if; + end loop; + return Res; + end Get_Bounds_Length; + + function Get_Array_Type_Length (Atype : Iir) return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + else + return Get_Bounds_Length (Get_Array_Type_Bounds (Atype), Atype); + end if; + end Get_Array_Type_Length; + + function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + else + return Get_Bounds_Length (Get_Array_Bounds (Arr), Atype); + end if; + end Get_Array_Length; + + function Get_Array_Base (Arr : Mnode) return Mnode + is + Info : Type_Info_Acc; + begin + Info := Get_Type_Info (Arr); + case Info.Type_Mode is + when Type_Mode_Fat_Array + | Type_Mode_Fat_Acc => + declare + Kind : Object_Kind_Type; + begin + Kind := Get_Object_Kind (Arr); + return Lp2M + (New_Selected_Element (M2Lv (Arr), + Info.T.Base_Field (Kind)), + Info, + Get_Object_Kind (Arr), + Info.T.Base_Type (Kind), + Info.T.Base_Ptr_Type (Kind)); + end; + when Type_Mode_Array => + return Arr; + when others => + raise Internal_Error; + end case; + end Get_Array_Base; + + function Reindex_Complex_Array + (Base : Mnode; Atype : Iir; Index : O_Enode; Res_Info : Type_Info_Acc) + return Mnode + is + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); + begin + pragma Assert (Is_Complex_Type (El_Tinfo)); + return + E2M + (New_Unchecked_Address + (New_Slice + (New_Access_Element + (New_Convert_Ov (M2E (Base), Char_Ptr_Type)), + Chararray_Type, + New_Dyadic_Op (ON_Mul_Ov, + New_Value + (Get_Var (El_Tinfo.C (Kind).Size_Var)), + Index)), + El_Tinfo.Ortho_Ptr_Type (Kind)), + Res_Info, Kind); + end Reindex_Complex_Array; + + function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode + is + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); + begin + if Is_Complex_Type (El_Tinfo) then + return Reindex_Complex_Array (Base, Atype, Index, El_Tinfo); + else + return Lv2M (New_Indexed_Element (M2Lv (Base), Index), + El_Tinfo, Kind); + end if; + end Index_Base; + + function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode) + return Mnode + is + T_Info : constant Type_Info_Acc := Get_Info (Atype); + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Base); + begin + if Is_Complex_Type (El_Tinfo) then + return Reindex_Complex_Array (Base, Atype, Index, T_Info); + else + return Lv2M (New_Slice (M2Lv (Base), + T_Info.T.Base_Type (Kind), + Index), + False, + T_Info.T.Base_Type (Kind), + T_Info.T.Base_Ptr_Type (Kind), + T_Info, Kind); + end if; + end Slice_Base; + + procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind; + Res : Mnode; + Arr_Type : Iir) + is + Dinfo : constant Type_Info_Acc := + Get_Info (Get_Base_Type (Arr_Type)); + Kind : constant Object_Kind_Type := Get_Object_Kind (Res); + Length : O_Enode; + begin + -- Compute array size. + Length := Get_Object_Size (Res, Arr_Type); + -- Allocate the storage for the elements. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + Gen_Alloc (Alloc_Kind, Length, Dinfo.T.Base_Ptr_Type (Kind))); + + if Is_Complex_Type (Dinfo) + and then Dinfo.C (Kind).Builder_Need_Func + then + Open_Temp; + -- Build the type. + Chap3.Gen_Call_Type_Builder (Res, Arr_Type); + Close_Temp; + end if; + end Allocate_Fat_Array_Base; + + procedure Create_Array_Subtype (Sub_Type : Iir; Transient : Boolean) + is + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix_Uniq (Mark); + if Get_Info (Sub_Type) = null then + -- Minimal subtype creation. + Translate_Type_Definition (Sub_Type, False); + if Transient then + Add_Transient_Type_In_Temp (Sub_Type); + end if; + end if; + -- Force creation of variables. + Chap3.Create_Array_Subtype_Bounds_Var (Sub_Type, True); + Chap3.Create_Type_Definition_Size_Var (Sub_Type); + Pop_Identifier_Prefix (Mark); + end Create_Array_Subtype; + + -- Copy SRC to DEST. + -- Both have the same type, OTYPE. + procedure Translate_Object_Copy (Dest : Mnode; + Src : O_Enode; + Obj_Type : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Obj_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Dest); + D : Mnode; + begin + case Info.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc + | Type_Mode_File => + -- Scalar or thin pointer. + New_Assign_Stmt (M2Lv (Dest), Src); + when Type_Mode_Fat_Acc => + -- a fat pointer. + D := Stabilize (Dest); + Copy_Fat_Pointer (D, Stabilize (E2M (Src, Info, Kind))); + when Type_Mode_Fat_Array => + -- a fat array. + D := Stabilize (Dest); + Gen_Memcpy (M2Addr (Get_Array_Base (D)), + M2Addr (Get_Array_Base (E2M (Src, Info, Kind))), + Get_Object_Size (D, Obj_Type)); + when Type_Mode_Array + | Type_Mode_Record => + D := Stabilize (Dest); + Gen_Memcpy (M2Addr (D), Src, Get_Object_Size (D, Obj_Type)); + when Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Object_Copy; + + function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) + return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Type_Info (Obj); + Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); + begin + if Is_Complex_Type (Type_Info) + and then Type_Info.C (Kind).Size_Var /= Null_Var + then + return New_Value (Get_Var (Type_Info.C (Kind).Size_Var)); + end if; + case Type_Info.Type_Mode is + when Type_Mode_Non_Composite + | Type_Mode_Array + | Type_Mode_Record => + return New_Lit (New_Sizeof (Type_Info.Ortho_Type (Kind), + Ghdl_Index_Type)); + when Type_Mode_Fat_Array => + declare + El_Type : Iir; + El_Tinfo : Type_Info_Acc; + Obj_Bt : Iir; + Sz : O_Enode; + begin + Obj_Bt := Get_Base_Type (Obj_Type); + El_Type := Get_Element_Subtype (Obj_Bt); + El_Tinfo := Get_Info (El_Type); + -- See create_type_definition_size_var. + Sz := Get_Object_Size (T2M (El_Type, Kind), El_Type); + if Is_Complex_Type (El_Tinfo) then + Sz := New_Dyadic_Op + (ON_Add_Ov, + Sz, + New_Lit (New_Sizeof (El_Tinfo.Ortho_Ptr_Type (Kind), + Ghdl_Index_Type))); + end if; + return New_Dyadic_Op + (ON_Mul_Ov, Chap3.Get_Array_Length (Obj, Obj_Bt), Sz); + end; + when others => + raise Internal_Error; + end case; + end Get_Object_Size; + + procedure Translate_Object_Allocation + (Res : in out Mnode; + Alloc_Kind : Allocation_Kind; + Obj_Type : Iir; + Bounds : Mnode) + is + Dinfo : constant Type_Info_Acc := Get_Info (Obj_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Res); + begin + if Dinfo.Type_Mode = Type_Mode_Fat_Array then + -- Allocate memory for bounds. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + Gen_Alloc (Alloc_Kind, + New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, + Ghdl_Index_Type)), + Dinfo.T.Bounds_Ptr_Type)); + + -- Copy bounds to the allocated area. + Gen_Memcpy + (M2Addr (Chap3.Get_Array_Bounds (Res)), + M2Addr (Bounds), + New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, Ghdl_Index_Type))); + + -- Allocate base. + Allocate_Fat_Array_Base (Alloc_Kind, Res, Obj_Type); + else + New_Assign_Stmt + (M2Lp (Res), + Gen_Alloc + (Alloc_Kind, + Chap3.Get_Object_Size (T2M (Obj_Type, Kind), + Obj_Type), + Dinfo.Ortho_Ptr_Type (Kind))); + + if Is_Complex_Type (Dinfo) + and then Dinfo.C (Kind).Builder_Need_Func + then + Open_Temp; + -- Build the type. + Chap3.Gen_Call_Type_Builder (Res, Obj_Type); + Close_Temp; + end if; + + end if; + end Translate_Object_Allocation; + + procedure Gen_Deallocate (Obj : O_Enode) + is + Assocs : O_Assoc_List; + begin + Start_Association (Assocs, Ghdl_Deallocate); + New_Association (Assocs, New_Convert_Ov (Obj, Ghdl_Ptr_Type)); + New_Procedure_Call (Assocs); + end Gen_Deallocate; + + -- Performs deallocation of PARAM (the parameter of a deallocate call). + procedure Translate_Object_Deallocation (Param : Iir) + is + -- Performs deallocation of field FIELD of type FTYPE of PTR. + -- If FIELD is O_FNODE_NULL, deallocate PTR (of type FTYPE). + -- Here, deallocate means freeing memory and clearing to null. + procedure Deallocate_1 + (Ptr : Mnode; Field : O_Fnode; Ftype : O_Tnode) + is + L : O_Lnode; + begin + for I in 0 .. 1 loop + L := M2Lv (Ptr); + if Field /= O_Fnode_Null then + L := New_Selected_Element (L, Field); + end if; + case I is + when 0 => + -- Call deallocator. + Gen_Deallocate (New_Value (L)); + when 1 => + -- set the value to 0. + New_Assign_Stmt (L, New_Lit (New_Null_Access (Ftype))); + end case; + end loop; + end Deallocate_1; + + Param_Type : Iir; + Val : Mnode; + Info : Type_Info_Acc; + Binfo : Type_Info_Acc; + begin + -- Compute parameter + Val := Chap6.Translate_Name (Param); + if Get_Object_Kind (Val) = Mode_Signal then + raise Internal_Error; + end if; + Stabilize (Val); + Param_Type := Get_Type (Param); + Info := Get_Info (Param_Type); + case Info.Type_Mode is + when Type_Mode_Fat_Acc => + -- This is a fat pointer. + -- Deallocate base and bounds. + Binfo := Get_Info (Get_Designated_Type (Param_Type)); + Deallocate_1 (Val, Binfo.T.Base_Field (Mode_Value), + Binfo.T.Base_Ptr_Type (Mode_Value)); + Deallocate_1 (Val, Binfo.T.Bounds_Field (Mode_Value), + Binfo.T.Bounds_Ptr_Type); + when Type_Mode_Acc => + -- This is a thin pointer. + Deallocate_1 (Val, O_Fnode_Null, + Info.Ortho_Type (Mode_Value)); + when others => + raise Internal_Error; + end case; + end Translate_Object_Deallocation; + + function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode + is + Constr : Iir; + Info : Type_Info_Acc; + + function Gen_Compare (Low : O_Enode; Hi : O_Enode) return O_Enode + is + L, H : O_Enode; + begin + if not Info.T.Nocheck_Low then + L := New_Compare_Op + (ON_Lt, New_Obj_Value (Value), Low, Ghdl_Bool_Type); + end if; + if not Info.T.Nocheck_Hi then + H := New_Compare_Op + (ON_Gt, New_Obj_Value (Value), Hi, Ghdl_Bool_Type); + end if; + if Info.T.Nocheck_Hi then + if Info.T.Nocheck_Low then + -- Should not happen! + return New_Lit (Ghdl_Bool_False_Node); + else + return L; + end if; + else + if Info.T.Nocheck_Low then + return H; + else + return New_Dyadic_Op (ON_Or, L, H); + end if; + end if; + end Gen_Compare; + + function Gen_Compare_To return O_Enode is + begin + return Gen_Compare + (Chap14.Translate_Left_Type_Attribute (Atype), + Chap14.Translate_Right_Type_Attribute (Atype)); + end Gen_Compare_To; + + function Gen_Compare_Downto return O_Enode is + begin + return Gen_Compare + (Chap14.Translate_Right_Type_Attribute (Atype), + Chap14.Translate_Left_Type_Attribute (Atype)); + end Gen_Compare_Downto; + + --Low, High : Iir; + Var_Res : O_Dnode; + If_Blk : O_If_Block; + begin + Constr := Get_Range_Constraint (Atype); + Info := Get_Info (Atype); + + if Get_Kind (Constr) = Iir_Kind_Range_Expression then + -- Constraint is a range expression, therefore, direction is + -- known. + if Get_Expr_Staticness (Constr) = Locally then + -- Range constraint is locally static + -- FIXME: check low and high if they are not limits... + --Low := Get_Low_Limit (Constr); + --High := Get_High_Limit (Constr); + null; + end if; + case Get_Direction (Constr) is + when Iir_To => + return Gen_Compare_To; + when Iir_Downto => + return Gen_Compare_Downto; + end case; + end if; + + -- Range constraint is not static + -- full check (lot's of code ?). + Var_Res := Create_Temp (Ghdl_Bool_Type); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + Chap14.Translate_Dir_Type_Attribute (Atype), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + -- To. + New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_To); + New_Else_Stmt (If_Blk); + -- Downto + New_Assign_Stmt (New_Obj (Var_Res), Gen_Compare_Downto); + Finish_If_Stmt (If_Blk); + return New_Obj_Value (Var_Res); + end Not_In_Range; + + function Need_Range_Check (Expr : Iir; Atype : Iir) return Boolean + is + Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if Info.T.Nocheck_Low and Info.T.Nocheck_Hi then + return False; + end if; + if Expr /= Null_Iir and then Get_Type (Expr) = Atype then + return False; + end if; + return True; + end Need_Range_Check; + + procedure Check_Range + (Value : O_Dnode; Expr : Iir; Atype : Iir; Loc : Iir) + is + If_Blk : O_If_Block; + begin + if not Need_Range_Check (Expr, Atype) then + return; + end if; + + if Expr /= Null_Iir + and then Get_Expr_Staticness (Expr) = Locally + and then Get_Type_Staticness (Atype) = Locally + then + if not Eval_Is_In_Bound (Eval_Static_Expr (Expr), Atype) then + Chap6.Gen_Bound_Error (Loc); + end if; + else + Open_Temp; + Start_If_Stmt (If_Blk, Not_In_Range (Value, Atype)); + Chap6.Gen_Bound_Error (Loc); + Finish_If_Stmt (If_Blk); + Close_Temp; + end if; + end Check_Range; + + function Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir; Loc : Iir) + return O_Enode + is + Var : O_Dnode; + begin + Var := Create_Temp_Init + (Get_Ortho_Type (Get_Base_Type (Atype), Mode_Value), Value); + Check_Range (Var, Expr, Atype, Loc); + return New_Obj_Value (Var); + end Insert_Scalar_Check; + + function Maybe_Insert_Scalar_Check + (Value : O_Enode; Expr : Iir; Atype : Iir) + return O_Enode + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + -- pragma Assert (Base_Type = Get_Base_Type (Atype)); + if Get_Kind (Expr_Type) in Iir_Kinds_Scalar_Type_Definition + and then Need_Range_Check (Expr, Atype) + then + return Insert_Scalar_Check (Value, Expr, Atype, Expr); + else + return Value; + end if; + end Maybe_Insert_Scalar_Check; + + function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean + is + L_Indexes : constant Iir_List := Get_Index_Subtype_List (L_Type); + R_Indexes : constant Iir_List := Get_Index_Subtype_List (R_Type); + L_El : Iir; + R_El : Iir; + begin + for I in Natural loop + L_El := Get_Index_Type (L_Indexes, I); + R_El := Get_Index_Type (R_Indexes, I); + exit when L_El = Null_Iir and R_El = Null_Iir; + if Eval_Discrete_Type_Length (L_El) + /= Eval_Discrete_Type_Length (R_El) + then + return False; + end if; + end loop; + return True; + end Locally_Array_Match; + + procedure Check_Array_Match (L_Type : Iir; + L_Node : Mnode; + R_Type : Iir; + R_Node : Mnode; + Loc : Iir) + is + L_Tinfo, R_Tinfo : Type_Info_Acc; + begin + L_Tinfo := Get_Info (L_Type); + R_Tinfo := Get_Info (R_Type); + -- FIXME: optimize for a statically bounded array of a complex type. + if L_Tinfo.Type_Mode = Type_Mode_Array + and then L_Tinfo.Type_Locally_Constrained + and then R_Tinfo.Type_Mode = Type_Mode_Array + and then R_Tinfo.Type_Locally_Constrained + then + -- Both left and right are thin array. + -- Check here the length are the same. + if not Locally_Array_Match (L_Type, R_Type) then + Chap6.Gen_Bound_Error (Loc); + end if; + else + -- Check length match. + declare + Index_List : constant Iir_List := + Get_Index_Subtype_List (L_Type); + Index : Iir; + Cond : O_Enode; + Sub_Cond : O_Enode; + begin + for I in Natural loop + Index := Get_Nth_Element (Index_List, I); + exit when Index = Null_Iir; + Sub_Cond := New_Compare_Op + (ON_Neq, + M2E (Range_To_Length + (Get_Array_Range (L_Node, L_Type, I + 1))), + M2E (Range_To_Length + (Get_Array_Range (R_Node, R_Type, I + 1))), + Ghdl_Bool_Type); + if I = 0 then + Cond := Sub_Cond; + else + Cond := New_Dyadic_Op (ON_Or, Cond, Sub_Cond); + end if; + end loop; + Chap6.Check_Bound_Error (Cond, Loc, 0); + end; + end if; + end Check_Array_Match; + + procedure Create_Range_From_Array_Attribute_And_Length + (Array_Attr : Iir; Length : O_Dnode; Range_Ptr : O_Dnode) + is + Attr_Kind : Iir_Kind; + Arr_Rng : Mnode; + Iinfo : Type_Info_Acc; + + Res : Mnode; + + Dir : O_Enode; + Diff : O_Dnode; + Left_Bound : Mnode; + If_Blk : O_If_Block; + If_Blk1 : O_If_Block; + begin + Open_Temp; + Arr_Rng := Chap14.Translate_Array_Attribute_To_Range (Array_Attr); + Iinfo := Get_Type_Info (Arr_Rng); + Stabilize (Arr_Rng); + + Res := Dp2M (Range_Ptr, Iinfo, Mode_Value); + + -- Length. + New_Assign_Stmt (M2Lv (Range_To_Length (Arr_Rng)), + New_Obj_Value (Length)); + + -- Direction. + Attr_Kind := Get_Kind (Array_Attr); + Dir := M2E (Range_To_Dir (Arr_Rng)); + case Attr_Kind is + when Iir_Kind_Range_Array_Attribute => + New_Assign_Stmt (M2Lv (Range_To_Dir (Res)), Dir); + when Iir_Kind_Reverse_Range_Array_Attribute => + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Eq, + Dir, + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt + (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_Downto_Node)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (M2Lv (Range_To_Dir (Res)), New_Lit (Ghdl_Dir_To_Node)); + Finish_If_Stmt (If_Blk); + when others => + Error_Kind ("Create_Range_From_Array_Attribute_And_Length", + Array_Attr); + end case; + + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + -- Null range. + case Attr_Kind is + when Iir_Kind_Range_Array_Attribute => + New_Assign_Stmt (M2Lv (Range_To_Left (Res)), + M2E (Range_To_Right (Arr_Rng))); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + M2E (Range_To_Left (Arr_Rng))); + when Iir_Kind_Reverse_Range_Array_Attribute => + New_Assign_Stmt (M2Lv (Range_To_Left (Res)), + M2E (Range_To_Left (Arr_Rng))); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + M2E (Range_To_Right (Arr_Rng))); + when others => + raise Internal_Error; + end case; + + New_Else_Stmt (If_Blk); + + -- LEFT. + case Attr_Kind is + when Iir_Kind_Range_Array_Attribute => + Left_Bound := Range_To_Left (Arr_Rng); + when Iir_Kind_Reverse_Range_Array_Attribute => + Left_Bound := Range_To_Right (Arr_Rng); + when others => + raise Internal_Error; + end case; + Stabilize (Left_Bound); + New_Assign_Stmt (M2Lv (Range_To_Left (Res)), M2E (Left_Bound)); + + -- RIGHT. + Diff := Create_Temp_Init + (Iinfo.Ortho_Type (Mode_Value), + New_Convert_Ov + (New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_1)), + Iinfo.Ortho_Type (Mode_Value))); + + Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Eq, + M2E (Range_To_Dir (Res)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + New_Dyadic_Op (ON_Add_Ov, + M2E (Left_Bound), + New_Obj_Value (Diff))); + New_Else_Stmt (If_Blk1); + New_Assign_Stmt (M2Lv (Range_To_Right (Res)), + New_Dyadic_Op (ON_Sub_Ov, + M2E (Left_Bound), + New_Obj_Value (Diff))); + Finish_If_Stmt (If_Blk1); + + -- FIXME: check right bounds is inside bounds. + Finish_If_Stmt (If_Blk); + Close_Temp; + end Create_Range_From_Array_Attribute_And_Length; + + procedure Create_Range_From_Length + (Index_Type : Iir; Length : O_Dnode; Range_Ptr : O_Dnode; Loc : Iir) + is + Iinfo : constant Type_Info_Acc := Get_Info (Index_Type); + Range_Constr : constant Iir := Get_Range_Constraint (Index_Type); + Op : ON_Op_Kind; + Diff : O_Enode; + Left_Bound : O_Enode; + Var_Right : O_Dnode; + If_Blk : O_If_Block; + begin + if Get_Kind (Range_Constr) /= Iir_Kind_Range_Expression then + Create_Range_From_Array_Attribute_And_Length + (Range_Constr, Length, Range_Ptr); + return; + end if; + + Start_Declare_Stmt; + New_Var_Decl (Var_Right, Get_Identifier ("right_bound"), + O_Storage_Local, Iinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Length), + New_Obj_Value (Length)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Dir), + New_Lit (Chap7.Translate_Static_Range_Dir (Range_Constr))); + + case Get_Direction (Range_Constr) is + when Iir_To => + Op := ON_Add_Ov; + when Iir_Downto => + Op := ON_Sub_Ov; + end case; + + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + -- Null range. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Left), + Chap7.Translate_Range_Expression_Right (Range_Constr, Index_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right), + Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type)); + + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Left), + Chap7.Translate_Range_Expression_Left (Range_Constr, Index_Type)); + Left_Bound := Chap7.Translate_Range_Expression_Left + (Range_Constr, Index_Type); + Diff := New_Convert_Ov + (New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Length), + New_Lit (Ghdl_Index_1)), + Iinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt (New_Obj (Var_Right), + New_Dyadic_Op (Op, Left_Bound, Diff)); + + -- Check the right bounds is inside the bounds of the index type. + Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Loc); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Range_Ptr), Iinfo.T.Range_Right), + New_Obj_Value (Var_Right)); + Finish_If_Stmt (If_Blk); + Finish_Declare_Stmt; + end Create_Range_From_Length; + end Chap3; + + package body Chap4 is + -- Get the ortho type for an object of mode MODE. + function Get_Object_Type (Tinfo : Type_Info_Acc; Kind : Object_Kind_Type) + return O_Tnode is + begin + if Is_Complex_Type (Tinfo) then + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array => + return Tinfo.Ortho_Type (Kind); + when Type_Mode_Record + | Type_Mode_Array + | Type_Mode_Protected => + -- For a complex type, use a pointer. + return Tinfo.Ortho_Ptr_Type (Kind); + when others => + raise Internal_Error; + end case; + else + return Tinfo.Ortho_Type (Kind); + end if; + end Get_Object_Type; + + procedure Create_Object (El : Iir) + is + Obj_Type : O_Tnode; + Info : Object_Info_Acc; + Tinfo : Type_Info_Acc; + Def : Iir; + Val : Iir; + Storage : O_Storage; + Deferred : Iir; + begin + Def := Get_Type (El); + Val := Get_Default_Value (El); + + -- Be sure the object type was translated. + if Get_Kind (El) = Iir_Kind_Constant_Declaration + and then Get_Deferred_Declaration_Flag (El) = False + and then Get_Deferred_Declaration (El) /= Null_Iir + then + -- This is a full constant declaration which complete a previous + -- incomplete constant declaration. + -- + -- Do not create the subtype of this full constant declaration, + -- since it was already created by the deferred declaration. + -- Use the type of the deferred declaration. + Deferred := Get_Deferred_Declaration (El); + Def := Get_Type (Deferred); + Info := Get_Info (Deferred); + Set_Info (El, Info); + else + Chap3.Translate_Object_Subtype (El); + Info := Add_Info (El, Kind_Object); + end if; + + Tinfo := Get_Info (Def); + Obj_Type := Get_Object_Type (Tinfo, Mode_Value); + + case Get_Kind (El) is + when Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Constant_Declaration => + Info.Object_Var := + Create_Var (Create_Var_Identifier (El), Obj_Type); + when Iir_Kind_Constant_Declaration => + if Get_Deferred_Declaration (El) /= Null_Iir then + -- This is a full constant declaration (in a body) of a + -- deferred constant declaration (in a package). + Storage := O_Storage_Public; + else + Storage := Global_Storage; + end if; + if Info.Object_Var = Null_Var then + -- Not a full constant declaration (ie a value for an + -- already declared constant). + -- Must create the declaration. + if Chap7.Is_Static_Constant (El) then + Info.Object_Static := True; + Info.Object_Var := Create_Global_Const + (Create_Identifier (El), Obj_Type, Global_Storage, + O_Cnode_Null); + else + Info.Object_Static := False; + Info.Object_Var := Create_Var + (Create_Var_Identifier (El), + Obj_Type, Global_Storage); + end if; + end if; + if Get_Deferred_Declaration (El) = Null_Iir + and then Info.Object_Static + and then Storage /= O_Storage_External + then + -- Deferred constant are never considered as locally static. + -- FIXME: to be improved ? + + -- open_temp/close_temp only required for transient types. + Open_Temp; + Define_Global_Const + (Info.Object_Var, + Chap7.Translate_Static_Expression (Val, Def)); + Close_Temp; + end if; + when others => + Error_Kind ("create_objet", El); + end case; + end Create_Object; + + procedure Create_Signal (Decl : Iir) + is + Sig_Type_Def : constant Iir := Get_Type (Decl); + Sig_Type : O_Tnode; + Type_Info : Type_Info_Acc; + Info : Ortho_Info_Acc; + begin + Chap3.Translate_Object_Subtype (Decl); + + Type_Info := Get_Info (Sig_Type_Def); + Sig_Type := Get_Object_Type (Type_Info, Mode_Signal); + pragma Assert (Sig_Type /= O_Tnode_Null); + + Info := Add_Info (Decl, Kind_Object); + + Info.Object_Var := + Create_Var (Create_Var_Identifier (Decl), Sig_Type); + + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Rtis.Generate_Signal_Rti (Decl); + when Iir_Kind_Guard_Signal_Declaration => + -- No name created for guard signal. + null; + when others => + Error_Kind ("create_signal", Decl); + end case; + end Create_Signal; + + procedure Create_Implicit_Signal (Decl : Iir) + is + Sig_Type : O_Tnode; + Type_Info : Type_Info_Acc; + Info : Ortho_Info_Acc; + Sig_Type_Def : Iir; + begin + Sig_Type_Def := Get_Type (Decl); + -- This has been disabled since DECL can have an anonymous subtype, + -- and DECL has no identifiers, which causes translate_object_subtype + -- to crash. + -- Note: DECL can only be a iir_kind_delayed_attribute. + --Chap3.Translate_Object_Subtype (Decl); + Type_Info := Get_Info (Sig_Type_Def); + Sig_Type := Type_Info.Ortho_Type (Mode_Signal); + if Sig_Type = O_Tnode_Null then + raise Internal_Error; + end if; + + Info := Add_Info (Decl, Kind_Object); + + Info.Object_Var := Create_Var (Create_Uniq_Identifier, Sig_Type); + end Create_Implicit_Signal; + + procedure Create_File_Object (El : Iir_File_Declaration) + is + Obj_Type : O_Tnode; + Info : Ortho_Info_Acc; + Obj_Type_Def : Iir; + begin + Obj_Type_Def := Get_Type (El); + Obj_Type := Get_Ortho_Type (Obj_Type_Def, Mode_Value); + + Info := Add_Info (El, Kind_Object); + + Info.Object_Var := Create_Var (Create_Var_Identifier (El), Obj_Type); + end Create_File_Object; + + procedure Create_Package_Interface (Inter : Iir) + is + Info : Ortho_Info_Acc; + Pkg : constant Iir := Get_Named_Entity + (Get_Uninstantiated_Package_Name (Inter)); + Pkg_Info : constant Ortho_Info_Acc := Get_Info (Pkg); + begin + Chap2.Instantiate_Info_Package (Inter); + Info := Get_Info (Inter); + + -- The spec + Info.Package_Instance_Spec_Var := + Create_Var (Create_Var_Identifier (Inter, "SPEC", 0), + Pkg_Info.Package_Spec_Ptr_Type); + Set_Scope_Via_Var_Ptr + (Info.Package_Instance_Spec_Scope, + Info.Package_Instance_Spec_Var); + + -- The body + Info.Package_Instance_Body_Var := + Create_Var (Create_Var_Identifier (Inter, "BODY", 0), + Pkg_Info.Package_Body_Ptr_Type); + Set_Scope_Via_Var_Ptr + (Info.Package_Instance_Body_Scope, + Info.Package_Instance_Body_Var); + end Create_Package_Interface; + + procedure Allocate_Complex_Object (Obj_Type : Iir; + Alloc_Kind : Allocation_Kind; + Var : in out Mnode) + is + Type_Info : constant Type_Info_Acc := Get_Type_Info (Var); + Kind : constant Object_Kind_Type := Get_Object_Kind (Var); + Targ : Mnode; + begin + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Cannot allocate unconstrained object (since size is unknown). + raise Internal_Error; + end if; + + if not Is_Complex_Type (Type_Info) then + -- Object is not complex. + return; + end if; + + if Type_Info.C (Kind).Builder_Need_Func + and then not Is_Stable (Var) + then + Targ := Create_Temp (Type_Info, Kind); + else + Targ := Var; + end if; + + -- Allocate variable. + New_Assign_Stmt + (M2Lp (Targ), + Gen_Alloc (Alloc_Kind, + Chap3.Get_Object_Size (Var, Obj_Type), + Type_Info.Ortho_Ptr_Type (Kind))); + + if Type_Info.C (Kind).Builder_Need_Func then + -- Build the type. + Chap3.Gen_Call_Type_Builder (Targ, Obj_Type); + if not Is_Stable (Var) then + New_Assign_Stmt (M2Lp (Var), M2Addr (Targ)); + Var := Targ; + end if; + end if; + end Allocate_Complex_Object; + + -- Note : OBJ can be a tree. + -- FIXME: should use translate_aggregate_others. + procedure Init_Array_Object (Obj : Mnode; Obj_Type : Iir) + is + Sobj : Mnode; + + -- Type of the object. + Type_Info : Type_Info_Acc; + + -- Iterator for the elements. + Index : O_Dnode; + + Upper_Limit : O_Enode; + Upper_Var : O_Dnode; + + Label : O_Snode; + begin + Type_Info := Get_Info (Obj_Type); + + -- Iterate on all elements of the object. + Open_Temp; + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + Sobj := Stabilize (Obj); + else + Sobj := Obj; + end if; + Upper_Limit := Chap3.Get_Array_Length (Sobj, Obj_Type); + + if Type_Info.Type_Mode /= Type_Mode_Array then + Upper_Var := Create_Temp_Init (Ghdl_Index_Type, Upper_Limit); + else + Upper_Var := O_Dnode_Null; + end if; + + Index := Create_Temp (Ghdl_Index_Type); + Init_Var (Index); + Start_Loop_Stmt (Label); + if Upper_Var /= O_Dnode_Null then + Upper_Limit := New_Obj_Value (Upper_Var); + end if; + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Index), Upper_Limit, + Ghdl_Bool_Type)); + Init_Object (Chap3.Index_Base (Chap3.Get_Array_Base (Sobj), + Obj_Type, + New_Obj_Value (Index)), + Get_Element_Subtype (Obj_Type)); + Inc_Var (Index); + Finish_Loop_Stmt (Label); + + Close_Temp; + end Init_Array_Object; + + procedure Init_Protected_Object (Obj : Mnode; Obj_Type : Iir) + is + Assoc : O_Assoc_List; + Info : Type_Info_Acc; + begin + Info := Get_Info (Obj_Type); + + -- Call the initializer. + Start_Association (Assoc, Info.T.Prot_Init_Subprg); + Chap2.Add_Subprg_Instance_Assoc (Assoc, Info.T.Prot_Init_Instance); + -- Use of M2Lp is a little bit fragile (not sure we get the + -- variable, but should work: we didn't stabilize it). + New_Assign_Stmt (M2Lp (Obj), New_Function_Call (Assoc)); + end Init_Protected_Object; + + procedure Fini_Protected_Object (Decl : Iir) + is + Obj : Mnode; + Assoc : O_Assoc_List; + Info : Type_Info_Acc; + begin + Info := Get_Info (Get_Type (Decl)); + + Obj := Chap6.Translate_Name (Decl); + -- Call the Finalizator. + Start_Association (Assoc, Info.T.Prot_Final_Subprg); + New_Association (Assoc, M2E (Obj)); + New_Procedure_Call (Assoc); + end Fini_Protected_Object; + + procedure Init_Object (Obj : Mnode; Obj_Type : Iir) + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (Obj); + case Tinfo.Type_Mode is + when Type_Mode_Scalar => + New_Assign_Stmt + (M2Lv (Obj), Chap14.Translate_Left_Type_Attribute (Obj_Type)); + when Type_Mode_Acc => + New_Assign_Stmt + (M2Lv (Obj), + New_Lit (New_Null_Access (Tinfo.Ortho_Type (Mode_Value)))); + when Type_Mode_Fat_Acc => + declare + Dinfo : Type_Info_Acc; + Sobj : Mnode; + begin + Open_Temp; + Sobj := Stabilize (Obj); + Dinfo := Get_Info (Get_Designated_Type (Obj_Type)); + New_Assign_Stmt + (New_Selected_Element (M2Lv (Sobj), + Dinfo.T.Bounds_Field (Mode_Value)), + New_Lit (New_Null_Access (Dinfo.T.Bounds_Ptr_Type))); + New_Assign_Stmt + (New_Selected_Element (M2Lv (Sobj), + Dinfo.T.Base_Field (Mode_Value)), + New_Lit (New_Null_Access + (Dinfo.T.Base_Ptr_Type (Mode_Value)))); + Close_Temp; + end; + when Type_Mode_Arrays => + Init_Array_Object (Obj, Obj_Type); + when Type_Mode_Record => + declare + Sobj : Mnode; + El : Iir_Element_Declaration; + List : Iir_List; + begin + Open_Temp; + Sobj := Stabilize (Obj); + List := Get_Elements_Declaration_List + (Get_Base_Type (Obj_Type)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Init_Object (Chap6.Translate_Selected_Element (Sobj, El), + Get_Type (El)); + end loop; + Close_Temp; + end; + when Type_Mode_Protected => + Init_Protected_Object (Obj, Obj_Type); + when Type_Mode_Unknown + | Type_Mode_File => + raise Internal_Error; + end case; + end Init_Object; + + procedure Elab_Object_Storage (Obj : Iir) + is + Obj_Type : constant Iir := Get_Type (Obj); + Obj_Info : constant Object_Info_Acc := Get_Info (Obj); + + Name_Node : Mnode; + + Type_Info : Type_Info_Acc; + Alloc_Kind : Allocation_Kind; + begin + -- Elaborate subtype. + Chap3.Elab_Object_Subtype (Obj_Type); + + Type_Info := Get_Info (Obj_Type); + + -- FIXME: the object type may be a fat array! + -- FIXME: fat array + aggregate ? + + if Type_Info.Type_Mode = Type_Mode_Protected then + -- Protected object will be created by its INIT function. + return; + end if; + + if Is_Complex_Type (Type_Info) + and then Type_Info.Type_Mode /= Type_Mode_Fat_Array + then + -- FIXME: avoid allocation if the value is a string and + -- the object is a constant + Name_Node := Get_Var (Obj_Info.Object_Var, Type_Info, Mode_Value); + Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var); + Allocate_Complex_Object (Obj_Type, Alloc_Kind, Name_Node); + end if; + end Elab_Object_Storage; + + -- Generate code to create object OBJ and initialize it with value VAL. + procedure Elab_Object_Init (Name : Mnode; Obj : Iir; Value : Iir) + is + Obj_Type : constant Iir := Get_Type (Obj); + Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type); + Obj_Info : constant Object_Info_Acc := Get_Info (Obj); + + Name_Node : Mnode; + Value_Node : O_Enode; + + Alloc_Kind : Allocation_Kind; + begin + -- Elaborate subtype. + Alloc_Kind := Get_Alloc_Kind_For_Var (Obj_Info.Object_Var); + + -- Note: no temporary variable region is created, as the allocation + -- may be performed on the stack. + + if Value = Null_Iir then + -- Performs default initialization. + Open_Temp; + Init_Object (Name, Obj_Type); + Close_Temp; + elsif Get_Kind (Value) = Iir_Kind_Aggregate then + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Allocate. + declare + Aggr_Type : Iir; + begin + Aggr_Type := Get_Type (Value); + Chap3.Create_Array_Subtype (Aggr_Type, True); + Name_Node := Stabilize (Name); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Name_Node)), + M2Addr (Chap3.Get_Array_Type_Bounds (Aggr_Type))); + Chap3.Allocate_Fat_Array_Base + (Alloc_Kind, Name_Node, Get_Base_Type (Aggr_Type)); + end; + else + Name_Node := Name; + end if; + Chap7.Translate_Aggregate (Name_Node, Obj_Type, Value); + else + Value_Node := Chap7.Translate_Expression (Value, Obj_Type); + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + declare + S : Mnode; + begin + Name_Node := Stabilize (Name); + S := Stabilize (E2M (Value_Node, Type_Info, Mode_Value)); + + if Get_Kind (Value) = Iir_Kind_String_Literal + and then Get_Kind (Obj) = Iir_Kind_Constant_Declaration + then + -- No need to allocate space for the object. + Copy_Fat_Pointer (Name_Node, S); + else + Chap3.Translate_Object_Allocation + (Name_Node, Alloc_Kind, Obj_Type, + Chap3.Get_Array_Bounds (S)); + Chap3.Translate_Object_Copy + (Name_Node, M2Addr (S), Obj_Type); + end if; + end; + else + Chap3.Translate_Object_Copy (Name, Value_Node, Obj_Type); + end if; + Destroy_Local_Transient_Types; + end if; + end Elab_Object_Init; + + -- Generate code to create object OBJ and initialize it with value VAL. + procedure Elab_Object_Value (Obj : Iir; Value : Iir) + is + Name : Mnode; + begin + Elab_Object_Storage (Obj); + Name := Get_Var (Get_Info (Obj).Object_Var, + Get_Info (Get_Type (Obj)), Mode_Value); + Elab_Object_Init (Name, Obj, Value); + end Elab_Object_Value; + + -- Create code to elaborate OBJ. + procedure Elab_Object (Obj : Iir) + is + Value : Iir; + Obj1 : Iir; + begin + -- A locally static constant is pre-elaborated. + -- (only constant can be locally static). + if Get_Expr_Staticness (Obj) = Locally + and then Get_Deferred_Declaration (Obj) = Null_Iir + then + return; + end if; + + -- Set default value. + if Get_Kind (Obj) = Iir_Kind_Constant_Declaration then + if Get_Info (Obj).Object_Static then + return; + end if; + if Get_Deferred_Declaration_Flag (Obj) then + -- No code generation for a deferred constant. + return; + end if; + Obj1 := Get_Deferred_Declaration (Obj); + if Obj1 = Null_Iir then + Obj1 := Obj; + end if; + else + Obj1 := Obj; + end if; + + New_Debug_Line_Stmt (Get_Line_Number (Obj)); + + -- Still use the default value of the not deferred constant. + -- FIXME: what about composite types. + Value := Get_Default_Value (Obj); + Elab_Object_Value (Obj1, Value); + end Elab_Object; + + procedure Fini_Object (Obj : Iir) + is + Obj_Type : Iir; + Type_Info : Type_Info_Acc; + begin + Obj_Type := Get_Type (Obj); + Type_Info := Get_Info (Obj_Type); + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + declare + V : Mnode; + begin + Open_Temp; + V := Chap6.Translate_Name (Obj); + Stabilize (V); + Chap3.Gen_Deallocate + (New_Value (M2Lp (Chap3.Get_Array_Bounds (V)))); + Chap3.Gen_Deallocate + (New_Value (M2Lp (Chap3.Get_Array_Base (V)))); + Close_Temp; + end; + elsif Is_Complex_Type (Type_Info) then + Chap3.Gen_Deallocate + (New_Value (M2Lp (Chap6.Translate_Name (Obj)))); + end if; + end Fini_Object; + + function Get_Nbr_Signals (Sig : Mnode; Sig_Type : Iir) return O_Enode + is + Info : constant Type_Info_Acc := Get_Info (Sig_Type); + begin + case Info.Type_Mode is + when Type_Mode_Scalar => + -- Note: here we discard SIG... + return New_Lit (Ghdl_Index_1); + when Type_Mode_Arrays => + declare + Len : O_Dnode; + If_Blk : O_If_Block; + Ssig : Mnode; + begin + Ssig := Stabilize (Sig); + Len := Create_Temp_Init + (Ghdl_Index_Type, + Chap3.Get_Array_Length (Ssig, Sig_Type)); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Neq, + New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Len), + New_Dyadic_Op + (ON_Mul_Ov, + New_Obj_Value (Len), + Get_Nbr_Signals + (Chap3.Index_Base + (Chap3.Get_Array_Base (Ssig), Sig_Type, + New_Lit (Ghdl_Index_0)), + Get_Element_Subtype (Sig_Type)))); + Finish_If_Stmt (If_Blk); + + return New_Obj_Value (Len); + end; + when Type_Mode_Record => + declare + List : Iir_List; + El : Iir; + Res : O_Enode; + E : O_Enode; + Sig_El : Mnode; + Ssig : Mnode; + begin + List := + Get_Elements_Declaration_List (Get_Base_Type (Sig_Type)); + Ssig := Stabilize (Sig); + Res := O_Enode_Null; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Sig_El := Chap6.Translate_Selected_Element (Ssig, El); + E := Get_Nbr_Signals (Sig_El, Get_Type (El)); + if Res /= O_Enode_Null then + Res := New_Dyadic_Op (ON_Add_Ov, Res, E); + else + Res := E; + end if; + end loop; + if Res = O_Enode_Null then + -- Empty records. + Res := New_Lit (Ghdl_Index_0); + end if; + return Res; + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Get_Nbr_Signals; + + -- Get the leftest signal of SIG. + -- The leftest signal of + -- a scalar signal is itself, + -- an array signal is the leftest, + -- a record signal is the first element. + function Get_Leftest_Signal (Sig: Mnode; Sig_Type : Iir) + return Mnode + is + Res : Mnode; + Res_Type : Iir; + Info : Type_Info_Acc; + begin + Res := Sig; + Res_Type := Sig_Type; + loop + Info := Get_Type_Info (Res); + case Info.Type_Mode is + when Type_Mode_Scalar => + return Res; + when Type_Mode_Arrays => + Res := Chap3.Index_Base + (Chap3.Get_Array_Base (Res), Res_Type, + New_Lit (Ghdl_Index_0)); + Res_Type := Get_Element_Subtype (Res_Type); + when Type_Mode_Record => + declare + Element : Iir; + begin + Element := Get_First_Element + (Get_Elements_Declaration_List + (Get_Base_Type (Res_Type))); + Res := Chap6.Translate_Selected_Element (Res, Element); + Res_Type := Get_Type (Element); + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end loop; + end Get_Leftest_Signal; + + -- Add func and instance. + procedure Add_Associations_For_Resolver + (Assoc : in out O_Assoc_List; Func_Decl : Iir) + is + Func_Info : constant Subprg_Info_Acc := Get_Info (Func_Decl); + Resolv_Info : constant Subprg_Resolv_Info_Acc := + Func_Info.Subprg_Resolv; + Val : O_Enode; + begin + New_Association + (Assoc, New_Lit (New_Subprogram_Address (Resolv_Info.Resolv_Func, + Ghdl_Ptr_Type))); + if Chap2.Has_Subprg_Instance (Resolv_Info.Var_Instance) then + Val := New_Convert_Ov + (Chap2.Get_Subprg_Instance (Resolv_Info.Var_Instance), + Ghdl_Ptr_Type); + else + Val := New_Lit (New_Null_Access (Ghdl_Ptr_Type)); + end if; + New_Association (Assoc, Val); + end Add_Associations_For_Resolver; + + type O_If_Block_Acc is access O_If_Block; + + type Elab_Signal_Data is record + -- Default value of the signal. + Val : Mnode; + -- If statement for a block of signals. + If_Stmt : O_If_Block_Acc; + -- True if the default value is set. + Has_Val : Boolean; + -- True if a resolution function was already attached. + Already_Resolved : Boolean; + -- True if the signal may already have been created. + Check_Null : Boolean; + end record; + + procedure Elab_Signal_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Elab_Signal_Data) + is + Type_Info : constant Type_Info_Acc := Get_Info (Targ_Type); + Create_Subprg : O_Dnode; + Conv : O_Tnode; + Res : O_Enode; + Assoc : O_Assoc_List; + Init_Val : O_Enode; + -- For the resolution function (if any). + Func : Iir; + If_Stmt : O_If_Block; + Targ_Ptr : O_Dnode; + begin + if Data.Check_Null then + Targ_Ptr := Create_Temp_Init + (Ghdl_Signal_Ptr_Ptr, + New_Unchecked_Address (M2Lv (Targ), Ghdl_Signal_Ptr_Ptr)); + Start_If_Stmt + (If_Stmt, + New_Compare_Op (ON_Eq, + New_Value (New_Acc_Value (New_Obj (Targ_Ptr))), + New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), + Ghdl_Bool_Type)); + end if; + + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Create_Subprg := Ghdl_Create_Signal_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Create_Subprg := Ghdl_Create_Signal_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Create_Subprg := Ghdl_Create_Signal_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Create_Subprg := Ghdl_Create_Signal_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Create_Subprg := Ghdl_Create_Signal_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Create_Subprg := Ghdl_Create_Signal_F64; + Conv := Ghdl_Real_Type; + when others => + Error_Kind ("elab_signal_non_composite", Targ_Type); + end case; + + if Data.Has_Val then + Init_Val := M2E (Data.Val); + else + Init_Val := Chap14.Translate_Left_Type_Attribute (Targ_Type); + end if; + + Start_Association (Assoc, Create_Subprg); + New_Association (Assoc, New_Convert_Ov (Init_Val, Conv)); + + if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then + Func := Has_Resolution_Function (Targ_Type); + else + Func := Null_Iir; + end if; + if Func /= Null_Iir and then not Data.Already_Resolved then + Add_Associations_For_Resolver (Assoc, Func); + else + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + end if; + + Res := New_Function_Call (Assoc); + + if Data.Check_Null then + New_Assign_Stmt (New_Acc_Value (New_Obj (Targ_Ptr)), Res); + Finish_If_Stmt (If_Stmt); + else + New_Assign_Stmt + (M2Lv (Targ), + New_Convert_Ov (Res, Type_Info.Ortho_Type (Mode_Signal))); + end if; + end Elab_Signal_Non_Composite; + + function Elab_Signal_Prepare_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Elab_Signal_Data) + return Elab_Signal_Data + is + Assoc : O_Assoc_List; + Func : Iir; + Res : Elab_Signal_Data; + begin + Res := Data; + if Get_Kind (Targ_Type) in Iir_Kinds_Subtype_Definition then + Func := Has_Resolution_Function (Targ_Type); + if Func /= Null_Iir and then not Data.Already_Resolved then + if Data.Check_Null then + Res.If_Stmt := new O_If_Block; + Start_If_Stmt + (Res.If_Stmt.all, + New_Compare_Op + (ON_Eq, + New_Convert_Ov (M2E (Get_Leftest_Signal (Targ, + Targ_Type)), + Ghdl_Signal_Ptr), + New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), + Ghdl_Bool_Type)); + --Res.Check_Null := False; + end if; + -- Add resolver. + Start_Association (Assoc, Ghdl_Signal_Create_Resolution); + Add_Associations_For_Resolver (Assoc, Func); + New_Association + (Assoc, New_Convert_Ov (M2Addr (Targ), Ghdl_Ptr_Type)); + New_Association (Assoc, Get_Nbr_Signals (Targ, Targ_Type)); + New_Procedure_Call (Assoc); + Res.Already_Resolved := True; + end if; + end if; + if Data.Has_Val then + if Get_Type_Info (Data.Val).Type_Mode = Type_Mode_Record then + Res.Val := Stabilize (Data.Val); + else + Res.Val := Chap3.Get_Array_Base (Data.Val); + end if; + end if; + return Res; + end Elab_Signal_Prepare_Composite; + + procedure Elab_Signal_Finish_Composite (Data : in out Elab_Signal_Data) + is + procedure Free is new Ada.Unchecked_Deallocation + (Object => O_If_Block, Name => O_If_Block_Acc); + begin + if Data.If_Stmt /= null then + Finish_If_Stmt (Data.If_Stmt.all); + Free (Data.If_Stmt); + end if; + end Elab_Signal_Finish_Composite; + + function Elab_Signal_Update_Array (Data : Elab_Signal_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Elab_Signal_Data + is + begin + if not Data.Has_Val then + return Data; + else + return Elab_Signal_Data' + (Val => Chap3.Index_Base (Data.Val, Targ_Type, + New_Obj_Value (Index)), + Has_Val => True, + If_Stmt => null, + Already_Resolved => Data.Already_Resolved, + Check_Null => Data.Check_Null); + end if; + end Elab_Signal_Update_Array; + + function Elab_Signal_Update_Record (Data : Elab_Signal_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Elab_Signal_Data + is + pragma Unreferenced (Targ_Type); + begin + if not Data.Has_Val then + return Data; + else + return Elab_Signal_Data' + (Val => Chap6.Translate_Selected_Element (Data.Val, El), + Has_Val => True, + If_Stmt => null, + Already_Resolved => Data.Already_Resolved, + Check_Null => Data.Check_Null); + end if; + end Elab_Signal_Update_Record; + + procedure Elab_Signal is new Foreach_Non_Composite + (Data_Type => Elab_Signal_Data, + Composite_Data_Type => Elab_Signal_Data, + Do_Non_Composite => Elab_Signal_Non_Composite, + Prepare_Data_Array => Elab_Signal_Prepare_Composite, + Update_Data_Array => Elab_Signal_Update_Array, + Finish_Data_Array => Elab_Signal_Finish_Composite, + Prepare_Data_Record => Elab_Signal_Prepare_Composite, + Update_Data_Record => Elab_Signal_Update_Record, + Finish_Data_Record => Elab_Signal_Finish_Composite); + + -- Elaborate signal subtypes and allocate the storage for the object. + procedure Elab_Signal_Declaration_Storage (Decl : Iir) + is + Sig_Type : Iir; + Type_Info : Type_Info_Acc; + Name_Node : Mnode; + begin + New_Debug_Line_Stmt (Get_Line_Number (Decl)); + + Open_Temp; + + Sig_Type := Get_Type (Decl); + Chap3.Elab_Object_Subtype (Sig_Type); + Type_Info := Get_Info (Sig_Type); + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + Name_Node := Chap6.Translate_Name (Decl); + Name_Node := Stabilize (Name_Node); + Chap3.Allocate_Fat_Array_Base (Alloc_System, Name_Node, Sig_Type); + elsif Is_Complex_Type (Type_Info) then + Name_Node := Chap6.Translate_Name (Decl); + Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); + end if; + + Close_Temp; + end Elab_Signal_Declaration_Storage; + + function Has_Direct_Driver (Sig : Iir) return Boolean + is + Info : Ortho_Info_Acc; + begin + Info := Get_Info (Get_Object_Prefix (Sig)); + return Info.Kind = Kind_Object + and then Info.Object_Driver /= Null_Var; + end Has_Direct_Driver; + + procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir) + is + Sig_Type : constant Iir := Get_Type (Decl); + Sig_Info : constant Ortho_Info_Acc := Get_Info (Decl); + Type_Info : constant Type_Info_Acc := Get_Info (Sig_Type); + Name_Node : Mnode; + begin + Open_Temp; + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + Name_Node := Get_Var (Sig_Info.Object_Driver, + Type_Info, Mode_Value); + Name_Node := Stabilize (Name_Node); + -- Copy bounds from signal. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Name_Node)), + M2Addr (Chap3.Get_Array_Bounds (Chap6.Translate_Name (Decl)))); + -- Allocate base. + Chap3.Allocate_Fat_Array_Base (Alloc_System, Name_Node, Sig_Type); + elsif Is_Complex_Type (Type_Info) then + Name_Node := Get_Var (Sig_Info.Object_Driver, + Type_Info, Mode_Value); + Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); + end if; + + Close_Temp; + end Elab_Direct_Driver_Declaration_Storage; + + -- Create signal object. + -- Note: SIG can be a signal sub-element (used when signals are + -- collapsed). + -- If CHECK_NULL is TRUE, create the signal only if it was not yet + -- created. + procedure Elab_Signal_Declaration_Object + (Sig : Iir; Parent : Iir; Check_Null : Boolean) + is + Decl : constant Iir := Strip_Denoting_Name (Sig); + Sig_Type : constant Iir := Get_Type (Sig); + Base_Decl : constant Iir := Get_Object_Prefix (Sig); + Name_Node : Mnode; + Val : Iir; + Data : Elab_Signal_Data; + begin + New_Debug_Line_Stmt (Get_Line_Number (Sig)); + + Open_Temp; + + -- Set the name of the signal. + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Signal_Name_Rti); + New_Association + (Assoc, + New_Lit (New_Global_Unchecked_Address + (Get_Info (Base_Decl).Object_Rti, + Rtis.Ghdl_Rti_Access))); + Rtis.Associate_Rti_Context (Assoc, Parent); + New_Procedure_Call (Assoc); + end; + + Name_Node := Chap6.Translate_Name (Decl); + if Get_Object_Kind (Name_Node) /= Mode_Signal then + raise Internal_Error; + end if; + + if Decl = Base_Decl then + Data.Already_Resolved := False; + Data.Check_Null := Check_Null; + Val := Get_Default_Value (Base_Decl); + if Val = Null_Iir then + Data.Has_Val := False; + else + Data.Has_Val := True; + Data.Val := E2M (Chap7.Translate_Expression (Val, Sig_Type), + Get_Info (Sig_Type), + Mode_Value); + end if; + else + -- Sub signal. + -- Do not add resolver. + -- Do not use default value. + Data.Already_Resolved := True; + Data.Has_Val := False; + Data.Check_Null := False; + end if; + Elab_Signal (Name_Node, Sig_Type, Data); + + Close_Temp; + end Elab_Signal_Declaration_Object; + + procedure Elab_Signal_Declaration + (Decl : Iir; Parent : Iir; Check_Null : Boolean) + is + begin + Elab_Signal_Declaration_Storage (Decl); + Elab_Signal_Declaration_Object (Decl, Parent, Check_Null); + end Elab_Signal_Declaration; + + procedure Elab_Signal_Attribute (Decl : Iir) + is + Assoc : O_Assoc_List; + Dtype : Iir; + Type_Info : Type_Info_Acc; + Info : Object_Info_Acc; + Prefix : Iir; + Prefix_Node : Mnode; + Res : O_Enode; + Val : O_Enode; + Param : Iir; + Subprg : O_Dnode; + begin + New_Debug_Line_Stmt (Get_Line_Number (Decl)); + + Info := Get_Info (Decl); + Dtype := Get_Type (Decl); + Type_Info := Get_Info (Dtype); + -- Create the signal (with the time) + case Get_Kind (Decl) is + when Iir_Kind_Stable_Attribute => + Subprg := Ghdl_Create_Stable_Signal; + when Iir_Kind_Quiet_Attribute => + Subprg := Ghdl_Create_Quiet_Signal; + when Iir_Kind_Transaction_Attribute => + Subprg := Ghdl_Create_Transaction_Signal; + when others => + Error_Kind ("elab_signal_attribute", Decl); + end case; + Start_Association (Assoc, Subprg); + case Get_Kind (Decl) is + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute => + Param := Get_Parameter (Decl); + if Param = Null_Iir then + Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0)); + else + Val := Chap7.Translate_Expression (Param); + end if; + New_Association (Assoc, Val); + when others => + null; + end case; + Res := New_Convert_Ov (New_Function_Call (Assoc), + Type_Info.Ortho_Type (Mode_Signal)); + New_Assign_Stmt (Get_Var (Info.Object_Var), Res); + + -- Register all signals this depends on. + Prefix := Get_Prefix (Decl); + Prefix_Node := Chap6.Translate_Name (Prefix); + Register_Signal (Prefix_Node, Get_Type (Prefix), + Ghdl_Signal_Attribute_Register_Prefix); + end Elab_Signal_Attribute; + + type Delayed_Signal_Data is record + Pfx : Mnode; + Param : Iir; + end record; + + procedure Create_Delayed_Signal_Noncomposite + (Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data) + is + pragma Unreferenced (Targ_Type); + Assoc : O_Assoc_List; + Type_Info : Type_Info_Acc; + Val : O_Enode; + begin + Start_Association (Assoc, Ghdl_Create_Delayed_Signal); + New_Association + (Assoc, + New_Convert_Ov (New_Value (M2Lv (Data.Pfx)), Ghdl_Signal_Ptr)); + if Data.Param = Null_Iir then + Val := New_Lit (New_Signed_Literal (Std_Time_Otype, 0)); + else + Val := Chap7.Translate_Expression (Data.Param); + end if; + New_Association (Assoc, Val); + Type_Info := Get_Type_Info (Targ); + New_Assign_Stmt + (M2Lv (Targ), + New_Convert_Ov (New_Function_Call (Assoc), + Type_Info.Ortho_Type (Mode_Signal))); + end Create_Delayed_Signal_Noncomposite; + + function Create_Delayed_Signal_Prepare_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Delayed_Signal_Data) + return Delayed_Signal_Data + is + pragma Unreferenced (Targ_Type); + Res : Delayed_Signal_Data; + begin + Res.Param := Data.Param; + if Get_Type_Info (Targ).Type_Mode = Type_Mode_Record then + Res.Pfx := Stabilize (Data.Pfx); + else + Res.Pfx := Chap3.Get_Array_Base (Data.Pfx); + end if; + return Res; + end Create_Delayed_Signal_Prepare_Composite; + + function Create_Delayed_Signal_Update_Data_Array + (Data : Delayed_Signal_Data; Targ_Type : Iir; Index : O_Dnode) + return Delayed_Signal_Data + is + begin + return Delayed_Signal_Data' + (Pfx => Chap3.Index_Base (Data.Pfx, Targ_Type, + New_Obj_Value (Index)), + Param => Data.Param); + end Create_Delayed_Signal_Update_Data_Array; + + function Create_Delayed_Signal_Update_Data_Record + (Data : Delayed_Signal_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Delayed_Signal_Data + is + pragma Unreferenced (Targ_Type); + begin + return Delayed_Signal_Data' + (Pfx => Chap6.Translate_Selected_Element (Data.Pfx, El), + Param => Data.Param); + end Create_Delayed_Signal_Update_Data_Record; + + procedure Create_Delayed_Signal_Finish_Data_Composite + (Data : in out Delayed_Signal_Data) + is + pragma Unreferenced (Data); + begin + null; + end Create_Delayed_Signal_Finish_Data_Composite; + + procedure Create_Delayed_Signal is new Foreach_Non_Composite + (Data_Type => Delayed_Signal_Data, + Composite_Data_Type => Delayed_Signal_Data, + Do_Non_Composite => Create_Delayed_Signal_Noncomposite, + Prepare_Data_Array => Create_Delayed_Signal_Prepare_Composite, + Update_Data_Array => Create_Delayed_Signal_Update_Data_Array, + Finish_Data_Array => Create_Delayed_Signal_Finish_Data_Composite, + Prepare_Data_Record => Create_Delayed_Signal_Prepare_Composite, + Update_Data_Record => Create_Delayed_Signal_Update_Data_Record, + Finish_Data_Record => Create_Delayed_Signal_Finish_Data_Composite); + + procedure Elab_Signal_Delayed_Attribute (Decl : Iir) + is + Name_Node : Mnode; + Sig_Type : Iir; + Type_Info : Type_Info_Acc; + Pfx_Node : Mnode; + Data: Delayed_Signal_Data; + begin + Name_Node := Chap6.Translate_Name (Decl); + Sig_Type := Get_Type (Decl); + Type_Info := Get_Info (Sig_Type); + + if Is_Complex_Type (Type_Info) then + Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); + -- We cannot stabilize NAME_NODE, since Allocate_Complex_Object + -- assign it. + Name_Node := Chap6.Translate_Name (Decl); + end if; + + Pfx_Node := Chap6.Translate_Name (Get_Prefix (Decl)); + Data := Delayed_Signal_Data'(Pfx => Pfx_Node, + Param => Get_Parameter (Decl)); + + Create_Delayed_Signal (Name_Node, Get_Type (Decl), Data); + end Elab_Signal_Delayed_Attribute; + + procedure Elab_File_Declaration (Decl : Iir_File_Declaration) + is + Constr : O_Assoc_List; + Name : Mnode; + File_Name : Iir; + Open_Kind : Iir; + Mode_Val : O_Enode; + Str : O_Enode; + Is_Text : Boolean; + Info : Type_Info_Acc; + begin + -- Elaborate the file. + Name := Chap6.Translate_Name (Decl); + if Get_Object_Kind (Name) /= Mode_Value then + raise Internal_Error; + end if; + Is_Text := Get_Text_File_Flag (Get_Type (Decl)); + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Elaborate); + else + Start_Association (Constr, Ghdl_File_Elaborate); + Info := Get_Info (Get_Type (Decl)); + if Info.T.File_Signature /= O_Dnode_Null then + New_Association + (Constr, New_Address (New_Obj (Info.T.File_Signature), + Char_Ptr_Type)); + else + New_Association (Constr, + New_Lit (New_Null_Access (Char_Ptr_Type))); + end if; + end if; + New_Assign_Stmt (M2Lv (Name), New_Function_Call (Constr)); + + -- If file_open_information is present, open the file. + File_Name := Get_File_Logical_Name (Decl); + if File_Name = Null_Iir then + return; + end if; + Open_Temp; + Name := Chap6.Translate_Name (Decl); + Open_Kind := Get_File_Open_Kind (Decl); + if Open_Kind /= Null_Iir then + Mode_Val := New_Convert_Ov + (Chap7.Translate_Expression (Open_Kind), Ghdl_I32_Type); + else + case Get_Mode (Decl) is + when Iir_In_Mode => + Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0)); + when Iir_Out_Mode => + Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 1)); + when others => + raise Internal_Error; + end case; + end if; + Str := Chap7.Translate_Expression (File_Name, String_Type_Definition); + + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Open); + else + Start_Association (Constr, Ghdl_File_Open); + end if; + New_Association (Constr, M2E (Name)); + New_Association (Constr, Mode_Val); + New_Association (Constr, Str); + New_Procedure_Call (Constr); + Close_Temp; + end Elab_File_Declaration; + + procedure Final_File_Declaration (Decl : Iir_File_Declaration) + is + Constr : O_Assoc_List; + Name : Mnode; + Is_Text : Boolean; + begin + Is_Text := Get_Text_File_Flag (Get_Type (Decl)); + + Open_Temp; + Name := Chap6.Translate_Name (Decl); + Stabilize (Name); + + -- LRM 3.4.1 File Operations + -- An implicit call to FILE_CLOSE exists in a subprogram body for + -- every file object declared in the corresponding subprogram + -- declarative part. Each such call associates a unique file object + -- with the formal parameter F and is called whenever the + -- corresponding subprogram completes its execution. + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Close); + else + Start_Association (Constr, Ghdl_File_Close); + end if; + New_Association (Constr, M2E (Name)); + New_Procedure_Call (Constr); + + if Is_Text then + Start_Association (Constr, Ghdl_Text_File_Finalize); + else + Start_Association (Constr, Ghdl_File_Finalize); + end if; + New_Association (Constr, M2E (Name)); + New_Procedure_Call (Constr); + + Close_Temp; + end Final_File_Declaration; + + procedure Translate_Type_Declaration (Decl : Iir) + is + begin + Chap3.Translate_Named_Type_Definition (Get_Type_Definition (Decl), + Get_Identifier (Decl)); + end Translate_Type_Declaration; + + procedure Translate_Anonymous_Type_Declaration (Decl : Iir) + is + Mark : Id_Mark_Type; + Mark1 : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Push_Identifier_Prefix (Mark1, "BT"); + Chap3.Translate_Type_Definition (Get_Type_Definition (Decl)); + Pop_Identifier_Prefix (Mark1); + Pop_Identifier_Prefix (Mark); + end Translate_Anonymous_Type_Declaration; + + procedure Translate_Subtype_Declaration (Decl : Iir_Subtype_Declaration) + is + begin + Chap3.Translate_Named_Type_Definition (Get_Type (Decl), + Get_Identifier (Decl)); + end Translate_Subtype_Declaration; + + procedure Translate_Bool_Type_Declaration (Decl : Iir_Type_Declaration) + is + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Chap3.Translate_Bool_Type_Definition (Get_Type_Definition (Decl)); + Pop_Identifier_Prefix (Mark); + end Translate_Bool_Type_Declaration; + + procedure Translate_Object_Alias_Declaration + (Decl : Iir_Object_Alias_Declaration) + is + Decl_Type : Iir; + Info : Alias_Info_Acc; + Tinfo : Type_Info_Acc; + Atype : O_Tnode; + begin + Decl_Type := Get_Type (Decl); + + Chap3.Translate_Named_Type_Definition + (Decl_Type, Get_Identifier (Decl)); + + Info := Add_Info (Decl, Kind_Alias); + case Get_Kind (Get_Object_Prefix (Decl)) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + Info.Alias_Kind := Mode_Signal; + when others => + Info.Alias_Kind := Mode_Value; + end case; + + Tinfo := Get_Info (Decl_Type); + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array => + -- create an object. + -- At elaboration: copy base from name, copy bounds from type, + -- check for matching bounds. + Atype := Get_Ortho_Type (Decl_Type, Info.Alias_Kind); + when Type_Mode_Array + | Type_Mode_Acc + | Type_Mode_Fat_Acc => + -- Create an object pointer. + -- At elaboration: copy base from name. + Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind); + when Type_Mode_Scalar => + case Info.Alias_Kind is + when Mode_Signal => + Atype := Tinfo.Ortho_Type (Mode_Signal); + when Mode_Value => + Atype := Tinfo.Ortho_Ptr_Type (Mode_Value); + end case; + when Type_Mode_Record => + -- Create an object pointer. + -- At elaboration: copy base from name. + Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind); + when others => + raise Internal_Error; + end case; + Info.Alias_Var := Create_Var (Create_Var_Identifier (Decl), Atype); + end Translate_Object_Alias_Declaration; + + procedure Elab_Object_Alias_Declaration + (Decl : Iir_Object_Alias_Declaration) + is + Decl_Type : Iir; + Name : Iir; + Name_Node : Mnode; + Alias_Node : Mnode; + Alias_Info : Alias_Info_Acc; + Name_Type : Iir; + Tinfo : Type_Info_Acc; + Kind : Object_Kind_Type; + begin + New_Debug_Line_Stmt (Get_Line_Number (Decl)); + + Decl_Type := Get_Type (Decl); + Tinfo := Get_Info (Decl_Type); + + Alias_Info := Get_Info (Decl); + Chap3.Elab_Object_Subtype (Decl_Type); + Name := Get_Name (Decl); + Name_Type := Get_Type (Name); + Name_Node := Chap6.Translate_Name (Name); + Kind := Get_Object_Kind (Name_Node); + + case Tinfo.Type_Mode is + when Type_Mode_Fat_Array => + Open_Temp; + Stabilize (Name_Node); + Alias_Node := Stabilize + (Get_Var (Alias_Info.Alias_Var, + Tinfo, Alias_Info.Alias_Kind)); + Copy_Fat_Pointer (Alias_Node, Name_Node); + Close_Temp; + when Type_Mode_Array => + Open_Temp; + Stabilize (Name_Node); + New_Assign_Stmt + (Get_Var (Alias_Info.Alias_Var), + M2E (Chap3.Get_Array_Base (Name_Node))); + Chap3.Check_Array_Match (Decl_Type, T2M (Decl_Type, Kind), + Name_Type, Name_Node, + Decl); + Close_Temp; + when Type_Mode_Acc + | Type_Mode_Fat_Acc => + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2Addr (Name_Node)); + when Type_Mode_Scalar => + case Alias_Info.Alias_Kind is + when Mode_Value => + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2Addr (Name_Node)); + when Mode_Signal => + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2E (Name_Node)); + end case; + when Type_Mode_Record => + Open_Temp; + Stabilize (Name_Node); + New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), + M2Addr (Name_Node)); + Close_Temp; + when others => + raise Internal_Error; + end case; + end Elab_Object_Alias_Declaration; + + procedure Translate_Port_Chain (Parent : Iir) + is + Port : Iir; + begin + Port := Get_Port_Chain (Parent); + while Port /= Null_Iir loop + Create_Signal (Port); + Port := Get_Chain (Port); + end loop; + end Translate_Port_Chain; + + procedure Translate_Generic_Chain (Parent : Iir) + is + Decl : Iir; + begin + Decl := Get_Generic_Chain (Parent); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kinds_Interface_Object_Declaration => + Create_Object (Decl); + when Iir_Kind_Interface_Package_Declaration => + Create_Package_Interface (Decl); + when others => + Error_Kind ("translate_generic_chain", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Translate_Generic_Chain; + + -- Create instance record for a component. + procedure Translate_Component_Declaration (Decl : Iir) + is + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Decl, Kind_Component); + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + Push_Instance_Factory (Info.Comp_Scope'Access); + + Info.Comp_Link := Add_Instance_Factory_Field + (Wki_Instance, Rtis.Ghdl_Component_Link_Type); + + -- Generic and ports. + Translate_Generic_Chain (Decl); + Translate_Port_Chain (Decl); + + Pop_Instance_Factory (Info.Comp_Scope'Access); + New_Type_Decl (Create_Identifier ("_COMPTYPE"), + Get_Scope_Type (Info.Comp_Scope)); + Info.Comp_Ptr_Type := New_Access_Type + (Get_Scope_Type (Info.Comp_Scope)); + New_Type_Decl (Create_Identifier ("_COMPPTR"), Info.Comp_Ptr_Type); + Pop_Identifier_Prefix (Mark); + end Translate_Component_Declaration; + + procedure Translate_Declaration (Decl : Iir) + is + begin + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Configuration_Specification => + null; + when Iir_Kind_Disconnection_Specification => + null; + + when Iir_Kind_Component_Declaration => + Chap4.Translate_Component_Declaration (Decl); + when Iir_Kind_Type_Declaration => + Chap4.Translate_Type_Declaration (Decl); + when Iir_Kind_Anonymous_Type_Declaration => + Chap4.Translate_Anonymous_Type_Declaration (Decl); + when Iir_Kind_Subtype_Declaration => + Chap4.Translate_Subtype_Declaration (Decl); + + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + raise Internal_Error; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + + when Iir_Kind_Protected_Type_Body => + null; + + --when Iir_Kind_Implicit_Function_Declaration => + --when Iir_Kind_Signal_Declaration + -- | Iir_Kind_Interface_Signal_Declaration => + -- Chap4.Create_Object (Decl); + + when Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration => + Create_Object (Decl); + + when Iir_Kind_Signal_Declaration => + Create_Signal (Decl); + + when Iir_Kind_Object_Alias_Declaration => + Translate_Object_Alias_Declaration (Decl); + + when Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_File_Declaration => + Create_File_Object (Decl); + + when Iir_Kind_Attribute_Declaration => + -- Useless as attribute declarations have a type mark. + Chap3.Translate_Object_Subtype (Decl); + + when Iir_Kind_Attribute_Specification => + Chap5.Translate_Attribute_Specification (Decl); + + when Iir_Kinds_Signal_Attribute => + Chap4.Create_Implicit_Signal (Decl); + + when Iir_Kind_Guard_Signal_Declaration => + Create_Signal (Decl); + + when Iir_Kind_Group_Template_Declaration => + null; + when Iir_Kind_Group_Declaration => + null; + + when others => + Error_Kind ("translate_declaration", Decl); + end case; + end Translate_Declaration; + + procedure Translate_Resolution_Function (Func : Iir) + is + -- Type of the resolution function parameter. + El_Type : Iir; + El_Info : Type_Info_Acc; + Finfo : constant Subprg_Info_Acc := Get_Info (Func); + Interface_List : O_Inter_List; + Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; + Id : O_Ident; + Itype : O_Tnode; + Unused_Instance : O_Dnode; + begin + if Rinfo = null then + -- Not a resolution function + return; + end if; + + -- Declare the procedure. + Id := Create_Identifier (Func, Get_Overload_Number (Func), "_RESOLV"); + Start_Procedure_Decl (Interface_List, Id, Global_Storage); + + -- The instance. + if Chap2.Has_Current_Subprg_Instance then + Chap2.Add_Subprg_Instance_Interfaces (Interface_List, + Rinfo.Var_Instance); + else + -- Create a dummy instance parameter + New_Interface_Decl (Interface_List, Unused_Instance, + Wki_Instance, Ghdl_Ptr_Type); + Rinfo.Var_Instance := Chap2.Null_Subprg_Instance; + end if; + + -- The signal. + El_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); + El_Type := Get_Element_Subtype (El_Type); + El_Info := Get_Info (El_Type); + -- FIXME: create a function for getting the type of an interface. + case El_Info.Type_Mode is + when Type_Mode_Thin => + Itype := El_Info.Ortho_Type (Mode_Signal); + when Type_Mode_Fat => + Itype := El_Info.Ortho_Ptr_Type (Mode_Signal); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + New_Interface_Decl + (Interface_List, Rinfo.Var_Vals, Get_Identifier ("VALS"), Itype); + + New_Interface_Decl + (Interface_List, Rinfo.Var_Vec, Get_Identifier ("bool_vec"), + Ghdl_Bool_Array_Ptr); + New_Interface_Decl + (Interface_List, Rinfo.Var_Vlen, Get_Identifier ("vec_len"), + Ghdl_Index_Type); + New_Interface_Decl + (Interface_List, Rinfo.Var_Nbr_Drv, Get_Identifier ("nbr_drv"), + Ghdl_Index_Type); + New_Interface_Decl + (Interface_List, Rinfo.Var_Nbr_Ports, Get_Identifier ("nbr_ports"), + Ghdl_Index_Type); + + Finish_Subprogram_Decl (Interface_List, Rinfo.Resolv_Func); + end Translate_Resolution_Function; + + type Read_Source_Kind is (Read_Port, Read_Driver); + type Read_Source_Data is record + Sig : Mnode; + Drv_Index : O_Dnode; + Kind : Read_Source_Kind; + end record; + + procedure Read_Source_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data) + is + Assoc : O_Assoc_List; + Targ_Info : Type_Info_Acc; + E : O_Enode; + begin + Targ_Info := Get_Info (Targ_Type); + case Data.Kind is + when Read_Port => + Start_Association (Assoc, Ghdl_Signal_Read_Port); + when Read_Driver => + Start_Association (Assoc, Ghdl_Signal_Read_Driver); + end case; + + New_Association + (Assoc, New_Convert_Ov (M2E (Data.Sig), Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.Drv_Index)); + E := New_Convert_Ov (New_Function_Call (Assoc), + Targ_Info.Ortho_Ptr_Type (Mode_Value)); + New_Assign_Stmt (M2Lv (Targ), + New_Value (New_Access_Element (E))); + end Read_Source_Non_Composite; + + function Read_Source_Prepare_Data_Array + (Targ: Mnode; Targ_Type : Iir; Data : Read_Source_Data) + return Read_Source_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Data; + end Read_Source_Prepare_Data_Array; + + function Read_Source_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data) + return Read_Source_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Read_Source_Data'(Sig => Stabilize (Data.Sig), + Drv_Index => Data.Drv_Index, + Kind => Data.Kind); + end Read_Source_Prepare_Data_Record; + + function Read_Source_Update_Data_Array + (Data : Read_Source_Data; Targ_Type : Iir; Index : O_Dnode) + return Read_Source_Data + is + begin + return Read_Source_Data' + (Sig => Chap3.Index_Base (Data.Sig, Targ_Type, + New_Obj_Value (Index)), + Drv_Index => Data.Drv_Index, + Kind => Data.Kind); + end Read_Source_Update_Data_Array; + + function Read_Source_Update_Data_Record + (Data : Read_Source_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Read_Source_Data + is + pragma Unreferenced (Targ_Type); + begin + return Read_Source_Data' + (Sig => Chap6.Translate_Selected_Element (Data.Sig, El), + Drv_Index => Data.Drv_Index, + Kind => Data.Kind); + end Read_Source_Update_Data_Record; + + procedure Read_Source_Finish_Data_Composite + (Data : in out Read_Source_Data) + is + pragma Unreferenced (Data); + begin + null; + end Read_Source_Finish_Data_Composite; + + procedure Read_Signal_Source is new Foreach_Non_Composite + (Data_Type => Read_Source_Data, + Composite_Data_Type => Read_Source_Data, + Do_Non_Composite => Read_Source_Non_Composite, + Prepare_Data_Array => Read_Source_Prepare_Data_Array, + Update_Data_Array => Read_Source_Update_Data_Array, + Finish_Data_Array => Read_Source_Finish_Data_Composite, + Prepare_Data_Record => Read_Source_Prepare_Data_Record, + Update_Data_Record => Read_Source_Update_Data_Record, + Finish_Data_Record => Read_Source_Finish_Data_Composite); + + procedure Translate_Resolution_Function_Body (Func : Iir) + is + -- Type of the resolution function parameter. + Arr_Type : Iir; + Base_Type : Iir; + Base_Info : Type_Info_Acc; + Index_Info : Index_Info_Acc; + + -- Type of parameter element. + El_Type : Iir; + El_Info : Type_Info_Acc; + + -- Type of the function return value. + Ret_Type : Iir; + Ret_Info : Type_Info_Acc; + + -- Type and info of the array index. + Index_Type : Iir; + Index_Tinfo : Type_Info_Acc; + + -- Local variables. + Var_I : O_Dnode; + Var_J : O_Dnode; + Var_Length : O_Dnode; + Var_Res : O_Dnode; + + Vals : Mnode; + Res : Mnode; + + If_Blk : O_If_Block; + Label : O_Snode; + + V : Mnode; + + Var_Bound : O_Dnode; + Var_Range_Ptr : O_Dnode; + Var_Array : O_Dnode; + Finfo : constant Subprg_Info_Acc := Get_Info (Func); + Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; + Assoc : O_Assoc_List; + + Data : Read_Source_Data; + begin + if Rinfo = null then + -- No resolver for this function + return; + end if; + + Ret_Type := Get_Return_Type (Func); + Ret_Info := Get_Info (Ret_Type); + + Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); + Base_Type := Get_Base_Type (Arr_Type); + Index_Info := Get_Info + (Get_First_Element (Get_Index_Subtype_Definition_List (Base_Type))); + Base_Info := Get_Info (Base_Type); + + El_Type := Get_Element_Subtype (Arr_Type); + El_Info := Get_Info (El_Type); + + Index_Type := Get_Index_Type (Arr_Type, 0); + Index_Tinfo := Get_Info (Index_Type); + + Start_Subprogram_Body (Rinfo.Resolv_Func); + if Chap2.Has_Subprg_Instance (Rinfo.Var_Instance) then + Chap2.Start_Subprg_Instance_Use (Rinfo.Var_Instance); + end if; + Push_Local_Factory; + + -- A signal. + + New_Var_Decl + (Var_Res, Get_Identifier ("res"), + O_Storage_Local, Get_Object_Type (Ret_Info, Mode_Value)); + + -- I, J. + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_J, Get_Identifier ("J"), + O_Storage_Local, Ghdl_Index_Type); + + -- Length. + New_Var_Decl + (Var_Length, Wki_Length, O_Storage_Local, Ghdl_Index_Type); + + New_Var_Decl (Var_Bound, Get_Identifier ("BOUND"), O_Storage_Local, + Base_Info.T.Bounds_Type); + New_Var_Decl (Var_Array, Get_Identifier ("ARRAY"), O_Storage_Local, + Base_Info.Ortho_Type (Mode_Value)); + + New_Var_Decl (Var_Range_Ptr, Get_Identifier ("RANGE_PTR"), + O_Storage_Local, Index_Tinfo.T.Range_Ptr_Type); + + Open_Temp; + + case El_Info.Type_Mode is + when Type_Mode_Thin => + Vals := Dv2M (Rinfo.Var_Vals, El_Info, Mode_Signal); + when Type_Mode_Fat => + Vals := Dp2M (Rinfo.Var_Vals, El_Info, Mode_Signal); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + + -- * length := vec_len + nports; + New_Assign_Stmt (New_Obj (Var_Length), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Rinfo.Var_Vlen), + New_Obj_Value (Rinfo.Var_Nbr_Ports))); + + -- * range_ptr := BOUND.dim_1'address; + New_Assign_Stmt + (New_Obj (Var_Range_Ptr), + New_Address (New_Selected_Element (New_Obj (Var_Bound), + Index_Info.Index_Field), + Index_Tinfo.T.Range_Ptr_Type)); + + -- Create range from length + Chap3.Create_Range_From_Length + (Index_Type, Var_Length, Var_Range_Ptr, Func); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Var_Array), + Base_Info.T.Bounds_Field (Mode_Value)), + New_Address (New_Obj (Var_Bound), Base_Info.T.Bounds_Ptr_Type)); + + -- Allocate the array. + Chap3.Allocate_Fat_Array_Base + (Alloc_Stack, Dv2M (Var_Array, Base_Info, Mode_Value), Base_Type); + + -- Fill the array + -- 1. From ports. + -- * I := 0; + Init_Var (Var_I); + -- * loop + Start_Loop_Stmt (Label); + -- * exit when I = nports; + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Obj_Value (Rinfo.Var_Nbr_Ports), + Ghdl_Bool_Type)); + -- fill array[i] + V := Chap3.Index_Base + (Chap3.Get_Array_Base (Dv2M (Var_Array, Base_Info, Mode_Value)), + Base_Type, New_Obj_Value (Var_I)); + Data := Read_Source_Data'(Vals, Var_I, Read_Port); + Read_Signal_Source (V, El_Type, Data); + + -- * I := I + 1; + Inc_Var (Var_I); + -- * end loop; + Finish_Loop_Stmt (Label); + + -- 2. From drivers. + -- * J := 0; + -- * loop + -- * exit when j = var_max; + -- * if vec[j] then + -- + -- * ptr := get_signal_driver (sig, j); + -- * array[i].XXX := *ptr + -- + -- * i := i + 1; + -- * end if; + -- * J := J + 1; + -- * end loop; + Init_Var (Var_J); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_J), + New_Obj_Value (Rinfo.Var_Nbr_Drv), + Ghdl_Bool_Type)); + Start_If_Stmt + (If_Blk, + New_Value (New_Indexed_Acc_Value (New_Obj (Rinfo.Var_Vec), + New_Obj_Value (Var_J)))); + + V := Chap3.Index_Base + (Chap3.Get_Array_Base (Dv2M (Var_Array, Base_Info, Mode_Value)), + Base_Type, New_Obj_Value (Var_I)); + Data := Read_Source_Data'(Vals, Var_J, Read_Driver); + Read_Signal_Source (V, El_Type, Data); + + Inc_Var (Var_I); + Finish_If_Stmt (If_Blk); + + Inc_Var (Var_J); + Finish_Loop_Stmt (Label); + + if Finfo.Res_Interface /= O_Dnode_Null then + Res := Lo2M (Var_Res, Ret_Info, Mode_Value); + if Ret_Info.Type_Mode /= Type_Mode_Fat_Array then + Allocate_Complex_Object (Ret_Type, Alloc_Stack, Res); + end if; + end if; + + -- Call the resolution function. + if Finfo.Use_Stack2 then + Create_Temp_Stack2_Mark; + end if; + + Start_Association (Assoc, Finfo.Ortho_Func); + if Finfo.Res_Interface /= O_Dnode_Null then + New_Association (Assoc, M2E (Res)); + end if; + Chap2.Add_Subprg_Instance_Assoc (Assoc, Finfo.Subprg_Instance); + New_Association + (Assoc, New_Address (New_Obj (Var_Array), + Base_Info.Ortho_Ptr_Type (Mode_Value))); + + if Finfo.Res_Interface = O_Dnode_Null then + Res := E2M (New_Function_Call (Assoc), Ret_Info, Mode_Value); + else + New_Procedure_Call (Assoc); + end if; + + if El_Type /= Ret_Type then + Res := E2M + (Chap7.Translate_Implicit_Conv (M2E (Res), Ret_Type, El_Type, + Mode_Value, Func), + El_Info, Mode_Value); + end if; + Chap7.Set_Driving_Value (Vals, El_Type, Res); + + Close_Temp; + Pop_Local_Factory; + if Chap2.Has_Subprg_Instance (Rinfo.Var_Instance) then + Chap2.Finish_Subprg_Instance_Use (Rinfo.Var_Instance); + end if; + Finish_Subprogram_Body; + end Translate_Resolution_Function_Body; + + procedure Translate_Declaration_Chain (Parent : Iir) + is + Info : Subprg_Info_Acc; + El : Iir; + begin + El := Get_Declaration_Chain (Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + -- Translate interfaces. + if (not Flag_Discard_Unused or else Get_Use_Flag (El)) + and then not Is_Second_Subprogram_Specification (El) + then + Info := Add_Info (El, Kind_Subprg); + Chap2.Translate_Subprogram_Interfaces (El); + if Get_Kind (El) = Iir_Kind_Function_Declaration then + if Get_Resolution_Function_Flag (El) then + Info.Subprg_Resolv := new Subprg_Resolv_Info; + end if; + end if; + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + null; + when others => + Translate_Declaration (El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Declaration_Chain; + + procedure Translate_Declaration_Chain_Subprograms (Parent : Iir) + is + El : Iir; + Infos : Chap7.Implicit_Subprogram_Infos; + begin + El := Get_Declaration_Chain (Parent); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + -- Translate only if used. + if Get_Info (El) /= null then + Chap2.Translate_Subprogram_Declaration (El); + Translate_Resolution_Function (El); + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + -- Do not translate body if generating only specs (for + -- subprograms in an entity). + if Global_Storage /= O_Storage_External + and then + (not Flag_Discard_Unused + or else + Get_Use_Flag (Get_Subprogram_Specification (El))) + then + Chap2.Translate_Subprogram_Body (El); + Translate_Resolution_Function_Body + (Get_Subprogram_Specification (El)); + end if; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Chap3.Translate_Type_Subprograms (El); + Chap7.Init_Implicit_Subprogram_Infos (Infos); + when Iir_Kind_Protected_Type_Body => + Chap3.Translate_Protected_Type_Body (El); + Chap3.Translate_Protected_Type_Body_Subprograms (El); + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + if Flag_Discard_Unused_Implicit + and then not Get_Use_Flag (El) + 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. + Chap7.Translate_Implicit_Subprogram (El, Infos); + when others => + null; + end case; + else + Chap7.Translate_Implicit_Subprogram (El, Infos); + end if; + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Translate_Declaration_Chain_Subprograms; + + procedure Elab_Declaration_Chain (Parent : Iir; Need_Final : out Boolean) + is + Decl : Iir; + begin + Decl := Get_Declaration_Chain (Parent); + Need_Final := False; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Component_Declaration => + null; + when Iir_Kind_Configuration_Specification => + null; + when Iir_Kind_Disconnection_Specification => + Chap5.Elab_Disconnection_Specification (Decl); + + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration => + Chap3.Elab_Type_Declaration (Decl); + when Iir_Kind_Subtype_Declaration => + Chap3.Elab_Subtype_Declaration (Decl); + + when Iir_Kind_Protected_Type_Body => + null; + + --when Iir_Kind_Signal_Declaration => + -- Chap1.Elab_Signal (Decl); + when Iir_Kind_Variable_Declaration + | Iir_Kind_Constant_Declaration => + Elab_Object (Decl); + if Get_Kind (Get_Type (Decl)) + = Iir_Kind_Protected_Type_Declaration + then + Need_Final := True; + end if; + + when Iir_Kind_Signal_Declaration => + Elab_Signal_Declaration (Decl, Parent, False); + + when Iir_Kind_Object_Alias_Declaration => + Elab_Object_Alias_Declaration (Decl); + + when Iir_Kind_Non_Object_Alias_Declaration => + null; + + when Iir_Kind_File_Declaration => + Elab_File_Declaration (Decl); + Need_Final := True; + + when Iir_Kind_Attribute_Declaration => + Chap3.Elab_Object_Subtype (Get_Type (Decl)); + + when Iir_Kind_Attribute_Specification => + Chap5.Elab_Attribute_Specification (Decl); + + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + if Get_Info (Decl) /= null then + Chap2.Elab_Subprogram_Interfaces (Decl); + end if; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + null; + + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Transaction_Attribute => + Elab_Signal_Attribute (Decl); + + when Iir_Kind_Delayed_Attribute => + Elab_Signal_Delayed_Attribute (Decl); + + when Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + + when others => + Error_Kind ("elab_declaration_chain", Decl); + end case; + + Decl := Get_Chain (Decl); + end loop; + end Elab_Declaration_Chain; + + procedure Final_Declaration_Chain (Parent : Iir; Deallocate : Boolean) + is + Decl : Iir; + begin + Decl := Get_Declaration_Chain (Parent); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_File_Declaration => + Final_File_Declaration (Decl); + when Iir_Kind_Variable_Declaration => + if Get_Kind (Get_Type (Decl)) + = Iir_Kind_Protected_Type_Declaration + then + Fini_Protected_Object (Decl); + end if; + if Deallocate then + Fini_Object (Decl); + end if; + when Iir_Kind_Constant_Declaration => + if Deallocate then + Fini_Object (Decl); + end if; + when others => + null; + end case; + + Decl := Get_Chain (Decl); + end loop; + end Final_Declaration_Chain; + + type Conv_Mode is (Conv_Mode_In, Conv_Mode_Out); + + -- Create subprogram for an association conversion. + -- STMT is the statement/block_header containing the association. + -- BLOCK is the architecture/block containing the instance. + -- ASSOC is the association and MODE the conversion to work on. + -- CONV_INFO is the result place holder. + -- BASE_BLOCK is the base architecture/block containing the instance. + -- ENTITY is the entity/component instantiated (null for block_stmt) + procedure Translate_Association_Subprogram + (Stmt : Iir; + Block : Iir; + Assoc : Iir; + Mode : Conv_Mode; + Conv_Info : in out Assoc_Conv_Info; + Base_Block : Iir; + Entity : Iir) + is + Formal : constant Iir := Get_Formal (Assoc); + Actual : constant Iir := Get_Actual (Assoc); + + Mark2, Mark3 : Id_Mark_Type; + Inter_List : O_Inter_List; + In_Type, Out_Type : Iir; + In_Info, Out_Info : Type_Info_Acc; + Itype : O_Tnode; + El_List : O_Element_List; + Block_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Stmt_Info : Block_Info_Acc; + Entity_Info : Ortho_Info_Acc; + Var_Data : O_Dnode; + + -- Variables for body. + E : O_Enode; + V : O_Dnode; + V1 : O_Lnode; + V_Out : Mnode; + R : O_Enode; + Constr : O_Assoc_List; + Subprg_Info : Subprg_Info_Acc; + Res : Mnode; + Imp : Iir; + Func : Iir; + begin + case Mode is + when Conv_Mode_In => + -- IN: from actual to formal. + Push_Identifier_Prefix (Mark2, "CONVIN"); + Out_Type := Get_Type (Formal); + In_Type := Get_Type (Actual); + Imp := Get_In_Conversion (Assoc); + + when Conv_Mode_Out => + -- OUT: from formal to actual. + Push_Identifier_Prefix (Mark2, "CONVOUT"); + In_Type := Get_Type (Formal); + Out_Type := Get_Type (Actual); + Imp := Get_Out_Conversion (Assoc); + + end case; + -- FIXME: individual assoc -> overload. + Push_Identifier_Prefix + (Mark3, Get_Identifier (Get_Association_Interface (Assoc))); + + -- Handle anonymous subtypes. + Chap3.Translate_Anonymous_Type_Definition (Out_Type, False); + Chap3.Translate_Anonymous_Type_Definition (In_Type, False); + Out_Info := Get_Info (Out_Type); + In_Info := Get_Info (In_Type); + + -- Start record containing data for the conversion function. + Start_Record_Type (El_List); + + -- Add instance field. + Conv_Info.Instance_Block := Base_Block; + New_Record_Field + (El_List, Conv_Info.Instance_Field, Wki_Instance, + Block_Info.Block_Decls_Ptr_Type); + + if Entity /= Null_Iir then + Conv_Info.Instantiated_Entity := Entity; + Entity_Info := Get_Info (Entity); + declare + Ptr : O_Tnode; + begin + if Entity_Info.Kind = Kind_Component then + Ptr := Entity_Info.Comp_Ptr_Type; + else + Ptr := Entity_Info.Block_Decls_Ptr_Type; + end if; + New_Record_Field + (El_List, Conv_Info.Instantiated_Field, + Get_Identifier ("instantiated"), Ptr); + end; + else + Conv_Info.Instantiated_Entity := Null_Iir; + Conv_Info.Instantiated_Field := O_Fnode_Null; + end if; + + -- Add input. + case In_Info.Type_Mode is + when Type_Mode_Thin => + Itype := In_Info.Ortho_Type (Mode_Signal); + when Type_Mode_Fat => + Itype := In_Info.Ortho_Ptr_Type (Mode_Signal); + when Type_Mode_Unknown => + raise Internal_Error; + end case; + New_Record_Field + (El_List, Conv_Info.In_Field, Get_Identifier ("val_in"), Itype); + + -- Add output. + New_Record_Field + (El_List, Conv_Info.Out_Field, Get_Identifier ("val_out"), + Get_Object_Type (Out_Info, Mode_Signal)); + Finish_Record_Type (El_List, Conv_Info.Record_Type); + New_Type_Decl (Create_Identifier ("DTYPE"), Conv_Info.Record_Type); + Conv_Info.Record_Ptr_Type := New_Access_Type (Conv_Info.Record_Type); + New_Type_Decl (Create_Identifier ("DPTR"), Conv_Info.Record_Ptr_Type); + + -- Declare the subprogram. + Start_Procedure_Decl + (Inter_List, Create_Identifier, O_Storage_Private); + New_Interface_Decl + (Inter_List, Var_Data, Get_Identifier ("data"), + Conv_Info.Record_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Conv_Info.Subprg); + + Start_Subprogram_Body (Conv_Info.Subprg); + Push_Local_Factory; + Open_Temp; + + -- Add an access to local block. + V := Create_Temp_Init + (Block_Info.Block_Decls_Ptr_Type, + New_Value_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.Instance_Field)); + Set_Scope_Via_Param_Ptr (Block_Info.Block_Scope, V); + + -- Add an access to instantiated entity. + -- This may be used to do some type checks. + if Conv_Info.Instantiated_Entity /= Null_Iir then + declare + Ptr_Type : O_Tnode; + begin + if Entity_Info.Kind = Kind_Component then + Ptr_Type := Entity_Info.Comp_Ptr_Type; + else + Ptr_Type := Entity_Info.Block_Decls_Ptr_Type; + end if; + V := Create_Temp_Init + (Ptr_Type, + New_Value_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.Instantiated_Field)); + if Entity_Info.Kind = Kind_Component then + Set_Scope_Via_Param_Ptr (Entity_Info.Comp_Scope, V); + else + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, V); + end if; + end; + end if; + + -- Add access to the instantiation-specific data. + -- This is used only for anonymous subtype variables. + -- FIXME: what if STMT is a binding_indication ? + Stmt_Info := Get_Info (Stmt); + if Stmt_Info /= null + and then Has_Scope_Type (Stmt_Info.Block_Scope) + then + Set_Scope_Via_Field (Stmt_Info.Block_Scope, + Stmt_Info.Block_Parent_Field, + Get_Info (Block).Block_Scope'Access); + end if; + + -- Read signal value. + E := New_Value_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.In_Field); + case Mode is + when Conv_Mode_In => + R := Chap7.Translate_Signal_Effective_Value (E, In_Type); + when Conv_Mode_Out => + R := Chap7.Translate_Signal_Driving_Value (E, In_Type); + end case; + + case Get_Kind (Imp) is + when Iir_Kind_Function_Call => + Func := Get_Implementation (Imp); + R := Chap7.Translate_Implicit_Conv + (R, In_Type, + Get_Type (Get_Interface_Declaration_Chain (Func)), + Mode_Value, Assoc); + + -- Create result value. + Subprg_Info := Get_Info (Func); + + if Subprg_Info.Use_Stack2 then + Create_Temp_Stack2_Mark; + end if; + + if Subprg_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + -- If we need to allocate, do it before starting the call! + declare + Res_Type : constant Iir := Get_Return_Type (Func); + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + begin + Res := Create_Temp (Res_Info); + if Res_Info.Type_Mode /= Type_Mode_Fat_Array then + Chap4.Allocate_Complex_Object + (Res_Type, Alloc_Stack, Res); + end if; + end; + end if; + + -- Call conversion function. + Start_Association (Constr, Subprg_Info.Ortho_Func); + + if Subprg_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Association (Constr, M2E (Res)); + end if; + + Chap2.Add_Subprg_Instance_Assoc + (Constr, Subprg_Info.Subprg_Instance); + + New_Association (Constr, R); + + if Subprg_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Procedure_Call (Constr); + E := M2E (Res); + else + E := New_Function_Call (Constr); + end if; + Res := E2M + (Chap7.Translate_Implicit_Conv + (E, Get_Return_Type (Func), + Out_Type, Mode_Value, Imp), + Get_Info (Out_Type), Mode_Value); + + when Iir_Kind_Type_Conversion => + declare + Conv_Type : Iir; + begin + Conv_Type := Get_Type (Imp); + E := Chap7.Translate_Type_Conversion + (R, In_Type, Conv_Type, Assoc); + E := Chap7.Translate_Implicit_Conv + (E, Conv_Type, Out_Type, Mode_Value, Imp); + Res := E2M (E, Get_Info (Out_Type), Mode_Value); + end; + + when others => + Error_Kind ("Translate_Association_Subprogram", Imp); + end case; + + -- Assign signals. + V1 := New_Selected_Acc_Value (New_Obj (Var_Data), + Conv_Info.Out_Field); + V_Out := Lo2M (V1, Out_Info, Mode_Signal); + + case Mode is + when Conv_Mode_In => + Chap7.Set_Effective_Value (V_Out, Out_Type, Res); + when Conv_Mode_Out => + Chap7.Set_Driving_Value (V_Out, Out_Type, Res); + end case; + + Close_Temp; + if Stmt_Info /= null + and then Has_Scope_Type (Stmt_Info.Block_Scope) + then + Clear_Scope (Stmt_Info.Block_Scope); + end if; + if Conv_Info.Instantiated_Entity /= Null_Iir then + if Entity_Info.Kind = Kind_Component then + Clear_Scope (Entity_Info.Comp_Scope); + else + Clear_Scope (Entity_Info.Block_Scope); + end if; + end if; + Clear_Scope (Block_Info.Block_Scope); + + Pop_Local_Factory; + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Mark3); + Pop_Identifier_Prefix (Mark2); + end Translate_Association_Subprogram; + + -- ENTITY is null for block_statement. + procedure Translate_Association_Subprograms + (Stmt : Iir; Block : Iir; Base_Block : Iir; Entity : Iir) + is + Assoc : Iir; + Info : Assoc_Info_Acc; + begin + Assoc := Get_Port_Map_Aspect_Chain (Stmt); + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression + then + Info := null; + if Get_In_Conversion (Assoc) /= Null_Iir then + Info := Add_Info (Assoc, Kind_Assoc); + Translate_Association_Subprogram + (Stmt, Block, Assoc, Conv_Mode_In, Info.Assoc_In, + Base_Block, Entity); + end if; + if Get_Out_Conversion (Assoc) /= Null_Iir then + if Info = null then + Info := Add_Info (Assoc, Kind_Assoc); + end if; + Translate_Association_Subprogram + (Stmt, Block, Assoc, Conv_Mode_Out, Info.Assoc_Out, + Base_Block, Entity); + end if; + end if; + Assoc := Get_Chain (Assoc); + end loop; + end Translate_Association_Subprograms; + + procedure Elab_Conversion (Sig_In : Iir; + Sig_Out : Iir; + Reg_Subprg : O_Dnode; + Info : Assoc_Conv_Info; + Ndest : out Mnode) + is + Out_Type : Iir; + Out_Info : Type_Info_Acc; + Ssig : Mnode; + Constr : O_Assoc_List; + Var_Data : O_Dnode; + Data : Elab_Signal_Data; + begin + Out_Type := Get_Type (Sig_Out); + Out_Info := Get_Info (Out_Type); + + -- Allocate data for the subprogram. + Var_Data := Create_Temp (Info.Record_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Data), + Gen_Alloc (Alloc_System, + New_Lit (New_Sizeof (Info.Record_Type, + Ghdl_Index_Type)), + Info.Record_Ptr_Type)); + + -- Set instance. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Data), Info.Instance_Field), + Get_Instance_Access (Info.Instance_Block)); + + -- Set instantiated unit instance (if any). + if Info.Instantiated_Entity /= Null_Iir then + declare + Inst_Addr : O_Enode; + Inst_Info : Ortho_Info_Acc; + begin + if Get_Kind (Info.Instantiated_Entity) + = Iir_Kind_Component_Declaration + then + Inst_Info := Get_Info (Info.Instantiated_Entity); + Inst_Addr := New_Address + (Get_Instance_Ref (Inst_Info.Comp_Scope), + Inst_Info.Comp_Ptr_Type); + else + Inst_Addr := Get_Instance_Access (Info.Instantiated_Entity); + end if; + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Instantiated_Field), + Inst_Addr); + end; + end if; + + -- Set input. + Ssig := Chap6.Translate_Name (Sig_In); + Ssig := Stabilize (Ssig, True); + + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var_Data), Info.In_Field), + M2E (Ssig)); + + -- Create a copy of SIG_OUT. + Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Out_Field), + Out_Info, Mode_Signal); + Chap4.Allocate_Complex_Object (Out_Type, Alloc_System, Ndest); + -- Note: NDEST will be assigned by ELAB_SIGNAL. + Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Out_Field), + Out_Info, Mode_Signal); + Data := Elab_Signal_Data'(Has_Val => False, + Already_Resolved => True, + Val => Mnode_Null, + Check_Null => False, + If_Stmt => null); + Elab_Signal (Ndest, Out_Type, Data); + + Ndest := Lo2M (New_Selected_Acc_Value (New_Obj (Var_Data), + Info.Out_Field), + Out_Info, Mode_Signal); + Ndest := Stabilize (Ndest, True); + + -- Register. + Start_Association (Constr, Reg_Subprg); + New_Association + (Constr, New_Lit (New_Subprogram_Address (Info.Subprg, + Ghdl_Ptr_Type))); + New_Association + (Constr, New_Convert_Ov (New_Obj_Value (Var_Data), Ghdl_Ptr_Type)); + + New_Association + (Constr, + New_Convert_Ov (M2E (Get_Leftest_Signal (Ssig, Get_Type (Sig_In))), + Ghdl_Signal_Ptr)); + New_Association (Constr, Get_Nbr_Signals (Ssig, Get_Type (Sig_In))); + + New_Association + (Constr, + New_Convert_Ov + (M2E (Get_Leftest_Signal (Ndest, Get_Type (Sig_Out))), + Ghdl_Signal_Ptr)); + New_Association (Constr, Get_Nbr_Signals (Ndest, Get_Type (Sig_Out))); + + New_Procedure_Call (Constr); + end Elab_Conversion; + + -- In conversion: from actual to formal. + procedure Elab_In_Conversion (Assoc : Iir; Ndest : out Mnode) + is + Assoc_Info : Assoc_Info_Acc; + begin + Assoc_Info := Get_Info (Assoc); + + Elab_Conversion + (Get_Actual (Assoc), Get_Formal (Assoc), + Ghdl_Signal_In_Conversion, Assoc_Info.Assoc_In, Ndest); + end Elab_In_Conversion; + + -- Out conversion: from formal to actual. + procedure Elab_Out_Conversion (Assoc : Iir; Ndest : out Mnode) + is + Assoc_Info : Assoc_Info_Acc; + begin + Assoc_Info := Get_Info (Assoc); + + Elab_Conversion + (Get_Formal (Assoc), Get_Actual (Assoc), + Ghdl_Signal_Out_Conversion, Assoc_Info.Assoc_Out, Ndest); + end Elab_Out_Conversion; + + -- Create a record that describe thes location of an IIR node and + -- returns the address of it. + function Get_Location (N : Iir) return O_Dnode + is + Constr : O_Record_Aggr_List; + Aggr : O_Cnode; + Name : Name_Id; + Line : Natural; + Col : Natural; + C : O_Dnode; + begin + Files_Map.Location_To_Position (Get_Location (N), Name, Line, Col); + + New_Const_Decl (C, Create_Uniq_Identifier, O_Storage_Private, + Ghdl_Location_Type_Node); + Start_Const_Value (C); + Start_Record_Aggr (Constr, Ghdl_Location_Type_Node); + New_Record_Aggr_El + (Constr, New_Global_Address (Current_Filename_Node, Char_Ptr_Type)); + New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type, + Integer_64 (Line))); + New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type, + Integer_64 (Col))); + Finish_Record_Aggr (Constr, Aggr); + Finish_Const_Value (C, Aggr); + + return C; + --return New_Global_Address (C, Ghdl_Location_Ptr_Node); + end Get_Location; + end Chap4; + + package body Chap5 is + procedure Translate_Attribute_Specification + (Spec : Iir_Attribute_Specification) + is + Attr : constant Iir_Attribute_Declaration := + Get_Named_Entity (Get_Attribute_Designator (Spec)); + Atinfo : constant Type_Info_Acc := Get_Info (Get_Type (Attr)); + Mark : Id_Mark_Type; + Info : Object_Info_Acc; + begin + Push_Identifier_Prefix_Uniq (Mark); + Info := Add_Info (Spec, Kind_Object); + Info.Object_Var := Create_Var + (Create_Var_Identifier (Attr), + Chap4.Get_Object_Type (Atinfo, Mode_Value), + Global_Storage); + Pop_Identifier_Prefix (Mark); + end Translate_Attribute_Specification; + + procedure Elab_Attribute_Specification + (Spec : Iir_Attribute_Specification) + is + Attr : constant Iir_Attribute_Declaration := + Get_Named_Entity (Get_Attribute_Designator (Spec)); + begin + -- Kludge + Set_Info (Attr, Get_Info (Spec)); + Chap4.Elab_Object_Value (Attr, Get_Expression (Spec)); + Clear_Info (Attr); + end Elab_Attribute_Specification; + + procedure Gen_Elab_Disconnect_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Time : O_Dnode) + is + pragma Unreferenced (Targ_Type); + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Signal_Set_Disconnect); + New_Association + (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Time)); + New_Procedure_Call (Assoc); + end Gen_Elab_Disconnect_Non_Composite; + + function Gen_Elab_Disconnect_Prepare + (Targ : Mnode; Targ_Type : Iir; Time : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Time; + end Gen_Elab_Disconnect_Prepare; + + function Gen_Elab_Disconnect_Update_Data_Array (Time : O_Dnode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Dnode + is + pragma Unreferenced (Targ_Type, Index); + begin + return Time; + end Gen_Elab_Disconnect_Update_Data_Array; + + function Gen_Elab_Disconnect_Update_Data_Record + (Time : O_Dnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return O_Dnode + is + pragma Unreferenced (Targ_Type, El); + begin + return Time; + end Gen_Elab_Disconnect_Update_Data_Record; + + procedure Gen_Elab_Disconnect_Finish_Data_Composite + (Data : in out O_Dnode) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Elab_Disconnect_Finish_Data_Composite; + + procedure Gen_Elab_Disconnect is new Foreach_Non_Composite + (Data_Type => O_Dnode, + Composite_Data_Type => O_Dnode, + Do_Non_Composite => Gen_Elab_Disconnect_Non_Composite, + Prepare_Data_Array => Gen_Elab_Disconnect_Prepare, + Update_Data_Array => Gen_Elab_Disconnect_Update_Data_Array, + Finish_Data_Array => Gen_Elab_Disconnect_Finish_Data_Composite, + Prepare_Data_Record => Gen_Elab_Disconnect_Prepare, + Update_Data_Record => Gen_Elab_Disconnect_Update_Data_Record, + Finish_Data_Record => Gen_Elab_Disconnect_Finish_Data_Composite); + + procedure Elab_Disconnection_Specification + (Spec : Iir_Disconnection_Specification) + is + Val : O_Dnode; + List : constant Iir_List := Get_Signal_List (Spec); + El : Iir; + begin + Val := Create_Temp_Init + (Std_Time_Otype, + Chap7.Translate_Expression (Get_Expression (Spec))); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Gen_Elab_Disconnect (Chap6.Translate_Name (El), + Get_Type (El), Val); + end loop; + end Elab_Disconnection_Specification; + + type Connect_Mode is + ( + -- Actual is a source for the formal. + Connect_Source, + + -- Both. + Connect_Both, + + -- Effective value of actual is the effective value of the formal. + Connect_Effective, + + -- Actual is a value. + Connect_Value + ); + + type Connect_Data is record + Actual_Node : Mnode; + Actual_Type : Iir; + + -- Mode of the connection. + Mode : Connect_Mode; + + -- If true, formal signal is a copy of the actual. + By_Copy : Boolean; + end record; + + -- Connect_effective: FORMAL is set from ACTUAL. + -- Connect_Source: ACTUAL is set from FORMAL (source of ACTUAL). + procedure Connect_Scalar (Formal_Node : Mnode; + Formal_Type : Iir; + Data : Connect_Data) + is + Act_Node, Form_Node : Mnode; + begin + if Data.By_Copy then + New_Assign_Stmt (M2Lv (Formal_Node), M2E (Data.Actual_Node)); + return; + end if; + + case Data.Mode is + when Connect_Both => + Open_Temp; + Act_Node := Stabilize (Data.Actual_Node, True); + Form_Node := Stabilize (Formal_Node, True); + when Connect_Source + | Connect_Effective => + Act_Node := Data.Actual_Node; + Form_Node := Formal_Node; + when Connect_Value => + null; + end case; + + if Data.Mode in Connect_Source .. Connect_Both then + -- Formal is a source to actual. + declare + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Signal_Add_Source); + New_Association (Constr, New_Convert_Ov (M2E (Act_Node), + Ghdl_Signal_Ptr)); + New_Association (Constr, New_Convert_Ov (M2E (Form_Node), + Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + end; + end if; + + if Data.Mode in Connect_Both .. Connect_Effective then + -- The effective value of formal is the effective value of actual. + declare + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Signal_Effective_Value); + New_Association (Constr, New_Convert_Ov (M2E (Form_Node), + Ghdl_Signal_Ptr)); + New_Association (Constr, New_Convert_Ov (M2E (Act_Node), + Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + end; + end if; + + if Data.Mode = Connect_Value then + declare + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Constr : O_Assoc_List; + Conv : O_Tnode; + begin + Type_Info := Get_Info (Formal_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Associate_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Associate_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Associate_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 => + Subprg := Ghdl_Signal_Associate_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 => + Subprg := Ghdl_Signal_Associate_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Associate_F64; + Conv := Ghdl_Real_Type; + when others => + Error_Kind ("connect_scalar", Formal_Type); + end case; + Start_Association (Constr, Subprg); + New_Association (Constr, + New_Convert_Ov (New_Value (M2Lv (Formal_Node)), + Ghdl_Signal_Ptr)); + New_Association (Constr, + New_Convert_Ov (M2E (Data.Actual_Node), Conv)); + New_Procedure_Call (Constr); + end; + end if; + + if Data.Mode = Connect_Both then + Close_Temp; + end if; + end Connect_Scalar; + + function Connect_Prepare_Data_Composite + (Targ : Mnode; Formal_Type : Iir; Data : Connect_Data) + return Connect_Data + is + pragma Unreferenced (Targ, Formal_Type); + Res : Connect_Data; + Atype : Iir; + begin + Atype := Get_Base_Type (Data.Actual_Type); + if Get_Kind (Atype) = Iir_Kind_Record_Type_Definition then + Res := Data; + Stabilize (Res.Actual_Node); + return Res; + else + return Data; + end if; + end Connect_Prepare_Data_Composite; + + function Connect_Update_Data_Array (Data : Connect_Data; + Formal_Type : Iir; + Index : O_Dnode) + return Connect_Data + is + pragma Unreferenced (Formal_Type); + Res : Connect_Data; + begin + -- FIXME: should check matching elements! + Res := (Actual_Node => + Chap3.Index_Base (Chap3.Get_Array_Base (Data.Actual_Node), + Data.Actual_Type, New_Obj_Value (Index)), + Actual_Type => Get_Element_Subtype (Data.Actual_Type), + Mode => Data.Mode, + By_Copy => Data.By_Copy); + return Res; + end Connect_Update_Data_Array; + + function Connect_Update_Data_Record (Data : Connect_Data; + Formal_Type : Iir; + El : Iir_Element_Declaration) + return Connect_Data + is + pragma Unreferenced (Formal_Type); + Res : Connect_Data; + begin + Res := (Actual_Node => + Chap6.Translate_Selected_Element (Data.Actual_Node, El), + Actual_Type => Get_Type (El), + Mode => Data.Mode, + By_Copy => Data.By_Copy); + return Res; + end Connect_Update_Data_Record; + + procedure Connect_Finish_Data_Composite (Data : in out Connect_Data) + is + pragma Unreferenced (Data); + begin + null; + end Connect_Finish_Data_Composite; + + procedure Connect is new Foreach_Non_Composite + (Data_Type => Connect_Data, + Composite_Data_Type => Connect_Data, + Do_Non_Composite => Connect_Scalar, + Prepare_Data_Array => Connect_Prepare_Data_Composite, + Update_Data_Array => Connect_Update_Data_Array, + Finish_Data_Array => Connect_Finish_Data_Composite, + Prepare_Data_Record => Connect_Prepare_Data_Composite, + Update_Data_Record => Connect_Update_Data_Record, + Finish_Data_Record => Connect_Finish_Data_Composite); + + procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir) + is + Act_Node : Mnode; + Bounds : Mnode; + Tinfo : Type_Info_Acc; + Bound_Var : O_Dnode; + Actual_Type : Iir; + begin + Actual_Type := Get_Type (Actual); + Open_Temp; + if Is_Fully_Constrained_Type (Actual_Type) then + Chap3.Create_Array_Subtype (Actual_Type, False); + Tinfo := Get_Info (Actual_Type); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + if Get_Alloc_Kind_For_Var (Tinfo.T.Array_Bounds) = Alloc_Stack then + -- We need a copy. + Bound_Var := Create_Temp (Tinfo.T.Bounds_Ptr_Type); + New_Assign_Stmt + (New_Obj (Bound_Var), + Gen_Alloc (Alloc_System, + New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, + Ghdl_Index_Type)), + Tinfo.T.Bounds_Ptr_Type)); + Gen_Memcpy (New_Obj_Value (Bound_Var), + M2Addr (Bounds), + New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, + Ghdl_Index_Type))); + Bounds := Dp2M (Bound_Var, Tinfo, Mode_Value, + Tinfo.T.Bounds_Type, + Tinfo.T.Bounds_Ptr_Type); + end if; + else + Bounds := Chap3.Get_Array_Bounds (Chap6.Translate_Name (Actual)); + end if; + Act_Node := Chap6.Translate_Name (Port); + New_Assign_Stmt + (-- FIXME: this works only because it is not stabilized, + -- and therefore the bounds field is returned and not + -- a pointer to the bounds. + M2Lp (Chap3.Get_Array_Bounds (Act_Node)), + M2Addr (Bounds)); + Close_Temp; + end Elab_Unconstrained_Port; + + -- Return TRUE if EXPR is a signal name. + function Is_Signal (Expr : Iir) return Boolean + is + Obj : Iir; + begin + Obj := Sem_Names.Name_To_Object (Expr); + if Obj /= Null_Iir then + return Is_Signal_Object (Obj); + else + return False; + end if; + end Is_Signal; + + procedure Elab_Port_Map_Aspect_Assoc (Assoc : Iir; By_Copy : Boolean) + is + Formal : constant Iir := Get_Formal (Assoc); + Actual : constant Iir := Get_Actual (Assoc); + Formal_Type : constant Iir := Get_Type (Formal); + Actual_Type : constant Iir := Get_Type (Actual); + Inter : constant Iir := Get_Association_Interface (Assoc); + Formal_Node, Actual_Node : Mnode; + Data : Connect_Data; + Mode : Connect_Mode; + begin + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Expression then + raise Internal_Error; + end if; + + Open_Temp; + if Get_In_Conversion (Assoc) = Null_Iir + and then Get_Out_Conversion (Assoc) = Null_Iir + then + Formal_Node := Chap6.Translate_Name (Formal); + if Get_Object_Kind (Formal_Node) /= Mode_Signal then + raise Internal_Error; + end if; + if Is_Signal (Actual) then + -- LRM93 4.3.1.2 + -- For a signal of a scalar type, each source is either + -- a driver or an OUT, INOUT, BUFFER or LINKAGE port of + -- a component instance or of a block statement with + -- which the signalis associated. + + -- LRM93 12.6.2 + -- For a scalar signal S, the effective value of S is + -- determined in the following manner: + -- * If S is [...] a port of mode BUFFER or [...], + -- then the effective value of S is the same as + -- the driving value of S. + -- * If S is a connected port of mode IN or INOUT, + -- then the effective value of S is the same as + -- the effective value of the actual part of the + -- association element that associates an actual + -- with S. + -- * [...] + case Get_Mode (Inter) is + when Iir_In_Mode => + Mode := Connect_Effective; + when Iir_Inout_Mode => + Mode := Connect_Both; + when Iir_Out_Mode + | Iir_Buffer_Mode + | Iir_Linkage_Mode => + Mode := Connect_Source; + when Iir_Unknown_Mode => + raise Internal_Error; + end case; + + -- translate actual (abort if not a signal). + Actual_Node := Chap6.Translate_Name (Actual); + if Get_Object_Kind (Actual_Node) /= Mode_Signal then + raise Internal_Error; + end if; + else + declare + Actual_Val : O_Enode; + begin + Actual_Val := Chap7.Translate_Expression + (Actual, Formal_Type); + Actual_Node := E2M + (Actual_Val, Get_Info (Formal_Type), Mode_Value); + Mode := Connect_Value; + end; + end if; + + if Get_Kind (Formal_Type) in Iir_Kinds_Array_Type_Definition + then + -- Check length matches. + Stabilize (Formal_Node); + Stabilize (Actual_Node); + Chap3.Check_Array_Match (Formal_Type, Formal_Node, + Actual_Type, Actual_Node, + Assoc); + end if; + + Data := (Actual_Node => Actual_Node, + Actual_Type => Actual_Type, + Mode => Mode, + By_Copy => By_Copy); + Connect (Formal_Node, Formal_Type, Data); + else + if Get_In_Conversion (Assoc) /= Null_Iir then + Chap4.Elab_In_Conversion (Assoc, Actual_Node); + Formal_Node := Chap6.Translate_Name (Formal); + Data := (Actual_Node => Actual_Node, + Actual_Type => Formal_Type, + Mode => Connect_Effective, + By_Copy => False); + Connect (Formal_Node, Formal_Type, Data); + end if; + if Get_Out_Conversion (Assoc) /= Null_Iir then + -- flow: FORMAL to ACTUAL + Chap4.Elab_Out_Conversion (Assoc, Formal_Node); + Actual_Node := Chap6.Translate_Name (Actual); + Data := (Actual_Node => Actual_Node, + Actual_Type => Actual_Type, + Mode => Connect_Source, + By_Copy => False); + Connect (Formal_Node, Actual_Type, Data); + end if; + end if; + + Close_Temp; + end Elab_Port_Map_Aspect_Assoc; + + -- Return TRUE if the collapse_signal_flag is set for each individual + -- association. + function Inherit_Collapse_Flag (Assoc : Iir) return Boolean + is + El : Iir; + begin + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Individual => + El := Get_Individual_Association_Chain (Assoc); + while El /= Null_Iir loop + if Inherit_Collapse_Flag (El) = False then + return False; + end if; + El := Get_Chain (El); + end loop; + return True; + when Iir_Kind_Choice_By_Expression + | Iir_Kind_Choice_By_Range + | Iir_Kind_Choice_By_Name => + El := Assoc; + while El /= Null_Iir loop + if not Inherit_Collapse_Flag (Get_Associated_Expr (Assoc)) + then + return False; + end if; + El := Get_Chain (El); + end loop; + return True; + when Iir_Kind_Association_Element_By_Expression => + return Get_Collapse_Signal_Flag (Assoc); + when others => + Error_Kind ("inherit_collapse_flag", Assoc); + end case; + end Inherit_Collapse_Flag; + + procedure Elab_Generic_Map_Aspect (Mapping : Iir) + is + Assoc : Iir; + Formal : Iir; + begin + -- Elab generics, and associate. + Assoc := Get_Generic_Map_Aspect_Chain (Mapping); + while Assoc /= Null_Iir loop + Open_Temp; + Formal := Get_Formal (Assoc); + if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then + Formal := Get_Named_Entity (Formal); + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + declare + Targ : Mnode; + begin + if Get_Whole_Association_Flag (Assoc) then + Chap4.Elab_Object_Storage (Formal); + Targ := Chap6.Translate_Name (Formal); + Chap4.Elab_Object_Init + (Targ, Formal, Get_Actual (Assoc)); + else + Targ := Chap6.Translate_Name (Formal); + Chap7.Translate_Assign + (Targ, Get_Actual (Assoc), Get_Type (Formal)); + end if; + end; + when Iir_Kind_Association_Element_Open => + Chap4.Elab_Object_Value (Formal, Get_Default_Value (Formal)); + when Iir_Kind_Association_Element_By_Individual => + -- Create the object. + declare + Formal_Type : constant Iir := Get_Type (Formal); + Obj_Info : constant Object_Info_Acc := Get_Info (Formal); + Obj_Type : constant Iir := Get_Actual_Type (Assoc); + Formal_Node : Mnode; + Type_Info : Type_Info_Acc; + Bounds : Mnode; + begin + Chap3.Elab_Object_Subtype (Formal_Type); + Type_Info := Get_Info (Formal_Type); + Formal_Node := Get_Var + (Obj_Info.Object_Var, Type_Info, Mode_Value); + Stabilize (Formal_Node); + if Obj_Type = Null_Iir then + Chap4.Allocate_Complex_Object + (Formal_Type, Alloc_System, Formal_Node); + else + Chap3.Create_Array_Subtype (Obj_Type, False); + Bounds := Chap3.Get_Array_Type_Bounds (Obj_Type); + Chap3.Translate_Object_Allocation + (Formal_Node, Alloc_System, Formal_Type, Bounds); + end if; + end; + when Iir_Kind_Association_Element_Package => + pragma Assert (Get_Kind (Formal) = + Iir_Kind_Interface_Package_Declaration); + declare + Uninst_Pkg : constant Iir := Get_Named_Entity + (Get_Uninstantiated_Package_Name (Formal)); + Uninst_Info : constant Ortho_Info_Acc := + Get_Info (Uninst_Pkg); + Formal_Info : constant Ortho_Info_Acc := + Get_Info (Formal); + Actual : constant Iir := Get_Named_Entity + (Get_Actual (Assoc)); + Actual_Info : constant Ortho_Info_Acc := + Get_Info (Actual); + begin + New_Assign_Stmt + (Get_Var (Formal_Info.Package_Instance_Spec_Var), + New_Address + (Get_Instance_Ref + (Actual_Info.Package_Instance_Spec_Scope), + Uninst_Info.Package_Spec_Ptr_Type)); + New_Assign_Stmt + (Get_Var (Formal_Info.Package_Instance_Body_Var), + New_Address + (Get_Instance_Ref + (Actual_Info.Package_Instance_Body_Scope), + Uninst_Info.Package_Body_Ptr_Type)); + end; + when others => + Error_Kind ("elab_generic_map_aspect(1)", Assoc); + end case; + Close_Temp; + Assoc := Get_Chain (Assoc); + end loop; + end Elab_Generic_Map_Aspect; + + procedure Elab_Port_Map_Aspect (Mapping : Iir; Block_Parent : Iir) + is + Assoc : Iir; + Formal : Iir; + Formal_Base : Iir; + Fb_Type : Iir; + Fbt_Info : Type_Info_Acc; + Collapse_Individual : Boolean := False; + begin + -- Ports. + Assoc := Get_Port_Map_Aspect_Chain (Mapping); + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + Formal_Base := Get_Association_Interface (Assoc); + Fb_Type := Get_Type (Formal_Base); + + Open_Temp; + -- Set bounds of unconstrained ports. + Fbt_Info := Get_Info (Fb_Type); + if Fbt_Info.Type_Mode = Type_Mode_Fat_Array then + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + if Get_Whole_Association_Flag (Assoc) then + Elab_Unconstrained_Port (Formal, Get_Actual (Assoc)); + end if; + when Iir_Kind_Association_Element_Open => + declare + Actual_Type : Iir; + Bounds : Mnode; + Formal_Node : Mnode; + begin + Actual_Type := + Get_Type (Get_Default_Value (Formal_Base)); + Chap3.Create_Array_Subtype (Actual_Type, True); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Formal_Node := Chap6.Translate_Name (Formal); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Formal_Node)), + M2Addr (Bounds)); + end; + when Iir_Kind_Association_Element_By_Individual => + declare + Actual_Type : Iir; + Bounds : Mnode; + Formal_Node : Mnode; + begin + Actual_Type := Get_Actual_Type (Assoc); + Chap3.Create_Array_Subtype (Actual_Type, False); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Formal_Node := Chap6.Translate_Name (Formal); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Formal_Node)), + M2Addr (Bounds)); + end; + when others => + Error_Kind ("elab_map_aspect(2)", Assoc); + end case; + end if; + Close_Temp; + + -- Allocate storage of ports. + Open_Temp; + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Individual + | Iir_Kind_Association_Element_Open => + Chap4.Elab_Signal_Declaration_Storage (Formal); + when Iir_Kind_Association_Element_By_Expression => + if Get_Whole_Association_Flag (Assoc) then + Chap4.Elab_Signal_Declaration_Storage (Formal); + end if; + when others => + Error_Kind ("elab_map_aspect(3)", Assoc); + end case; + Close_Temp; + + -- Create or copy signals. + Open_Temp; + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + if Get_Whole_Association_Flag (Assoc) then + if Get_Collapse_Signal_Flag (Assoc) then + -- For collapsed association, copy signals. + Elab_Port_Map_Aspect_Assoc (Assoc, True); + else + -- Create non-collapsed signals. + Chap4.Elab_Signal_Declaration_Object + (Formal, Block_Parent, False); + -- And associate. + Elab_Port_Map_Aspect_Assoc (Assoc, False); + end if; + else + -- By sub-element. + -- Either the whole signal is collapsed or it was already + -- created. + -- And associate. + Elab_Port_Map_Aspect_Assoc (Assoc, Collapse_Individual); + end if; + when Iir_Kind_Association_Element_Open => + -- Create non-collapsed signals. + Chap4.Elab_Signal_Declaration_Object + (Formal, Block_Parent, False); + when Iir_Kind_Association_Element_By_Individual => + -- Inherit the collapse flag. + -- If it is set for all sub-associations, continue. + -- Otherwise, create signals and do not collapse. + -- FIXME: this may be slightly optimized. + if not Inherit_Collapse_Flag (Assoc) then + -- Create the formal. + Chap4.Elab_Signal_Declaration_Object + (Formal, Block_Parent, False); + Collapse_Individual := False; + else + Collapse_Individual := True; + end if; + when others => + Error_Kind ("elab_map_aspect(4)", Assoc); + end case; + Close_Temp; + + Assoc := Get_Chain (Assoc); + end loop; + end Elab_Port_Map_Aspect; + + procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir) is + begin + -- The generic map must be done before the elaboration of + -- the ports, since a port subtype may depend on a generic. + Elab_Generic_Map_Aspect (Mapping); + + Elab_Port_Map_Aspect (Mapping, Block_Parent); + end Elab_Map_Aspect; + end Chap5; + + package body Chap6 is + function Get_Array_Bound_Length (Arr : Mnode; + Arr_Type : Iir; + Dim : Natural) + return O_Enode + is + Index_Type : constant Iir := Get_Index_Type (Arr_Type, Dim - 1); + Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); + Constraint : Iir; + begin + if Tinfo.Type_Locally_Constrained then + Constraint := Get_Range_Constraint (Index_Type); + return New_Lit (Chap7.Translate_Static_Range_Length (Constraint)); + else + return M2E + (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Arr_Type, Dim))); + end if; + end Get_Array_Bound_Length; + + procedure Gen_Bound_Error (Loc : Iir) + is + Constr : O_Assoc_List; + Name : Name_Id; + Line, Col : Natural; + begin + Files_Map.Location_To_Position (Get_Location (Loc), Name, Line, Col); + + Start_Association (Constr, Ghdl_Bound_Check_Failed_L1); + Assoc_Filename_Line (Constr, Line); + New_Procedure_Call (Constr); + end Gen_Bound_Error; + + procedure Gen_Program_Error (Loc : Iir; Code : Natural) + is + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Program_Error); + + if Current_Filename_Node = O_Dnode_Null then + New_Association (Assoc, New_Lit (New_Null_Access (Char_Ptr_Type))); + New_Association (Assoc, + New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0))); + else + Assoc_Filename_Line (Assoc, Get_Line_Number (Loc)); + end if; + New_Association + (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Code)))); + New_Procedure_Call (Assoc); + end Gen_Program_Error; + + -- Generate code to emit a failure if COND is TRUE, indicating an + -- index violation for dimension DIM of an array. LOC is usually + -- the expression which has computed the index and is used only for + -- its location. + procedure Check_Bound_Error (Cond : O_Enode; Loc : Iir; Dim : Natural) + is + pragma Unreferenced (Dim); + If_Blk : O_If_Block; + begin + Start_If_Stmt (If_Blk, Cond); + Gen_Bound_Error (Loc); + Finish_If_Stmt (If_Blk); + end Check_Bound_Error; + + -- Return TRUE if an array whose index type is RNG_TYPE indexed by + -- an expression of type EXPR_TYPE needs a bound check. + function Need_Index_Check (Expr_Type : Iir; Rng_Type : Iir) + return Boolean + is + Rng : Iir; + begin + -- Do checks if type of the expression is not a subtype. + -- FIXME: EXPR_TYPE shound not be NULL_IIR (generate stmt) + if Expr_Type = Null_Iir then + return True; + end if; + case Get_Kind (Expr_Type) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + null; + when others => + return True; + end case; + + -- No check if the expression has the type of the index. + if Expr_Type = Rng_Type then + return False; + end if; + + -- No check for 'Range or 'Reverse_Range. + Rng := Get_Range_Constraint (Expr_Type); + if (Get_Kind (Rng) = Iir_Kind_Range_Array_Attribute + or Get_Kind (Rng) = Iir_Kind_Reverse_Range_Array_Attribute) + and then Get_Type (Rng) = Rng_Type + then + return False; + end if; + + return True; + end Need_Index_Check; + + procedure Get_Deep_Range_Expression + (Atype : Iir; Rng : out Iir; Is_Reverse : out Boolean) + is + T : Iir; + R : Iir; + begin + Is_Reverse := False; + + -- T is an integer/enumeration subtype. + T := Atype; + loop + case Get_Kind (T) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + -- These types have a range. + null; + when others => + Error_Kind ("get_deep_range_expression(1)", T); + end case; + + R := Get_Range_Constraint (T); + case Get_Kind (R) is + when Iir_Kind_Range_Expression => + Rng := R; + return; + when Iir_Kind_Range_Array_Attribute => + null; + when Iir_Kind_Reverse_Range_Array_Attribute => + Is_Reverse := not Is_Reverse; + when others => + Error_Kind ("get_deep_range_expression(2)", R); + end case; + T := Get_Index_Subtype (R); + if T = Null_Iir then + Rng := Null_Iir; + return; + end if; + end loop; + end Get_Deep_Range_Expression; + + function Translate_Index_To_Offset (Rng : Mnode; + Index : O_Enode; + Index_Expr : Iir; + Range_Type : Iir; + Loc : Iir) + return O_Enode + is + Need_Check : Boolean; + Dir : O_Enode; + If_Blk : O_If_Block; + Res : O_Dnode; + Off : O_Dnode; + Bound : O_Enode; + Cond1, Cond2: O_Enode; + Index_Node : O_Dnode; + Bound_Node : O_Dnode; + Index_Info : Type_Info_Acc; + Deep_Rng : Iir; + Deep_Reverse : Boolean; + begin + Index_Info := Get_Info (Get_Base_Type (Range_Type)); + if Index_Expr = Null_Iir then + Need_Check := True; + Deep_Rng := Null_Iir; + Deep_Reverse := False; + else + Need_Check := Need_Index_Check (Get_Type (Index_Expr), Range_Type); + Get_Deep_Range_Expression (Range_Type, Deep_Rng, Deep_Reverse); + end if; + + Res := Create_Temp (Ghdl_Index_Type); + + Open_Temp; + + Off := Create_Temp (Index_Info.Ortho_Type (Mode_Value)); + + Bound := M2E (Chap3.Range_To_Left (Rng)); + + if Deep_Rng /= Null_Iir then + if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then + -- Direction TO: INDEX - LEFT. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + Index, Bound)); + else + -- Direction DOWNTO: LEFT - INDEX. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + Bound, Index)); + end if; + else + Index_Node := Create_Temp_Init + (Index_Info.Ortho_Type (Mode_Value), Index); + Bound_Node := Create_Temp_Init + (Index_Info.Ortho_Type (Mode_Value), Bound); + Dir := M2E (Chap3.Range_To_Dir (Rng)); + + -- Non-static direction. + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Eq, Dir, + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + -- Direction TO: INDEX - LEFT. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Index_Node), + New_Obj_Value (Bound_Node))); + New_Else_Stmt (If_Blk); + -- Direction DOWNTO: LEFT - INDEX. + New_Assign_Stmt (New_Obj (Off), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Bound_Node), + New_Obj_Value (Index_Node))); + Finish_If_Stmt (If_Blk); + end if; + + -- Get the offset. + New_Assign_Stmt + (New_Obj (Res), New_Convert_Ov (New_Obj_Value (Off), + Ghdl_Index_Type)); + + -- Check bounds. + if Need_Check then + Cond1 := New_Compare_Op + (ON_Lt, + New_Obj_Value (Off), + New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), + 0)), + Ghdl_Bool_Type); + + Cond2 := New_Compare_Op + (ON_Ge, + New_Obj_Value (Res), + M2E (Chap3.Range_To_Length (Rng)), + Ghdl_Bool_Type); + Check_Bound_Error (New_Dyadic_Op (ON_Or, Cond1, Cond2), Loc, 0); + end if; + + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Index_To_Offset; + + -- Translate index EXPR in dimension DIM of thin array into an + -- offset. + -- This checks bounds. + function Translate_Thin_Index_Offset (Index_Type : Iir; + Dim : Natural; + Expr : Iir) + return O_Enode + is + Index_Range : constant Iir := Get_Range_Constraint (Index_Type); + Obound : O_Cnode; + Res : O_Dnode; + Cond2: O_Enode; + Index : O_Enode; + Index_Base_Type : Iir; + V : Iir_Int64; + B : Iir_Int64; + begin + B := Eval_Pos (Get_Left_Limit (Index_Range)); + if Get_Expr_Staticness (Expr) = Locally then + V := Eval_Pos (Eval_Static_Expr (Expr)); + if Get_Direction (Index_Range) = Iir_To then + B := V - B; + else + B := B - V; + end if; + return New_Lit + (New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (B))); + else + Index_Base_Type := Get_Base_Type (Index_Type); + Index := Chap7.Translate_Expression (Expr, Index_Base_Type); + + if Get_Direction (Index_Range) = Iir_To then + -- Direction TO: INDEX - LEFT. + if B /= 0 then + Obound := Chap7.Translate_Static_Range_Left + (Index_Range, Index_Base_Type); + Index := New_Dyadic_Op (ON_Sub_Ov, Index, New_Lit (Obound)); + end if; + else + -- Direction DOWNTO: LEFT - INDEX. + Obound := Chap7.Translate_Static_Range_Left + (Index_Range, Index_Base_Type); + Index := New_Dyadic_Op (ON_Sub_Ov, New_Lit (Obound), Index); + end if; + + -- Get the offset. + Index := New_Convert_Ov (Index, Ghdl_Index_Type); + + -- Since the value is unsigned, both left and right bounds are + -- checked in the same time. + if Get_Type (Expr) /= Index_Type then + Res := Create_Temp_Init (Ghdl_Index_Type, Index); + + Cond2 := New_Compare_Op + (ON_Ge, New_Obj_Value (Res), + New_Lit (Chap7.Translate_Static_Range_Length (Index_Range)), + Ghdl_Bool_Type); + Check_Bound_Error (Cond2, Expr, Dim); + Index := New_Obj_Value (Res); + end if; + + return Index; + end if; + end Translate_Thin_Index_Offset; + + -- Translate an indexed name. + type Indexed_Name_Data is record + Offset : O_Dnode; + Res : Mnode; + end record; + + function Translate_Indexed_Name_Init (Prefix_Orig : Mnode; Expr : Iir) + return Indexed_Name_Data + is + Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr)); + Prefix_Info : constant Type_Info_Acc := Get_Info (Prefix_Type); + Index_List : constant Iir_List := Get_Index_List (Expr); + Type_List : constant Iir_List := Get_Index_Subtype_List (Prefix_Type); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); + Prefix : Mnode; + Index : Iir; + Offset : O_Dnode; + R : O_Enode; + Length : O_Enode; + Itype : Iir; + Ibasetype : Iir; + Range_Ptr : Mnode; + begin + case Prefix_Info.Type_Mode is + when Type_Mode_Fat_Array => + Prefix := Stabilize (Prefix_Orig); + when Type_Mode_Array => + Prefix := Prefix_Orig; + when others => + raise Internal_Error; + end case; + Offset := Create_Temp (Ghdl_Index_Type); + for Dim in 1 .. Nbr_Dim loop + Index := Get_Nth_Element (Index_List, Dim - 1); + Itype := Get_Index_Type (Type_List, Dim - 1); + Ibasetype := Get_Base_Type (Itype); + Open_Temp; + -- Compute index for the current dimension. + case Prefix_Info.Type_Mode is + when Type_Mode_Fat_Array => + Range_Ptr := Stabilize + (Chap3.Get_Array_Range (Prefix, Prefix_Type, Dim)); + R := Translate_Index_To_Offset + (Range_Ptr, + Chap7.Translate_Expression (Index, Ibasetype), + Null_Iir, Itype, Index); + when Type_Mode_Array => + if Prefix_Info.Type_Locally_Constrained then + R := Translate_Thin_Index_Offset (Itype, Dim, Index); + else + -- Manually extract range since there is no infos for + -- index subtype. + Range_Ptr := Chap3.Bounds_To_Range + (Chap3.Get_Array_Type_Bounds (Prefix_Type), + Prefix_Type, Dim); + Stabilize (Range_Ptr); + R := Translate_Index_To_Offset + (Range_Ptr, + Chap7.Translate_Expression (Index, Ibasetype), + Index, Itype, Index); + end if; + when others => + raise Internal_Error; + end case; + if Dim = 1 then + -- First dimension. + New_Assign_Stmt (New_Obj (Offset), R); + else + -- If there are more dimension(s) to follow, then multiply + -- the current offset by the length of the current dimension. + if Prefix_Info.Type_Locally_Constrained then + Length := New_Lit (Chap7.Translate_Static_Range_Length + (Get_Range_Constraint (Itype))); + else + Length := M2E (Chap3.Range_To_Length (Range_Ptr)); + end if; + New_Assign_Stmt + (New_Obj (Offset), + New_Dyadic_Op (ON_Add_Ov, + New_Dyadic_Op (ON_Mul_Ov, + New_Obj_Value (Offset), + Length), + R)); + end if; + Close_Temp; + end loop; + + return (Offset => Offset, + Res => Chap3.Index_Base + (Chap3.Get_Array_Base (Prefix), Prefix_Type, + New_Obj_Value (Offset))); + end Translate_Indexed_Name_Init; + + function Translate_Indexed_Name_Finish + (Prefix : Mnode; Expr : Iir; Data : Indexed_Name_Data) + return Mnode + is + begin + return Chap3.Index_Base (Chap3.Get_Array_Base (Prefix), + Get_Type (Get_Prefix (Expr)), + New_Obj_Value (Data.Offset)); + end Translate_Indexed_Name_Finish; + + function Translate_Indexed_Name (Prefix : Mnode; Expr : Iir) + return Mnode + is + begin + return Translate_Indexed_Name_Init (Prefix, Expr).Res; + end Translate_Indexed_Name; + + type Slice_Name_Data is record + Off : Unsigned_64; + Is_Off : Boolean; + + Unsigned_Diff : O_Dnode; + + -- Variable pointing to the prefix. + Prefix_Var : Mnode; + + -- Variable pointing to slice. + Slice_Range : Mnode; + end record; + + procedure Translate_Slice_Name_Init + (Prefix : Mnode; Expr : Iir_Slice_Name; Data : out Slice_Name_Data) + is + -- Type of the prefix. + Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr)); + + -- Type info of the prefix. + Prefix_Info : Type_Info_Acc; + + -- Type of the first (and only) index of the prefix array type. + Index_Type : constant Iir := Get_Index_Type (Prefix_Type, 0); + + -- Type of the slice. + Slice_Type : constant Iir := Get_Type (Expr); + Slice_Info : Type_Info_Acc; + + -- True iff the direction of the slice is known at compile time. + Static_Range : Boolean; + + -- Suffix of the slice (discrete range). + Expr_Range : constant Iir := Get_Suffix (Expr); + + -- Variable pointing to the prefix. + Prefix_Var : Mnode; + + -- Type info of the range base type. + Index_Info : Type_Info_Acc; + + -- Variables pointing to slice and prefix ranges. + Slice_Range : Mnode; + Prefix_Range : Mnode; + + Diff : O_Dnode; + Unsigned_Diff : O_Dnode; + If_Blk, If_Blk1 : O_If_Block; + begin + -- Evaluate slice bounds. + Chap3.Create_Array_Subtype (Slice_Type, True); + + -- The info may have just been created. + Prefix_Info := Get_Info (Prefix_Type); + Slice_Info := Get_Info (Slice_Type); + + if Slice_Info.Type_Mode = Type_Mode_Array + and then Slice_Info.Type_Locally_Constrained + and then Prefix_Info.Type_Mode = Type_Mode_Array + and then Prefix_Info.Type_Locally_Constrained + then + Data.Is_Off := True; + Data.Prefix_Var := Prefix; + + -- Both prefix and result are constrained array. + declare + Prefix_Left, Slice_Left : Iir_Int64; + Off : Iir_Int64; + Slice_Index_Type : Iir; + Slice_Range : Iir; + Slice_Length : Iir_Int64; + Index_Range : Iir; + begin + Index_Range := Get_Range_Constraint (Index_Type); + Prefix_Left := Eval_Pos (Get_Left_Limit (Index_Range)); + Slice_Index_Type := Get_Index_Type (Slice_Type, 0); + Slice_Range := Get_Range_Constraint (Slice_Index_Type); + Slice_Left := Eval_Pos (Get_Left_Limit (Slice_Range)); + Slice_Length := Eval_Discrete_Range_Length (Slice_Range); + if Slice_Length = 0 then + -- Null slice. + Data.Off := 0; + return; + end if; + if Get_Direction (Index_Range) /= Get_Direction (Slice_Range) + then + -- This is allowed with vhdl87 + Off := 0; + Slice_Length := 0; + else + -- Both prefix and slice are thin array. + case Get_Direction (Index_Range) is + when Iir_To => + Off := Slice_Left - Prefix_Left; + when Iir_Downto => + Off := Prefix_Left - Slice_Left; + end case; + if Off < 0 then + -- Must have been caught by sem. + raise Internal_Error; + end if; + if Off + Slice_Length + > Eval_Discrete_Range_Length (Index_Range) + then + -- Must have been caught by sem. + raise Internal_Error; + end if; + end if; + Data.Off := Unsigned_64 (Off); + + return; + end; + end if; + + Data.Is_Off := False; + + -- Save prefix. + Prefix_Var := Stabilize (Prefix); + + Index_Info := Get_Info (Get_Base_Type (Index_Type)); + + -- Save prefix bounds. + Prefix_Range := Stabilize + (Chap3.Get_Array_Range (Prefix_Var, Prefix_Type, 1)); + + -- Save slice bounds. + Slice_Range := Stabilize + (Chap3.Bounds_To_Range (Chap3.Get_Array_Type_Bounds (Slice_Type), + Slice_Type, 1)); + + -- TRUE if the direction of the slice is known. + Static_Range := Get_Kind (Expr_Range) = Iir_Kind_Range_Expression; + + -- Check direction against same direction, error if different. + -- FIXME: what about v87 -> if different then null slice + if not Static_Range + or else Get_Kind (Prefix_Type) /= Iir_Kind_Array_Subtype_Definition + then + -- Check same direction. + Check_Bound_Error + (New_Compare_Op (ON_Neq, + M2E (Chap3.Range_To_Dir (Prefix_Range)), + M2E (Chap3.Range_To_Dir (Slice_Range)), + Ghdl_Bool_Type), + Expr, 1); + end if; + + Unsigned_Diff := Create_Temp (Ghdl_Index_Type); + + -- Check if not a null slice. + -- The bounds of a null slice may be out of range. So DIFF cannot + -- be computed by substraction. + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Eq, + M2E (Chap3.Range_To_Length (Slice_Range)), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Unsigned_Diff), New_Lit (Ghdl_Index_0)); + New_Else_Stmt (If_Blk); + Diff := Create_Temp (Index_Info.Ortho_Type (Mode_Value)); + + -- Compute the offset in the prefix. + if not Static_Range then + Start_If_Stmt + (If_Blk1, New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Slice_Range)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + end if; + if not Static_Range or else Get_Direction (Expr_Range) = Iir_To then + -- Diff = slice - bounds. + New_Assign_Stmt + (New_Obj (Diff), + New_Dyadic_Op (ON_Sub_Ov, + M2E (Chap3.Range_To_Left (Slice_Range)), + M2E (Chap3.Range_To_Left (Prefix_Range)))); + end if; + if not Static_Range then + New_Else_Stmt (If_Blk1); + end if; + if not Static_Range or else Get_Direction (Expr_Range) = Iir_Downto + then + -- Diff = bounds - slice. + New_Assign_Stmt + (New_Obj (Diff), + New_Dyadic_Op (ON_Sub_Ov, + M2E (Chap3.Range_To_Left (Prefix_Range)), + M2E (Chap3.Range_To_Left (Slice_Range)))); + end if; + if not Static_Range then + Finish_If_Stmt (If_Blk1); + end if; + + -- Note: this also check for overflow. + New_Assign_Stmt + (New_Obj (Unsigned_Diff), + New_Convert_Ov (New_Obj_Value (Diff), Ghdl_Index_Type)); + + -- Check bounds. + declare + Err_1 : O_Enode; + Err_2 : O_Enode; + begin + -- Bounds error if left of slice is before left of prefix. + Err_1 := New_Compare_Op + (ON_Lt, + New_Obj_Value (Diff), + New_Lit (New_Signed_Literal (Index_Info.Ortho_Type (Mode_Value), + 0)), + Ghdl_Bool_Type); + -- Bounds error if right of slice is after right of prefix. + Err_2 := New_Compare_Op + (ON_Gt, + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Unsigned_Diff), + M2E (Chap3.Range_To_Length (Slice_Range))), + M2E (Chap3.Range_To_Length (Prefix_Range)), + Ghdl_Bool_Type); + Check_Bound_Error (New_Dyadic_Op (ON_Or, Err_1, Err_2), Expr, 1); + end; + Finish_If_Stmt (If_Blk); + + Data.Slice_Range := Slice_Range; + Data.Prefix_Var := Prefix_Var; + Data.Unsigned_Diff := Unsigned_Diff; + Data.Is_Off := False; + end Translate_Slice_Name_Init; + + function Translate_Slice_Name_Finish + (Prefix : Mnode; Expr : Iir_Slice_Name; Data : Slice_Name_Data) + return Mnode + is + -- Type of the slice. + Slice_Type : constant Iir := Get_Type (Expr); + Slice_Info : constant Type_Info_Acc := Get_Info (Slice_Type); + + -- Object kind of the prefix. + Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix); + + Res_D : O_Dnode; + begin + if Data.Is_Off then + return Chap3.Slice_Base + (Prefix, Slice_Type, New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, Data.Off))); + else + -- Create the result (fat array) and assign the bounds field. + case Slice_Info.Type_Mode is + when Type_Mode_Fat_Array => + Res_D := Create_Temp (Slice_Info.Ortho_Type (Kind)); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res_D), + Slice_Info.T.Bounds_Field (Kind)), + New_Value (M2Lp (Data.Slice_Range))); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res_D), + Slice_Info.T.Base_Field (Kind)), + M2E (Chap3.Slice_Base + (Chap3.Get_Array_Base (Prefix), + Slice_Type, + New_Obj_Value (Data.Unsigned_Diff)))); + return Dv2M (Res_D, Slice_Info, Kind); + when Type_Mode_Array => + return Chap3.Slice_Base + (Chap3.Get_Array_Base (Prefix), + Slice_Type, + New_Obj_Value (Data.Unsigned_Diff)); + when others => + raise Internal_Error; + end case; + end if; + end Translate_Slice_Name_Finish; + + function Translate_Slice_Name (Prefix : Mnode; Expr : Iir_Slice_Name) + return Mnode + is + Data : Slice_Name_Data; + begin + Translate_Slice_Name_Init (Prefix, Expr, Data); + return Translate_Slice_Name_Finish (Data.Prefix_Var, Expr, Data); + end Translate_Slice_Name; + + function Translate_Interface_Name + (Inter : Iir; Info : Ortho_Info_Acc; Kind : Object_Kind_Type) + return Mnode + is + Type_Info : constant Type_Info_Acc := Get_Info (Get_Type (Inter)); + begin + case Info.Kind is + when Kind_Object => + -- For a generic or a port. + return Get_Var (Info.Object_Var, Type_Info, Kind); + when Kind_Interface => + -- For a parameter. + if Info.Interface_Field = O_Fnode_Null then + -- Normal case: the parameter was translated as an ortho + -- interface. + case Type_Info.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_By_Value => + return Dv2M (Info.Interface_Node, Type_Info, Kind); + when Type_Mode_By_Copy + | Type_Mode_By_Ref => + -- Parameter is passed by reference. + return Dp2M (Info.Interface_Node, Type_Info, Kind); + end case; + else + -- The parameter was put somewhere else. + declare + Subprg : constant Iir := Get_Parent (Inter); + Subprg_Info : constant Subprg_Info_Acc := + Get_Info (Subprg); + Linter : O_Lnode; + begin + if Info.Interface_Node = O_Dnode_Null then + -- The parameter is passed via a field of the RESULT + -- record parameter. + if Subprg_Info.Res_Record_Var = Null_Var then + Linter := New_Obj (Subprg_Info.Res_Interface); + else + -- Unnesting case. + Linter := Get_Var (Subprg_Info.Res_Record_Var); + end if; + return Lv2M (New_Selected_Element + (New_Acc_Value (Linter), + Info.Interface_Field), + Type_Info, Kind); + else + -- Unnesting case: the parameter was copied in the + -- subprogram frame so that nested subprograms can + -- reference it. Use field in FRAME. + Linter := New_Selected_Element + (Get_Instance_Ref (Subprg_Info.Subprg_Frame_Scope), + Info.Interface_Field); + case Type_Info.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_By_Value => + return Lv2M (Linter, Type_Info, Kind); + when Type_Mode_By_Copy + | Type_Mode_By_Ref => + -- Parameter is passed by reference. + return Lp2M (Linter, Type_Info, Kind); + end case; + end if; + end; + end if; + when others => + raise Internal_Error; + end case; + end Translate_Interface_Name; + + function Translate_Selected_Element (Prefix : Mnode; + El : Iir_Element_Declaration) + return Mnode + is + El_Info : constant Field_Info_Acc := Get_Info (El); + El_Type : constant Iir := Get_Type (El); + El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix); + Stable_Prefix : Mnode; + begin + if Is_Complex_Type (El_Tinfo) then + -- The element is in fact an offset. + Stable_Prefix := Stabilize (Prefix); + return E2M + (New_Unchecked_Address + (New_Slice + (New_Access_Element + (New_Unchecked_Address + (M2Lv (Stable_Prefix), Char_Ptr_Type)), + Chararray_Type, + New_Value + (New_Selected_Element (M2Lv (Stable_Prefix), + El_Info.Field_Node (Kind)))), + El_Tinfo.Ortho_Ptr_Type (Kind)), + El_Tinfo, Kind); + else + return Lv2M (New_Selected_Element (M2Lv (Prefix), + El_Info.Field_Node (Kind)), + El_Tinfo, Kind); + end if; + end Translate_Selected_Element; + +-- function Translate_Formal_Interface_Name (Scope_Type : O_Tnode; +-- Scope_Param : O_Lnode; +-- Name : Iir; +-- Kind : Object_Kind_Type) +-- return Mnode +-- is +-- Type_Info : Type_Info_Acc; +-- Info : Ortho_Info_Acc; +-- Res : Mnode; +-- begin +-- Type_Info := Get_Info (Get_Type (Name)); +-- Info := Get_Info (Name); +-- Push_Scope_Soft (Scope_Type, Scope_Param); +-- Res := Get_Var (Info.Object_Var, Type_Info, Kind); +-- Clear_Scope_Soft (Scope_Type); +-- return Res; +-- end Translate_Formal_Interface_Name; + +-- function Translate_Formal_Name (Scope_Type : O_Tnode; +-- Scope_Param : O_Lnode; +-- Name : Iir) +-- return Mnode +-- is +-- Prefix : Iir; +-- Prefix_Name : Mnode; +-- begin +-- case Get_Kind (Name) is +-- when Iir_Kind_Interface_Constant_Declaration => +-- return Translate_Formal_Interface_Name +-- (Scope_Type, Scope_Param, Name, Mode_Value); + +-- when Iir_Kind_Interface_Signal_Declaration => +-- return Translate_Formal_Interface_Name +-- (Scope_Type, Scope_Param, Name, Mode_Signal); + +-- when Iir_Kind_Indexed_Name => +-- Prefix := Get_Prefix (Name); +-- Prefix_Name := Translate_Formal_Name +-- (Scope_Type, Scope_Param, Prefix); +-- return Translate_Indexed_Name (Prefix_Name, Name); + +-- when Iir_Kind_Slice_Name => +-- Prefix := Get_Prefix (Name); +-- Prefix_Name := Translate_Formal_Name +-- (Scope_Type, Scope_Param, Prefix); +-- return Translate_Slice_Name (Prefix_Name, Name); + +-- when Iir_Kind_Selected_Element => +-- Prefix := Get_Prefix (Name); +-- Prefix_Name := Translate_Formal_Name +-- (Scope_Type, Scope_Param, Prefix); +-- return Translate_Selected_Element +-- (Prefix_Name, Get_Selected_Element (Name)); + +-- when others => +-- Error_Kind ("translate_generic_name", Name); +-- end case; +-- end Translate_Formal_Name; + + function Translate_Name (Name : Iir) return Mnode + is + Name_Type : constant Iir := Get_Type (Name); + Name_Info : constant Ortho_Info_Acc := Get_Info (Name); + Type_Info : constant Type_Info_Acc := Get_Info (Name_Type); + begin + case Get_Kind (Name) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration => + return Get_Var (Name_Info.Object_Var, Type_Info, Mode_Value); + + when Iir_Kind_Attribute_Name => + return Translate_Name (Get_Named_Entity (Name)); + when Iir_Kind_Attribute_Value => + return Get_Var + (Get_Info (Get_Attribute_Specification (Name)).Object_Var, + Type_Info, Mode_Value); + + when Iir_Kind_Object_Alias_Declaration => + -- Alias_Var is not like an object variable, since it is + -- always a pointer to the aliased object. + declare + R : O_Lnode; + begin + R := Get_Var (Name_Info.Alias_Var); + case Type_Info.Type_Mode is + when Type_Mode_Fat_Array => + return Get_Var (Name_Info.Alias_Var, Type_Info, + Name_Info.Alias_Kind); + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Acc + | Type_Mode_Fat_Acc => + R := Get_Var (Name_Info.Alias_Var); + return Lp2M (R, Type_Info, Name_Info.Alias_Kind); + when Type_Mode_Scalar => + R := Get_Var (Name_Info.Alias_Var); + if Name_Info.Alias_Kind = Mode_Signal then + return Lv2M (R, Type_Info, Name_Info.Alias_Kind); + else + return Lp2M (R, Type_Info, Name_Info.Alias_Kind); + end if; + when others => + raise Internal_Error; + end case; + end; + + when Iir_Kind_Signal_Declaration + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Guard_Signal_Declaration => + return Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal); + + when Iir_Kind_Interface_Constant_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Value); + + when Iir_Kind_Interface_File_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Value); + + when Iir_Kind_Interface_Variable_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Value); + + when Iir_Kind_Interface_Signal_Declaration => + return Translate_Interface_Name (Name, Name_Info, Mode_Signal); + + when Iir_Kind_Indexed_Name => + return Translate_Indexed_Name + (Translate_Name (Get_Prefix (Name)), Name); + + when Iir_Kind_Slice_Name => + return Translate_Slice_Name + (Translate_Name (Get_Prefix (Name)), Name); + + when Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference => + declare + Pfx : O_Enode; + begin + Pfx := Chap7.Translate_Expression (Get_Prefix (Name)); + -- FIXME: what about fat pointer ?? + return Lv2M (New_Access_Element (Pfx), + Type_Info, Mode_Value); + end; + + when Iir_Kind_Selected_Element => + return Translate_Selected_Element + (Translate_Name (Get_Prefix (Name)), + Get_Selected_Element (Name)); + + when Iir_Kind_Function_Call => + -- This can appear as a prefix of a name, therefore, the + -- result is always a composite type or an access type. + declare + Imp : constant Iir := Get_Implementation (Name); + Obj : Iir; + Assoc_Chain : Iir; + begin + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration + then + -- FIXME : to be done + raise Internal_Error; + else + Canon.Canon_Subprogram_Call (Name); + Assoc_Chain := Get_Parameter_Association_Chain (Name); + Obj := Get_Method_Object (Name); + return E2M + (Chap7.Translate_Function_Call (Imp, Assoc_Chain, Obj), + Type_Info, Mode_Value); + end if; + end; + + when Iir_Kind_Image_Attribute => + -- Can appear as a prefix. + return E2M (Chap14.Translate_Image_Attribute (Name), + Type_Info, Mode_Value); + + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Translate_Name (Get_Named_Entity (Name)); + + when others => + Error_Kind ("translate_name", Name); + end case; + end Translate_Name; + + procedure Translate_Direct_Driver + (Name : Iir; Sig : out Mnode; Drv : out Mnode) + is + Name_Type : constant Iir := Get_Type (Name); + Name_Info : constant Ortho_Info_Acc := Get_Info (Name); + Type_Info : constant Type_Info_Acc := Get_Info (Name_Type); + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Translate_Direct_Driver (Get_Named_Entity (Name), Sig, Drv); + when Iir_Kind_Object_Alias_Declaration => + Translate_Direct_Driver (Get_Name (Name), Sig, Drv); + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Sig := Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal); + Drv := Get_Var (Name_Info.Object_Driver, Type_Info, Mode_Value); + when Iir_Kind_Slice_Name => + declare + Data : Slice_Name_Data; + Pfx_Sig : Mnode; + Pfx_Drv : Mnode; + begin + Translate_Direct_Driver + (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); + Translate_Slice_Name_Init (Pfx_Sig, Name, Data); + Sig := Translate_Slice_Name_Finish + (Data.Prefix_Var, Name, Data); + Drv := Translate_Slice_Name_Finish (Pfx_Drv, Name, Data); + end; + when Iir_Kind_Indexed_Name => + declare + Data : Indexed_Name_Data; + Pfx_Sig : Mnode; + Pfx_Drv : Mnode; + begin + Translate_Direct_Driver + (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); + Data := Translate_Indexed_Name_Init (Pfx_Sig, Name); + Sig := Data.Res; + Drv := Translate_Indexed_Name_Finish (Pfx_Drv, Name, Data); + end; + when Iir_Kind_Selected_Element => + declare + El : Iir; + Pfx_Sig : Mnode; + Pfx_Drv : Mnode; + begin + Translate_Direct_Driver + (Get_Prefix (Name), Pfx_Sig, Pfx_Drv); + El := Get_Selected_Element (Name); + Sig := Translate_Selected_Element (Pfx_Sig, El); + Drv := Translate_Selected_Element (Pfx_Drv, El); + end; + when others => + Error_Kind ("translate_direct_driver", Name); + end case; + end Translate_Direct_Driver; + end Chap6; + + package body Chap7 is + function Is_Static_Constant (Decl : Iir_Constant_Declaration) + return Boolean + is + Expr : constant Iir := Get_Default_Value (Decl); + Atype : Iir; + Info : Iir; + begin + if Expr = Null_Iir + or else Get_Kind (Expr) = Iir_Kind_Overflow_Literal + then + -- Deferred constant. + return False; + end if; + + if Get_Expr_Staticness (Decl) = Locally then + return True; + end if; + + -- Only aggregates are handled. + if Get_Kind (Expr) /= Iir_Kind_Aggregate then + return False; + end if; + + Atype := Get_Type (Decl); + -- Bounds must be known (and static). + if Get_Type_Staticness (Atype) /= Locally then + return False; + end if; + + -- Currently, only array aggregates are handled. + if Get_Kind (Get_Base_Type (Atype)) /= Iir_Kind_Array_Type_Definition + then + return False; + end if; + + -- Aggregate elements must be locally static. + -- Note: this does not yet handled aggregates of aggregates. + if Get_Value_Staticness (Expr) /= Locally then + return False; + end if; + Info := Get_Aggregate_Info (Expr); + while Info /= Null_Iir loop + if Get_Aggr_Dynamic_Flag (Info) then + raise Internal_Error; + end if; + + -- Currently, only positionnal aggregates are handled. + if Get_Aggr_Named_Flag (Info) then + return False; + end if; + -- Currently, others choice are not handled. + if Get_Aggr_Others_Flag (Info) then + return False; + end if; + + Info := Get_Sub_Aggregate_Info (Info); + end loop; + return True; + end Is_Static_Constant; + + procedure Translate_Static_String_Literal_Inner + (List : in out O_Array_Aggr_List; + Str : Iir; + El_Type : Iir) + is + use Name_Table; + + Literal_List : Iir_List; + Lit : Iir; + Len : Nat32; + Ptr : String_Fat_Acc; + begin + Literal_List := + Get_Enumeration_Literal_List (Get_Base_Type (El_Type)); + Len := Get_String_Length (Str); + Ptr := Get_String_Fat_Acc (Str); + for I in 1 .. Len loop + Lit := Find_Name_In_List (Literal_List, Get_Identifier (Ptr (I))); + New_Array_Aggr_El (List, Get_Ortho_Expr (Lit)); + end loop; + end Translate_Static_String_Literal_Inner; + + procedure Translate_Static_Bit_String_Literal_Inner + (List : in out O_Array_Aggr_List; + Lit : Iir_Bit_String_Literal; + El_Type : Iir) + is + pragma Unreferenced (El_Type); + L_0 : O_Cnode; + L_1 : O_Cnode; + Ptr : String_Fat_Acc; + Len : Nat32; + V : O_Cnode; + begin + L_0 := Get_Ortho_Expr (Get_Bit_String_0 (Lit)); + L_1 := Get_Ortho_Expr (Get_Bit_String_1 (Lit)); + Ptr := Get_String_Fat_Acc (Lit); + Len := Get_String_Length (Lit); + for I in 1 .. Len loop + case Ptr (I) is + when '0' => + V := L_0; + when '1' => + V := L_1; + when others => + raise Internal_Error; + end case; + New_Array_Aggr_El (List, V); + end loop; + end Translate_Static_Bit_String_Literal_Inner; + + procedure Translate_Static_Aggregate_1 (List : in out O_Array_Aggr_List; + Aggr : Iir; + Info : Iir; + El_Type : Iir) + is + Assoc : Iir; + N_Info : Iir; + Sub : Iir; + begin + N_Info := Get_Sub_Aggregate_Info (Info); + + case Get_Kind (Aggr) is + when Iir_Kind_Aggregate => + Assoc := Get_Association_Choices_Chain (Aggr); + while Assoc /= Null_Iir loop + Sub := Get_Associated_Expr (Assoc); + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + if N_Info = Null_Iir then + New_Array_Aggr_El + (List, + Translate_Static_Expression (Sub, El_Type)); + else + Translate_Static_Aggregate_1 + (List, Sub, N_Info, El_Type); + end if; + when others => + Error_Kind ("translate_static_aggregate_1(2)", Assoc); + end case; + Assoc := Get_Chain (Assoc); + end loop; + when Iir_Kind_String_Literal => + if N_Info /= Null_Iir then + raise Internal_Error; + end if; + Translate_Static_String_Literal_Inner (List, Aggr, El_Type); + when Iir_Kind_Bit_String_Literal => + if N_Info /= Null_Iir then + raise Internal_Error; + end if; + Translate_Static_Bit_String_Literal_Inner (List, Aggr, El_Type); + when others => + Error_Kind ("translate_static_aggregate_1", Aggr); + end case; + end Translate_Static_Aggregate_1; + + function Translate_Static_Aggregate (Aggr : Iir) + return O_Cnode + is + Aggr_Type : constant Iir := Get_Type (Aggr); + El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, True); + Start_Array_Aggr (List, Get_Ortho_Type (Aggr_Type, Mode_Value)); + + Translate_Static_Aggregate_1 + (List, Aggr, Get_Aggregate_Info (Aggr), El_Type); + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_Aggregate; + + function Translate_Static_Simple_Aggregate (Aggr : Iir) + return O_Cnode + is + Aggr_Type : Iir; + El_List : Iir_List; + El : Iir; + El_Type : Iir; + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Aggr_Type := Get_Type (Aggr); + Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, True); + El_Type := Get_Element_Subtype (Aggr_Type); + El_List := Get_Simple_Aggregate_List (Aggr); + Start_Array_Aggr (List, Get_Ortho_Type (Aggr_Type, Mode_Value)); + + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + New_Array_Aggr_El + (List, Translate_Static_Expression (El, El_Type)); + end loop; + + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_Simple_Aggregate; + + function Translate_Static_String_Literal (Str : Iir) + return O_Cnode + is + use Name_Table; + + 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, Arr_Type); + + Element_Type := Get_Element_Subtype (Lit_Type); + + Translate_Static_String_Literal_Inner (List, Str, Element_Type); + + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_String_Literal; + + -- Create a variable (constant) for string or bit string literal STR. + -- The type of the literal element is ELEMENT_TYPE, and the ortho type + -- of the string (a constrained array type) is STR_TYPE. + function Create_String_Literal_Var_Inner + (Str : Iir; Element_Type : Iir; Str_Type : O_Tnode) + return Var_Type + is + use Name_Table; + + Val_Aggr : O_Array_Aggr_List; + Res : O_Cnode; + begin + Start_Array_Aggr (Val_Aggr, Str_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); + + return Create_Global_Const + (Create_Uniq_Identifier, Str_Type, O_Storage_Private, Res); + end Create_String_Literal_Var_Inner; + + -- Create a variable (constant) for string or bit string literal STR. + function Create_String_Literal_Var (Str : Iir) return Var_Type is + use Name_Table; + + Str_Type : constant Iir := Get_Type (Str); + Arr_Type : O_Tnode; + begin + -- Create the string value. + Arr_Type := New_Constrained_Array_Type + (Get_Info (Str_Type).T.Base_Type (Mode_Value), + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Get_String_Length (Str)))); + + return Create_String_Literal_Var_Inner + (Str, Get_Element_Subtype (Str_Type), Arr_Type); + end Create_String_Literal_Var; + + -- 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_Non_Static_String_Literal (Str : Iir) + return O_Enode + is + use Name_Table; + + Lit_Type : constant Iir := Get_Type (Str); + Type_Info : constant Type_Info_Acc := Get_Info (Lit_Type); + Index_Type : constant Iir := Get_Index_Type (Lit_Type, 0); + Index_Type_Info : constant Type_Info_Acc := Get_Info (Index_Type); + Bound_Aggr : O_Record_Aggr_List; + Index_Aggr : O_Record_Aggr_List; + Res_Aggr : O_Record_Aggr_List; + Res : O_Cnode; + Len : Int32; + Val : Var_Type; + Bound : Var_Type; + R : O_Enode; + begin + -- Create the string value. + Len := Get_String_Length (Str); + Val := Create_String_Literal_Var (Str); + + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + -- Create the string bound. + 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); + + Val := Create_Global_Const + (Create_Uniq_Identifier, Type_Info.Ortho_Type (Mode_Value), + O_Storage_Private, Res); + elsif Type_Info.Type_Mode = Type_Mode_Array then + -- Type of string literal isn't statically known; check the + -- length. + Chap6.Check_Bound_Error + (New_Compare_Op + (ON_Neq, + New_Lit (New_Index_Lit (Unsigned_64 (Len))), + Chap3.Get_Array_Type_Length (Lit_Type), + Ghdl_Bool_Type), + Str, 1); + else + raise Internal_Error; + end if; + + R := New_Address (Get_Var (Val), + Type_Info.Ortho_Ptr_Type (Mode_Value)); + 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) + return O_Cnode + is + use Name_Table; + + Literal_List : Iir_List; + Lit : Iir; + List : O_Array_Aggr_List; + Res : O_Cnode; + begin + Chap3.Translate_Anonymous_Type_Definition (Str_Type, True); + + Start_Array_Aggr (List, Get_Ortho_Type (Str_Type, Mode_Value)); + + Literal_List := + Get_Enumeration_Literal_List (Character_Type_Definition); + Image (Str_Ident); + for I in 1 .. Name_Length loop + Lit := Get_Nth_Element (Literal_List, + Character'Pos (Name_Buffer (I))); + New_Array_Aggr_El (List, Get_Ortho_Expr (Lit)); + end loop; + + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_String; + + function Translate_Static_Bit_String_Literal + (Lit : Iir_Bit_String_Literal) + return O_Cnode + is + Lit_Type : Iir; + Res : O_Cnode; + List : O_Array_Aggr_List; + begin + Lit_Type := Get_Type (Lit); + Chap3.Translate_Anonymous_Type_Definition (Lit_Type, True); + Start_Array_Aggr (List, Get_Ortho_Type (Lit_Type, Mode_Value)); + Translate_Static_Bit_String_Literal_Inner (List, Lit, Lit_Type); + Finish_Array_Aggr (List, Res); + return Res; + end Translate_Static_Bit_String_Literal; + + function Translate_String_Literal (Str : Iir) return O_Enode + is + Str_Type : constant Iir := Get_Type (Str); + Var : Var_Type; + Info : Type_Info_Acc; + Res : O_Cnode; + R : O_Enode; + begin + if Get_Constraint_State (Str_Type) = Fully_Constrained + and then + Get_Type_Staticness (Get_Index_Type (Str_Type, 0)) = Locally + then + Chap3.Create_Array_Subtype (Str_Type, True); + 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; + 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)); + return R; + else + return Translate_Non_Static_String_Literal (Str); + end if; + end Translate_String_Literal; + + function Translate_Static_Implicit_Conv + (Expr : O_Cnode; Expr_Type : Iir; Res_Type : Iir) return O_Cnode + is + Expr_Info : Type_Info_Acc; + Res_Info : Type_Info_Acc; + Val : Var_Type; + Res : O_Cnode; + List : O_Record_Aggr_List; + Bound : Var_Type; + begin + if Res_Type = Expr_Type then + return Expr; + end if; + if Get_Kind (Expr_Type) /= Iir_Kind_Array_Subtype_Definition then + raise Internal_Error; + end if; + if Get_Kind (Res_Type) = Iir_Kind_Array_Subtype_Definition then + return Expr; + end if; + if Get_Kind (Res_Type) /= Iir_Kind_Array_Type_Definition then + raise Internal_Error; + end if; + Expr_Info := Get_Info (Expr_Type); + Res_Info := Get_Info (Res_Type); + Val := Create_Global_Const + (Create_Uniq_Identifier, Expr_Info.Ortho_Type (Mode_Value), + O_Storage_Private, Expr); + Bound := Expr_Info.T.Array_Bounds; + if Bound = Null_Var then + Bound := Create_Global_Const + (Create_Uniq_Identifier, Expr_Info.T.Bounds_Type, + O_Storage_Private, + Chap3.Create_Static_Array_Subtype_Bounds (Expr_Type)); + Expr_Info.T.Array_Bounds := Bound; + end if; + + Start_Record_Aggr (List, Res_Info.Ortho_Type (Mode_Value)); + New_Record_Aggr_El + (List, New_Global_Address (Get_Var_Label (Val), + Res_Info.T.Base_Ptr_Type (Mode_Value))); + New_Record_Aggr_El + (List, New_Global_Address (Get_Var_Label (Bound), + Expr_Info.T.Bounds_Ptr_Type)); + Finish_Record_Aggr (List, Res); + return Res; + end Translate_Static_Implicit_Conv; + + function Translate_Numeric_Literal (Expr : Iir; Res_Type : O_Tnode) + return O_Cnode + is + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal => + return New_Signed_Literal + (Res_Type, Integer_64 (Get_Value (Expr))); + + when Iir_Kind_Enumeration_Literal => + return Get_Ortho_Expr (Get_Enumeration_Decl (Expr)); + + when Iir_Kind_Floating_Point_Literal => + return New_Float_Literal + (Res_Type, IEEE_Float_64 (Get_Fp_Value (Expr))); + + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Unit_Declaration => + return New_Signed_Literal + (Res_Type, Integer_64 (Get_Physical_Value (Expr))); + + when others => + Error_Kind ("translate_numeric_literal", Expr); + end case; + exception + when Constraint_Error => + -- Can be raised by Get_Physical_Unit_Value because of the kludge + -- on staticness. + Error_Msg_Elab ("numeric literal not in range", Expr); + return New_Signed_Literal (Res_Type, 0); + end Translate_Numeric_Literal; + + function Translate_Numeric_Literal (Expr : Iir; Res_Type : Iir) + return O_Cnode + is + Expr_Type : Iir; + Expr_Otype : O_Tnode; + Tinfo : Type_Info_Acc; + begin + Expr_Type := Get_Type (Expr); + Tinfo := Get_Info (Expr_Type); + if Res_Type /= Null_Iir then + Expr_Otype := Get_Ortho_Type (Res_Type, Mode_Value); + else + if Tinfo = null then + -- FIXME: this is a working kludge, in the case where EXPR_TYPE + -- is a subtype which was not yet translated. + -- (eg: evaluated array attribute) + Tinfo := Get_Info (Get_Base_Type (Expr_Type)); + end if; + Expr_Otype := Tinfo.Ortho_Type (Mode_Value); + end if; + return Translate_Numeric_Literal (Expr, Expr_Otype); + end Translate_Numeric_Literal; + + function Translate_Static_Expression (Expr : Iir; Res_Type : Iir) + return O_Cnode + is + Expr_Type : constant Iir := Get_Type (Expr); + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Floating_Point_Literal + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Unit_Declaration + | Iir_Kind_Physical_Fp_Literal => + return Translate_Numeric_Literal (Expr, Res_Type); + + when Iir_Kind_String_Literal => + return Translate_Static_Implicit_Conv + (Translate_Static_String_Literal (Expr), Expr_Type, Res_Type); + when Iir_Kind_Bit_String_Literal => + return Translate_Static_Implicit_Conv + (Translate_Static_Bit_String_Literal (Expr), + Expr_Type, Res_Type); + when Iir_Kind_Simple_Aggregate => + return Translate_Static_Implicit_Conv + (Translate_Static_Simple_Aggregate (Expr), + Expr_Type, Res_Type); + when Iir_Kind_Aggregate => + return Translate_Static_Implicit_Conv + (Translate_Static_Aggregate (Expr), Expr_Type, Res_Type); + + when Iir_Kinds_Denoting_Name => + return Translate_Static_Expression + (Get_Named_Entity (Expr), Res_Type); + when others => + Error_Kind ("translate_static_expression", Expr); + end case; + end Translate_Static_Expression; + + function Translate_Static_Range_Left + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode + is + Left : O_Cnode; + Bound : Iir; + begin + Bound := Get_Left_Limit (Expr); + Left := Chap7.Translate_Static_Expression (Bound, Range_Type); +-- if Range_Type /= Null_Iir and then Get_Type (Bound) /= Range_Type then +-- Left := New_Convert_Ov +-- (Left, Get_Ortho_Type (Range_Type, Mode_Value)); +-- end if; + return Left; + end Translate_Static_Range_Left; + + function Translate_Static_Range_Right + (Expr : Iir; Range_Type : Iir := Null_Iir) + return O_Cnode + is + Right : O_Cnode; + begin + Right := Chap7.Translate_Static_Expression (Get_Right_Limit (Expr), + Range_Type); +-- if Range_Type /= Null_Iir then +-- Right := New_Convert_Ov +-- (Right, Get_Ortho_Type (Range_Type, Mode_Value)); +-- end if; + return Right; + end Translate_Static_Range_Right; + + function Translate_Static_Range_Dir (Expr : Iir) return O_Cnode + is + begin + case Get_Direction (Expr) is + when Iir_To => + return Ghdl_Dir_To_Node; + when Iir_Downto => + return Ghdl_Dir_Downto_Node; + end case; + end Translate_Static_Range_Dir; + + function Translate_Static_Range_Length (Expr : Iir) return O_Cnode + is + Ulen : Unsigned_64; + begin + Ulen := Unsigned_64 (Eval_Discrete_Range_Length (Expr)); + return New_Unsigned_Literal (Ghdl_Index_Type, Ulen); + end Translate_Static_Range_Length; + + function Translate_Range_Expression_Left (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode + is + Left : O_Enode; + begin + Left := Chap7.Translate_Expression (Get_Left_Limit (Expr)); + if Range_Type /= Null_Iir then + Left := New_Convert_Ov (Left, + Get_Ortho_Type (Range_Type, Mode_Value)); + end if; + return Left; + end Translate_Range_Expression_Left; + + function Translate_Range_Expression_Right (Expr : Iir; + Range_Type : Iir := Null_Iir) + return O_Enode + is + Right : O_Enode; + begin + Right := Chap7.Translate_Expression (Get_Right_Limit (Expr)); + if Range_Type /= Null_Iir then + Right := New_Convert_Ov (Right, + Get_Ortho_Type (Range_Type, Mode_Value)); + end if; + return Right; + end Translate_Range_Expression_Right; + + -- Compute the length of LEFT DIR (to/downto) RIGHT. + function Compute_Range_Length + (Left : O_Enode; Right : O_Enode; Dir : Iir_Direction) + return O_Enode + is + L : O_Enode; + R : O_Enode; + Val : O_Enode; + Tmp : O_Dnode; + Res : O_Dnode; + If_Blk : O_If_Block; + Rng_Type : O_Tnode; + begin + Rng_Type := Ghdl_I32_Type; + L := New_Convert_Ov (Left, Rng_Type); + R := New_Convert_Ov (Right, Rng_Type); + + case Dir is + when Iir_To => + Val := New_Dyadic_Op (ON_Sub_Ov, R, L); + when Iir_Downto => + Val := New_Dyadic_Op (ON_Sub_Ov, L, R); + end case; + + Res := Create_Temp (Ghdl_Index_Type); + Open_Temp; + Tmp := Create_Temp (Rng_Type); + New_Assign_Stmt (New_Obj (Tmp), Val); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Lt, New_Obj_Value (Tmp), + New_Lit (New_Signed_Literal (Rng_Type, 0)), + Ghdl_Bool_Type)); + Init_Var (Res); + New_Else_Stmt (If_Blk); + Val := New_Convert_Ov (New_Obj_Value (Tmp), Ghdl_Index_Type); + Val := New_Dyadic_Op (ON_Add_Ov, Val, New_Lit (Ghdl_Index_1)); + New_Assign_Stmt (New_Obj (Res), Val); + Finish_If_Stmt (If_Blk); + Close_Temp; + return New_Obj_Value (Res); + end Compute_Range_Length; + + function Translate_Range_Expression_Length (Expr : Iir) return O_Enode + is + Left, Right : O_Enode; + begin + if Get_Expr_Staticness (Expr) = Locally then + return New_Lit (Translate_Static_Range_Length (Expr)); + else + Left := Chap7.Translate_Expression (Get_Left_Limit (Expr)); + Right := Chap7.Translate_Expression (Get_Right_Limit (Expr)); + + return Compute_Range_Length (Left, Right, Get_Direction (Expr)); + end if; + end Translate_Range_Expression_Length; + + function Translate_Range_Length (Expr : Iir) return O_Enode is + begin + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + return Translate_Range_Expression_Length (Expr); + when Iir_Kind_Range_Array_Attribute => + return Chap14.Translate_Length_Array_Attribute (Expr, Null_Iir); + when others => + Error_Kind ("translate_range_length", Expr); + end case; + end Translate_Range_Length; + + function Translate_Association (Assoc : Iir) return O_Enode + is + Formal : constant Iir := Get_Formal (Assoc); + Formal_Base : constant Iir := Get_Association_Interface (Assoc); + Actual : Iir; + begin + case Get_Kind (Assoc) is + when Iir_Kind_Association_Element_By_Expression => + Actual := Get_Actual (Assoc); + when Iir_Kind_Association_Element_Open => + Actual := Get_Default_Value (Formal); + when others => + Error_Kind ("translate_association", Assoc); + end case; + + case Get_Kind (Formal_Base) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration => + return Chap3.Maybe_Insert_Scalar_Check + (Translate_Expression (Actual, Get_Type (Formal)), + Actual, Get_Type (Formal)); + when Iir_Kind_Interface_Signal_Declaration => + return Translate_Implicit_Conv + (M2E (Chap6.Translate_Name (Actual)), + Get_Type (Actual), + Get_Type (Formal_Base), + Mode_Signal, Assoc); + when others => + Error_Kind ("translate_association", Formal); + end case; + end Translate_Association; + + function Translate_Function_Call + (Imp : Iir; Assoc_Chain : Iir; Obj : Iir) + return O_Enode + is + Info : constant Subprg_Info_Acc := Get_Info (Imp); + Constr : O_Assoc_List; + Assoc : Iir; + Res : Mnode; + begin + if Info.Use_Stack2 then + Create_Temp_Stack2_Mark; + end if; + + if Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + -- If we need to allocate, do it before starting the call! + declare + Res_Type : Iir; + Res_Info : Type_Info_Acc; + begin + Res_Type := Get_Return_Type (Imp); + Res_Info := Get_Info (Res_Type); + Res := Create_Temp (Res_Info); + if Res_Info.Type_Mode /= Type_Mode_Fat_Array then + Chap4.Allocate_Complex_Object (Res_Type, Alloc_Stack, Res); + end if; + end; + end if; + + Start_Association (Constr, Info.Ortho_Func); + + if Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Association (Constr, M2E (Res)); + end if; + + -- If the subprogram is a method, pass the protected object. + if Obj /= Null_Iir then + New_Association (Constr, M2E (Chap6.Translate_Name (Obj))); + else + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + end if; + + Assoc := Assoc_Chain; + while Assoc /= Null_Iir loop + -- FIXME: evaluate expression before, because we + -- may allocate objects. + New_Association (Constr, Translate_Association (Assoc)); + Assoc := Get_Chain (Assoc); + end loop; + + if Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Procedure_Call (Constr); + return M2E (Res); + else + return New_Function_Call (Constr); + end if; + end Translate_Function_Call; + + function Translate_Operator_Function_Call + (Imp : Iir; Left : Iir; Right : Iir; Res_Type : Iir) + return O_Enode + is + function Create_Assoc (Actual : Iir; Formal : Iir) + return Iir + is + R : Iir; + begin + R := Create_Iir (Iir_Kind_Association_Element_By_Expression); + Location_Copy (R, Actual); + Set_Actual (R, Actual); + Set_Formal (R, Formal); + return R; + end Create_Assoc; + + Inter : Iir; + El_L : Iir; + El_R : Iir; + Res : O_Enode; + begin + Inter := Get_Interface_Declaration_Chain (Imp); + + El_L := Create_Assoc (Left, Inter); + + if Right /= Null_Iir then + Inter := Get_Chain (Inter); + El_R := Create_Assoc (Right, Inter); + Set_Chain (El_L, El_R); + end if; + + Res := Translate_Function_Call (Imp, El_L, Null_Iir); + + Free_Iir (El_L); + if Right /= Null_Iir then + Free_Iir (El_R); + end if; + + return Translate_Implicit_Conv + (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Left); + end Translate_Operator_Function_Call; + + function Convert_Constrained_To_Unconstrained + (Expr : Mnode; Res_Type : Iir) + return Mnode + is + Type_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Expr); + Stable_Expr : Mnode; + Res : Mnode; + begin + Res := Create_Temp (Type_Info, Kind); + Stable_Expr := Stabilize (Expr); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (Stable_Expr)), + Type_Info.T.Base_Ptr_Type (Kind))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (Stable_Expr))); + return Res; + end Convert_Constrained_To_Unconstrained; + + function Convert_Array_To_Thin_Array (Expr : Mnode; + Expr_Type : Iir; + Atype : Iir; + Loc : Iir) + return Mnode + is + Expr_Indexes : constant Iir_List := + Get_Index_Subtype_List (Expr_Type); + Expr_Stable : Mnode; + Success_Label, Failure_Label : O_Snode; + begin + Expr_Stable := Stabilize (Expr); + + Open_Temp; + -- Check each dimension. + Start_Loop_Stmt (Success_Label); + Start_Loop_Stmt (Failure_Label); + for I in 1 .. Get_Nbr_Elements (Expr_Indexes) loop + Gen_Exit_When + (Failure_Label, + New_Compare_Op + (ON_Neq, + Chap6.Get_Array_Bound_Length + (Expr_Stable, Expr_Type, I), + Chap6.Get_Array_Bound_Length + (T2M (Atype, Get_Object_Kind (Expr_Stable)), Atype, I), + Ghdl_Bool_Type)); + end loop; + New_Exit_Stmt (Success_Label); + Finish_Loop_Stmt (Failure_Label); + Chap6.Gen_Bound_Error (Loc); + Finish_Loop_Stmt (Success_Label); + Close_Temp; + + return Chap3.Get_Array_Base (Expr_Stable); + end Convert_Array_To_Thin_Array; + + function Translate_Implicit_Array_Conversion + (Expr : Mnode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return Mnode + is + Ainfo : Type_Info_Acc; + Einfo : Type_Info_Acc; + begin + pragma Assert + (Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition); + + if Res_Type = Expr_Type then + return Expr; + end if; + + Ainfo := Get_Info (Res_Type); + Einfo := Get_Info (Expr_Type); + case Ainfo.Type_Mode is + when Type_Mode_Fat_Array => + -- X to unconstrained. + case Einfo.Type_Mode is + when Type_Mode_Fat_Array => + -- unconstrained to unconstrained. + return Expr; + when Type_Mode_Array => + -- constrained to unconstrained. + return Convert_Constrained_To_Unconstrained + (Expr, Res_Type); + when others => + raise Internal_Error; + end case; + when Type_Mode_Array => + -- X to constrained. + if Einfo.Type_Locally_Constrained + and then Ainfo.Type_Locally_Constrained + then + -- FIXME: optimize static vs non-static + -- constrained to constrained. + if not Chap3.Locally_Array_Match (Expr_Type, Res_Type) then + -- FIXME: generate a bound error ? + -- Even if this is caught at compile-time, + -- the code is not required to run. + Chap6.Gen_Bound_Error (Loc); + end if; + return Expr; + else + -- Unbounded/bounded array to bounded array. + return Convert_Array_To_Thin_Array + (Expr, Expr_Type, Res_Type, Loc); + end if; + when others => + raise Internal_Error; + end case; + end Translate_Implicit_Array_Conversion; + + -- Convert (if necessary) EXPR translated from EXPR_ORIG to type ATYPE. + function Translate_Implicit_Conv (Expr : O_Enode; + Expr_Type : Iir; + Atype : Iir; + Is_Sig : Object_Kind_Type; + Loc : Iir) + return O_Enode is + begin + -- Same type: nothing to do. + if Atype = Expr_Type then + return Expr; + end if; + + if Expr_Type = Universal_Integer_Type_Definition then + return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); + elsif Expr_Type = Universal_Real_Type_Definition then + return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); + elsif Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition then + return M2E (Translate_Implicit_Array_Conversion + (E2M (Expr, Get_Info (Expr_Type), Is_Sig), + Expr_Type, Atype, Loc)); + else + return Expr; + end if; + end Translate_Implicit_Conv; + + type Predefined_To_Onop_Type is array (Iir_Predefined_Functions) + of ON_Op_Kind; + Predefined_To_Onop : constant Predefined_To_Onop_Type := + (Iir_Predefined_Boolean_Or => ON_Or, + Iir_Predefined_Boolean_Not => ON_Not, + Iir_Predefined_Boolean_And => ON_And, + Iir_Predefined_Boolean_Xor => ON_Xor, + + Iir_Predefined_Bit_Not => ON_Not, + Iir_Predefined_Bit_And => ON_And, + Iir_Predefined_Bit_Or => ON_Or, + Iir_Predefined_Bit_Xor => ON_Xor, + + Iir_Predefined_Integer_Equality => ON_Eq, + Iir_Predefined_Integer_Inequality => ON_Neq, + Iir_Predefined_Integer_Less_Equal => ON_Le, + Iir_Predefined_Integer_Less => ON_Lt, + Iir_Predefined_Integer_Greater => ON_Gt, + Iir_Predefined_Integer_Greater_Equal => ON_Ge, + Iir_Predefined_Integer_Plus => ON_Add_Ov, + Iir_Predefined_Integer_Minus => ON_Sub_Ov, + Iir_Predefined_Integer_Mul => ON_Mul_Ov, + Iir_Predefined_Integer_Rem => ON_Rem_Ov, + Iir_Predefined_Integer_Mod => ON_Mod_Ov, + Iir_Predefined_Integer_Div => ON_Div_Ov, + Iir_Predefined_Integer_Absolute => ON_Abs_Ov, + Iir_Predefined_Integer_Negation => ON_Neg_Ov, + + Iir_Predefined_Enum_Equality => ON_Eq, + Iir_Predefined_Enum_Inequality => ON_Neq, + Iir_Predefined_Enum_Greater_Equal => ON_Ge, + Iir_Predefined_Enum_Greater => ON_Gt, + Iir_Predefined_Enum_Less => ON_Lt, + Iir_Predefined_Enum_Less_Equal => ON_Le, + + Iir_Predefined_Physical_Equality => ON_Eq, + Iir_Predefined_Physical_Inequality => ON_Neq, + Iir_Predefined_Physical_Less => ON_Lt, + Iir_Predefined_Physical_Less_Equal => ON_Le, + Iir_Predefined_Physical_Greater => ON_Gt, + Iir_Predefined_Physical_Greater_Equal => ON_Ge, + Iir_Predefined_Physical_Negation => ON_Neg_Ov, + Iir_Predefined_Physical_Absolute => ON_Abs_Ov, + Iir_Predefined_Physical_Minus => ON_Sub_Ov, + Iir_Predefined_Physical_Plus => ON_Add_Ov, + + Iir_Predefined_Floating_Greater => ON_Gt, + Iir_Predefined_Floating_Greater_Equal => ON_Ge, + Iir_Predefined_Floating_Less => ON_Lt, + Iir_Predefined_Floating_Less_Equal => ON_Le, + Iir_Predefined_Floating_Equality => ON_Eq, + Iir_Predefined_Floating_Inequality => ON_Neq, + Iir_Predefined_Floating_Minus => ON_Sub_Ov, + Iir_Predefined_Floating_Plus => ON_Add_Ov, + Iir_Predefined_Floating_Mul => ON_Mul_Ov, + Iir_Predefined_Floating_Div => ON_Div_Ov, + Iir_Predefined_Floating_Negation => ON_Neg_Ov, + Iir_Predefined_Floating_Absolute => ON_Abs_Ov, + + others => ON_Nil); + + function Translate_Shortcut_Operator + (Imp : Iir_Implicit_Function_Declaration; Left, Right : Iir) + return O_Enode + is + Rtype : Iir; + Res : O_Dnode; + Res_Type : O_Tnode; + If_Blk : O_If_Block; + Val : Integer; + V : O_Cnode; + Kind : Iir_Predefined_Functions; + Invert : Boolean; + begin + Rtype := Get_Return_Type (Imp); + Res_Type := Get_Ortho_Type (Rtype, Mode_Value); + Res := Create_Temp (Res_Type); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Left)); + Close_Temp; + Kind := Get_Implicit_Definition (Imp); + + -- Short cut: RIGHT is the result (and must be evaluated) iff + -- LEFT is equal to VAL (ie '0' or false for 0, '1' or true for 1). + case Kind is + when Iir_Predefined_Bit_And + | Iir_Predefined_Boolean_And => + Invert := False; + Val := 1; + when Iir_Predefined_Bit_Nand + | Iir_Predefined_Boolean_Nand => + Invert := True; + Val := 1; + when Iir_Predefined_Bit_Or + | Iir_Predefined_Boolean_Or => + Invert := False; + Val := 0; + when Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_Nor => + Invert := True; + Val := 0; + when others => + Ada.Text_IO.Put_Line + ("translate_shortcut_operator: cannot handle " + & Iir_Predefined_Functions'Image (Kind)); + raise Internal_Error; + end case; + + V := Get_Ortho_Expr + (Get_Nth_Element (Get_Enumeration_Literal_List (Rtype), Val)); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Eq, + New_Obj_Value (Res), New_Lit (V), + Ghdl_Bool_Type)); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), Chap7.Translate_Expression (Right)); + Close_Temp; + Finish_If_Stmt (If_Blk); + if Invert then + return New_Monadic_Op (ON_Not, New_Obj_Value (Res)); + else + return New_Obj_Value (Res); + end if; + end Translate_Shortcut_Operator; + + function Translate_Lib_Operator (Left, Right : O_Enode; Func : O_Dnode) + return O_Enode + is + Constr : O_Assoc_List; + begin + Start_Association (Constr, Func); + New_Association (Constr, Left); + if Right /= O_Enode_Null then + New_Association (Constr, Right); + end if; + return New_Function_Call (Constr); + end Translate_Lib_Operator; + + function Translate_Predefined_Lib_Operator + (Left, Right : O_Enode; Func : Iir_Implicit_Function_Declaration) + return O_Enode + is + Info : constant Subprg_Info_Acc := Get_Info (Func); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + New_Association (Constr, Left); + if Right /= O_Enode_Null then + New_Association (Constr, Right); + end if; + return New_Function_Call (Constr); + end Translate_Predefined_Lib_Operator; + + function Translate_Predefined_Array_Operator + (Left, Right : O_Enode; Func : Iir) + return O_Enode + is + Res : O_Dnode; + Constr : O_Assoc_List; + Info : Type_Info_Acc; + Func_Info : Subprg_Info_Acc; + begin + Create_Temp_Stack2_Mark; + Info := Get_Info (Get_Return_Type (Func)); + Res := Create_Temp (Info.Ortho_Type (Mode_Value)); + Func_Info := Get_Info (Func); + Start_Association (Constr, Func_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Constr, Func_Info.Subprg_Instance); + New_Association (Constr, + New_Address (New_Obj (Res), + Info.Ortho_Ptr_Type (Mode_Value))); + New_Association (Constr, Left); + if Right /= O_Enode_Null then + New_Association (Constr, Right); + end if; + New_Procedure_Call (Constr); + return New_Address (New_Obj (Res), Info.Ortho_Ptr_Type (Mode_Value)); + end Translate_Predefined_Array_Operator; + + function Translate_Predefined_Array_Operator_Convert + (Left, Right : O_Enode; Func : Iir; Res_Type : Iir) + return O_Enode + is + Res : O_Enode; + Ret_Type : Iir; + begin + Ret_Type := Get_Return_Type (Func); + Res := Translate_Predefined_Array_Operator (Left, Right, Func); + return Translate_Implicit_Conv + (Res, Ret_Type, Res_Type, Mode_Value, Func); + end Translate_Predefined_Array_Operator_Convert; + + -- Create an array aggregate containing one element, EL. + function Translate_Element_To_Array (El : O_Enode; Arr_Type : Iir) + return O_Enode + is + Res : O_Dnode; + Ainfo : Type_Info_Acc; + Einfo : Type_Info_Acc; + V : O_Dnode; + begin + Ainfo := Get_Info (Arr_Type); + Einfo := Get_Info (Get_Element_Subtype (Arr_Type)); + Res := Create_Temp (Ainfo.Ortho_Type (Mode_Value)); + if Is_Composite (Einfo) then + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Ainfo.T.Base_Field (Mode_Value)), + New_Convert_Ov (El, Ainfo.T.Base_Ptr_Type (Mode_Value))); + else + V := Create_Temp_Init (Einfo.Ortho_Type (Mode_Value), El); + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Ainfo.T.Base_Field (Mode_Value)), + New_Convert_Ov (New_Address (New_Obj (V), + Einfo.Ortho_Ptr_Type (Mode_Value)), + Ainfo.T.Base_Ptr_Type (Mode_Value))); + end if; + New_Assign_Stmt + (New_Selected_Element (New_Obj (Res), + Ainfo.T.Bounds_Field (Mode_Value)), + New_Address (Get_Var (Ainfo.T.Array_1bound), + Ainfo.T.Bounds_Ptr_Type)); + return New_Address (New_Obj (Res), Ainfo.Ortho_Ptr_Type (Mode_Value)); + end Translate_Element_To_Array; + + function Translate_Concat_Operator + (Left_Tree, Right_Tree : O_Enode; + Imp : Iir_Implicit_Function_Declaration; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Ret_Type : constant Iir := Get_Return_Type (Imp); + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + Arr_El1 : O_Enode; + Arr_El2 : O_Enode; + Res : O_Enode; + begin + case Kind is + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + Arr_El1 := Translate_Element_To_Array (Left_Tree, Ret_Type); + when others => + Arr_El1 := Left_Tree; + end case; + case Kind is + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Arr_El2 := Translate_Element_To_Array (Right_Tree, Ret_Type); + when others => + Arr_El2 := Right_Tree; + end case; + Res := Translate_Predefined_Array_Operator (Arr_El1, Arr_El2, Imp); + return Translate_Implicit_Conv + (Res, Ret_Type, Res_Type, Mode_Value, Loc); + end Translate_Concat_Operator; + + function Translate_Scalar_Min_Max + (Op : ON_Op_Kind; + Left, Right : Iir; + Res_Type : Iir) + return O_Enode + is + Res_Otype : constant O_Tnode := + Get_Ortho_Type (Res_Type, Mode_Value); + Res, L, R : O_Dnode; + If_Blk : O_If_Block; + begin + -- Create a variable for the result. + Res := Create_Temp (Res_Otype); + + Open_Temp; + L := Create_Temp_Init + (Res_Otype, Translate_Expression (Left, Res_Type)); + R := Create_Temp_Init + (Res_Otype, Translate_Expression (Right, Res_Type)); + + Start_If_Stmt (If_Blk, New_Compare_Op (Op, + New_Obj_Value (L), + New_Obj_Value (R), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Res), New_Obj_Value (L)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Res), New_Obj_Value (R)); + Finish_If_Stmt (If_Blk); + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Scalar_Min_Max; + + function Translate_Predefined_Vector_Min_Max (Is_Min : Boolean; + Left : Iir; + Res_Type : Iir) + return O_Enode + is + Res_Otype : constant O_Tnode := + Get_Ortho_Type (Res_Type, Mode_Value); + Left_Type : constant Iir := Get_Type (Left); + Res, El, Len : O_Dnode; + Arr : Mnode; + If_Blk : O_If_Block; + Label : O_Snode; + Op : ON_Op_Kind; + begin + -- Create a variable for the result. + Res := Create_Temp (Res_Otype); + + Open_Temp; + if Is_Min then + Op := ON_Lt; + else + Op := ON_Gt; + end if; + New_Assign_Stmt + (New_Obj (Res), + Chap14.Translate_High_Low_Type_Attribute (Res_Type, Is_Min)); + + El := Create_Temp (Res_Otype); + Arr := Stabilize (E2M (Translate_Expression (Left), + Get_Info (Left_Type), Mode_Value)); + Len := Create_Temp_Init + (Ghdl_Index_Type, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Left_Type, 1)))); + + -- Create: + -- loop + -- exit when LEN = 0; + -- LEN := LEN - 1; + -- if ARR[LEN] </> RES then + -- RES := ARR[LEN]; + -- end if; + -- end loop; + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Dec_Var (Len); + New_Assign_Stmt + (New_Obj (El), + M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), + Left_Type, New_Obj_Value (Len)))); + Start_If_Stmt (If_Blk, New_Compare_Op (Op, + New_Obj_Value (El), + New_Obj_Value (Res), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Res), New_Obj_Value (El)); + Finish_If_Stmt (If_Blk); + Finish_Loop_Stmt (Label); + + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Predefined_Vector_Min_Max; + + function Translate_Std_Ulogic_Match (Func : O_Dnode; + L, R : O_Enode; + Res_Type : O_Tnode) + return O_Enode + is + Constr : O_Assoc_List; + begin + Start_Association (Constr, Func); + New_Association (Constr, New_Convert_Ov (L, Ghdl_I32_Type)); + New_Association (Constr, New_Convert_Ov (R, Ghdl_I32_Type)); + return New_Convert_Ov (New_Function_Call (Constr), Res_Type); + end Translate_Std_Ulogic_Match; + + function Translate_To_String (Subprg : O_Dnode; + Res_Type : Iir; + Loc : Iir; + Val : O_Enode; + Arg2 : O_Enode := O_Enode_Null; + Arg3 : O_Enode := O_Enode_Null) + return O_Enode + is + Val_Type : constant Iir := Get_Base_Type (Res_Type); + Res : O_Dnode; + Assoc : O_Assoc_List; + begin + Res := Create_Temp (Std_String_Node); + Create_Temp_Stack2_Mark; + Start_Association (Assoc, Subprg); + New_Association (Assoc, + New_Address (New_Obj (Res), Std_String_Ptr_Node)); + New_Association (Assoc, Val); + if Arg2 /= O_Enode_Null then + New_Association (Assoc, Arg2); + if Arg3 /= O_Enode_Null then + New_Association (Assoc, Arg3); + end if; + end if; + New_Procedure_Call (Assoc); + return M2E (Translate_Implicit_Array_Conversion + (Dv2M (Res, Get_Info (Val_Type), Mode_Value), + Val_Type, Res_Type, Loc)); + end Translate_To_String; + + function Translate_Bv_To_String (Subprg : O_Dnode; + Val : O_Enode; + Val_Type : Iir; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Arr : Mnode; + begin + Arr := Stabilize (E2M (Val, Get_Info (Val_Type), Mode_Value)); + return Translate_To_String + (Subprg, Res_Type, Loc, + M2E (Chap3.Get_Array_Base (Arr)), + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Val_Type, 1)))); + end Translate_Bv_To_String; + + subtype Predefined_Boolean_Logical is Iir_Predefined_Functions range + Iir_Predefined_Boolean_And .. Iir_Predefined_Boolean_Xnor; + + function Translate_Predefined_Logical + (Op : Predefined_Boolean_Logical; Left, Right : O_Enode) + return O_Enode is + begin + case Op is + when Iir_Predefined_Boolean_And => + return New_Dyadic_Op (ON_And, Left, Right); + when Iir_Predefined_Boolean_Or => + return New_Dyadic_Op (ON_Or, Left, Right); + when Iir_Predefined_Boolean_Nand => + return New_Monadic_Op + (ON_Not, New_Dyadic_Op (ON_And, Left, Right)); + when Iir_Predefined_Boolean_Nor => + return New_Monadic_Op + (ON_Not, New_Dyadic_Op (ON_Or, Left, Right)); + when Iir_Predefined_Boolean_Xor => + return New_Dyadic_Op (ON_Xor, Left, Right); + when Iir_Predefined_Boolean_Xnor => + return New_Monadic_Op + (ON_Not, New_Dyadic_Op (ON_Xor, Left, Right)); + end case; + end Translate_Predefined_Logical; + + function Translate_Predefined_TF_Array_Element + (Op : Predefined_Boolean_Logical; + Left, Right : Iir; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Arr_Type : constant Iir := Get_Type (Left); + Res_Btype : constant Iir := Get_Base_Type (Res_Type); + Res_Info : constant Type_Info_Acc := Get_Info (Res_Btype); + Base_Ptr_Type : constant O_Tnode := + Res_Info.T.Base_Ptr_Type (Mode_Value); + Arr : Mnode; + El : O_Dnode; + Base : O_Dnode; + Len : O_Dnode; + Label : O_Snode; + Res : Mnode; + begin + -- Translate the array. + Arr := Stabilize (E2M (Translate_Expression (Left), + Get_Info (Arr_Type), Mode_Value)); + + -- Extract its length. + Len := Create_Temp_Init + (Ghdl_Index_Type, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Arr_Type, 1)))); + + -- Allocate the result array. + Base := Create_Temp_Init + (Base_Ptr_Type, + Gen_Alloc (Alloc_Stack, New_Obj_Value (Len), Base_Ptr_Type)); + + Open_Temp; + -- Translate the element. + El := Create_Temp_Init (Get_Ortho_Type (Get_Type (Right), Mode_Value), + Translate_Expression (Right)); + -- Create: + -- loop + -- exit when LEN = 0; + -- LEN := LEN - 1; + -- BASE[LEN] := EL op ARR[LEN]; + -- end loop; + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Dec_Var (Len); + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Base), + New_Obj_Value (Len)), + Translate_Predefined_Logical + (Op, + New_Obj_Value (El), + M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), + Arr_Type, New_Obj_Value (Len))))); + Finish_Loop_Stmt (Label); + Close_Temp; + + Res := Create_Temp (Res_Info, Mode_Value); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (Res)), + New_Obj_Value (Base)); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (Arr))); + + return Translate_Implicit_Conv (M2E (Res), Res_Btype, Res_Type, + Mode_Value, Loc); + end Translate_Predefined_TF_Array_Element; + + function Translate_Predefined_TF_Reduction + (Op : ON_Op_Kind; Operand : Iir; Res_Type : Iir) + return O_Enode + is + Arr_Type : constant Iir := Get_Type (Operand); + Enums : constant Iir_List := + Get_Enumeration_Literal_List (Get_Base_Type (Res_Type)); + Init_Enum : Iir; + + Res : O_Dnode; + Arr_Expr : O_Enode; + Arr : Mnode; + Len : O_Dnode; + Label : O_Snode; + begin + if Op = ON_And then + Init_Enum := Get_Nth_Element (Enums, 1); + else + Init_Enum := Get_Nth_Element (Enums, 0); + end if; + + Res := Create_Temp_Init (Get_Ortho_Type (Res_Type, Mode_Value), + New_Lit (Get_Ortho_Expr (Init_Enum))); + + Open_Temp; + -- Translate the array. Note that Translate_Expression may create + -- the info for the array type, so be sure to call it before calling + -- Get_Info. + Arr_Expr := Translate_Expression (Operand); + Arr := Stabilize (E2M (Arr_Expr, Get_Info (Arr_Type), Mode_Value)); + + -- Extract its length. + Len := Create_Temp_Init + (Ghdl_Index_Type, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Arr_Type, 1)))); + + -- Create: + -- loop + -- exit when LEN = 0; + -- LEN := LEN - 1; + -- RES := RES op ARR[LEN]; + -- end loop; + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Dec_Var (Len); + New_Assign_Stmt + (New_Obj (Res), + New_Dyadic_Op + (Op, + New_Obj_Value (Res), + M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), + Arr_Type, New_Obj_Value (Len))))); + Finish_Loop_Stmt (Label); + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Predefined_TF_Reduction; + + function Translate_Predefined_Array_Min_Max + (Is_Min : Boolean; + Left, Right : O_Enode; + Left_Type, Right_Type : Iir; + Res_Type : Iir; + Imp : Iir; + Loc : Iir) + return O_Enode + is + Arr_Type : constant Iir := Get_Base_Type (Left_Type); + Arr_Info : constant Type_Info_Acc := Get_Info (Arr_Type); + L, R : Mnode; + If_Blk : O_If_Block; + Res : Mnode; + begin + Res := Create_Temp (Arr_Info, Mode_Value); + L := Stabilize (E2M (Left, Get_Info (Left_Type), Mode_Value)); + R := Stabilize (E2M (Right, Get_Info (Right_Type), Mode_Value)); + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator (M2E (L), M2E (R), Imp), + New_Lit (Ghdl_Compare_Lt), + Std_Boolean_Type_Node)); + if Is_Min then + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (L, Left_Type, Arr_Type, Loc)); + else + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (R, Right_Type, Arr_Type, Loc)); + end if; + New_Else_Stmt (If_Blk); + if Is_Min then + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (R, Right_Type, Arr_Type, Loc)); + else + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (L, Left_Type, Arr_Type, Loc)); + end if; + Finish_If_Stmt (If_Blk); + + return M2E (Translate_Implicit_Array_Conversion + (Res, Arr_Type, Res_Type, Loc)); + end Translate_Predefined_Array_Min_Max; + + function Translate_Predefined_TF_Edge + (Is_Rising : Boolean; Left : Iir) + return O_Enode + is + Enums : constant Iir_List := + Get_Enumeration_Literal_List (Get_Base_Type (Get_Type (Left))); + Name : Mnode; + begin + Name := Stabilize (Chap6.Translate_Name (Left), True); + return New_Dyadic_Op + (ON_And, + New_Value (Chap14.Get_Signal_Field + (Name, Ghdl_Signal_Event_Field)), + New_Compare_Op + (ON_Eq, + New_Value (New_Access_Element (M2E (Name))), + New_Lit (Get_Ortho_Expr + (Get_Nth_Element (Enums, Boolean'Pos (Is_Rising)))), + Std_Boolean_Type_Node)); + end Translate_Predefined_TF_Edge; + + function Translate_Predefined_Std_Ulogic_Array_Match + (Subprg : O_Dnode; Left, Right : Iir; Res_Type : Iir) + return O_Enode + is + Res_Otype : constant O_Tnode := + Get_Ortho_Type (Res_Type, Mode_Value); + L_Type : constant Iir := Get_Type (Left); + R_Type : constant Iir := Get_Type (Right); + L_Expr, R_Expr : O_Enode; + L, R : Mnode; + Assoc : O_Assoc_List; + + Res : O_Dnode; + begin + Res := Create_Temp (Ghdl_I32_Type); + + Open_Temp; + -- Translate the arrays. Note that Translate_Expression may create + -- the info for the array type, so be sure to call it before calling + -- Get_Info. + L_Expr := Translate_Expression (Left); + L := Stabilize (E2M (L_Expr, Get_Info (L_Type), Mode_Value)); + + R_Expr := Translate_Expression (Right); + R := Stabilize (E2M (R_Expr, Get_Info (R_Type), Mode_Value)); + + Start_Association (Assoc, Subprg); + New_Association + (Assoc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (L)), Ghdl_Ptr_Type)); + New_Association + (Assoc, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (L, L_Type, 1)))); + + New_Association + (Assoc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (R)), Ghdl_Ptr_Type)); + New_Association + (Assoc, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (R, R_Type, 1)))); + + New_Assign_Stmt (New_Obj (Res), New_Function_Call (Assoc)); + + Close_Temp; + + return New_Convert_Ov (New_Obj_Value (Res), Res_Otype); + end Translate_Predefined_Std_Ulogic_Array_Match; + + function Translate_Predefined_Operator + (Imp : Iir_Implicit_Function_Declaration; + Left, Right : Iir; + Res_Type : Iir; + Loc : Iir) + return O_Enode + is + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + Left_Tree : O_Enode; + Right_Tree : O_Enode; + Left_Type : Iir; + Right_Type : Iir; + Res_Otype : O_Tnode; + Op : ON_Op_Kind; + Inter : Iir; + Res : O_Enode; + begin + case Kind is + when Iir_Predefined_Bit_And + | Iir_Predefined_Bit_Or + | Iir_Predefined_Bit_Nand + | Iir_Predefined_Bit_Nor + | Iir_Predefined_Boolean_And + | Iir_Predefined_Boolean_Or + | Iir_Predefined_Boolean_Nand + | Iir_Predefined_Boolean_Nor => + -- Right operand of shortcur operators may not be evaluated. + return Translate_Shortcut_Operator (Imp, Left, Right); + + -- Operands of min/max are evaluated in a declare block. + when Iir_Predefined_Enum_Minimum + | Iir_Predefined_Integer_Minimum + | Iir_Predefined_Floating_Minimum + | Iir_Predefined_Physical_Minimum => + return Translate_Scalar_Min_Max (ON_Le, Left, Right, Res_Type); + when Iir_Predefined_Enum_Maximum + | Iir_Predefined_Integer_Maximum + | Iir_Predefined_Floating_Maximum + | Iir_Predefined_Physical_Maximum => + return Translate_Scalar_Min_Max (ON_Ge, Left, Right, Res_Type); + + -- Avoid implicit conversion of the array parameters to the + -- unbounded type for optimizing purpose. FIXME: should do the + -- same for the result. + when Iir_Predefined_TF_Array_Element_And => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_And, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_And => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_And, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Or => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Or, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Or => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Or, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Nand => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nand, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Nand => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nand, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Nor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nor, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Nor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Nor, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Xor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xor, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Xor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xor, Right, Left, Res_Type, Loc); + when Iir_Predefined_TF_Array_Element_Xnor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xnor, Left, Right, Res_Type, Loc); + when Iir_Predefined_TF_Element_Array_Xnor => + return Translate_Predefined_TF_Array_Element + (Iir_Predefined_Boolean_Xnor, Right, Left, Res_Type, Loc); + + -- Avoid implicit conversion of the array parameters to the + -- unbounded type for optimizing purpose. + when Iir_Predefined_TF_Reduction_And => + return Translate_Predefined_TF_Reduction + (ON_And, Left, Res_Type); + when Iir_Predefined_TF_Reduction_Or => + return Translate_Predefined_TF_Reduction + (ON_Or, Left, Res_Type); + when Iir_Predefined_TF_Reduction_Nand => + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_And, Left, Res_Type)); + when Iir_Predefined_TF_Reduction_Nor => + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_Or, Left, Res_Type)); + when Iir_Predefined_TF_Reduction_Xor => + return Translate_Predefined_TF_Reduction + (ON_Xor, Left, Res_Type); + when Iir_Predefined_TF_Reduction_Xnor => + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_Xor, Left, Res_Type)); + + when Iir_Predefined_Vector_Minimum => + return Translate_Predefined_Vector_Min_Max + (True, Left, Res_Type); + when Iir_Predefined_Vector_Maximum => + return Translate_Predefined_Vector_Min_Max + (False, Left, Res_Type); + + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge => + return Translate_Predefined_TF_Edge (True, Left); + when Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge => + return Translate_Predefined_TF_Edge (False, Left); + + when Iir_Predefined_Std_Ulogic_Array_Match_Equality => + return Translate_Predefined_Std_Ulogic_Array_Match + (Ghdl_Std_Ulogic_Array_Match_Eq, Left, Right, Res_Type); + when Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + return Translate_Predefined_Std_Ulogic_Array_Match + (Ghdl_Std_Ulogic_Array_Match_Ne, Left, Right, Res_Type); + + when others => + null; + end case; + + -- Evaluate parameters. + Res_Otype := Get_Ortho_Type (Res_Type, Mode_Value); + Inter := Get_Interface_Declaration_Chain (Imp); + if Left = Null_Iir then + Left_Tree := O_Enode_Null; + else + Left_Type := Get_Type (Inter); + Left_Tree := Translate_Expression (Left, Left_Type); + end if; + + if Right = Null_Iir then + Right_Tree := O_Enode_Null; + else + Right_Type := Get_Type (Get_Chain (Inter)); + Right_Tree := Translate_Expression (Right, Right_Type); + end if; + + Op := Predefined_To_Onop (Kind); + if Op /= ON_Nil then + case Op is + when ON_Eq + | ON_Neq + | ON_Ge + | ON_Gt + | ON_Le + | ON_Lt => + Res := New_Compare_Op (Op, Left_Tree, Right_Tree, + Std_Boolean_Type_Node); + when ON_Add_Ov + | ON_Sub_Ov + | ON_Mul_Ov + | ON_Div_Ov + | ON_Rem_Ov + | ON_Mod_Ov + | ON_Xor => + Res := New_Dyadic_Op (Op, Left_Tree, Right_Tree); + when ON_Abs_Ov + | ON_Neg_Ov + | ON_Not => + Res := New_Monadic_Op (Op, Left_Tree); + when others => + Ada.Text_IO.Put_Line + ("translate_predefined_operator: cannot handle " + & ON_Op_Kind'Image (Op)); + raise Internal_Error; + end case; + Res := Translate_Implicit_Conv + (Res, Get_Return_Type (Imp), Res_Type, Mode_Value, Loc); + return Res; + end if; + + case Kind is + when Iir_Predefined_Bit_Xnor + | Iir_Predefined_Boolean_Xnor => + return Translate_Predefined_Logical + (Iir_Predefined_Boolean_Xnor, Left_Tree, Right_Tree); + when Iir_Predefined_Bit_Match_Equality => + return New_Compare_Op (ON_Eq, Left_Tree, Right_Tree, + Get_Ortho_Type (Res_Type, Mode_Value)); + when Iir_Predefined_Bit_Match_Inequality => + return New_Compare_Op (ON_Neq, Left_Tree, Right_Tree, + Get_Ortho_Type (Res_Type, Mode_Value)); + + when Iir_Predefined_Bit_Condition => + return New_Compare_Op + (ON_Eq, Left_Tree, New_Lit (Get_Ortho_Expr (Bit_1)), + Std_Boolean_Type_Node); + + when Iir_Predefined_Integer_Identity + | Iir_Predefined_Floating_Identity + | Iir_Predefined_Physical_Identity => + return Translate_Implicit_Conv + (Left_Tree, Left_Type, Res_Type, Mode_Value, Loc); + + when Iir_Predefined_Access_Equality + | Iir_Predefined_Access_Inequality => + if Is_Composite (Get_Info (Left_Type)) then + -- a fat pointer. + declare + T : Type_Info_Acc; + B : Type_Info_Acc; + L, R : O_Dnode; + V1, V2 : O_Enode; + Op1, Op2 : ON_Op_Kind; + begin + if Kind = Iir_Predefined_Access_Equality then + Op1 := ON_Eq; + Op2 := ON_And; + else + Op1 := ON_Neq; + Op2 := ON_Or; + end if; + T := Get_Info (Left_Type); + B := Get_Info (Get_Designated_Type (Left_Type)); + L := Create_Temp (T.Ortho_Ptr_Type (Mode_Value)); + R := Create_Temp (T.Ortho_Ptr_Type (Mode_Value)); + New_Assign_Stmt (New_Obj (L), Left_Tree); + New_Assign_Stmt (New_Obj (R), Right_Tree); + V1 := New_Compare_Op + (Op1, + New_Value_Selected_Acc_Value + (New_Obj (L), B.T.Base_Field (Mode_Value)), + New_Value_Selected_Acc_Value + (New_Obj (R), B.T.Base_Field (Mode_Value)), + Std_Boolean_Type_Node); + V2 := New_Compare_Op + (Op1, + New_Value_Selected_Acc_Value + (New_Obj (L), B.T.Bounds_Field (Mode_Value)), + New_Value_Selected_Acc_Value + (New_Obj (R), B.T.Bounds_Field (Mode_Value)), + Std_Boolean_Type_Node); + return New_Dyadic_Op (Op2, V1, V2); + end; + else + -- a thin pointer. + if Kind = Iir_Predefined_Access_Equality then + return New_Compare_Op + (ON_Eq, Left_Tree, Right_Tree, Std_Boolean_Type_Node); + else + return New_Compare_Op + (ON_Neq, Left_Tree, Right_Tree, Std_Boolean_Type_Node); + end if; + end if; + + when Iir_Predefined_Physical_Integer_Div => + return New_Dyadic_Op (ON_Div_Ov, Left_Tree, + New_Convert_Ov (Right_Tree, Res_Otype)); + when Iir_Predefined_Physical_Physical_Div => + return New_Convert_Ov + (New_Dyadic_Op (ON_Div_Ov, Left_Tree, Right_Tree), Res_Otype); + + -- LRM 7.2.6 + -- Multiplication of a value P of a physical type Tp by a + -- value I of type INTEGER is equivalent to the following + -- computation: Tp'Val (Tp'Pos (P) * I) + -- FIXME: this is not what is really done... + when Iir_Predefined_Integer_Physical_Mul => + return New_Dyadic_Op (ON_Mul_Ov, + New_Convert_Ov (Left_Tree, Res_Otype), + Right_Tree); + when Iir_Predefined_Physical_Integer_Mul => + return New_Dyadic_Op (ON_Mul_Ov, Left_Tree, + New_Convert_Ov (Right_Tree, Res_Otype)); + + -- LRM 7.2.6 + -- Multiplication of a value P of a physical type Tp by a + -- value F of type REAL is equivalten to the following + -- computation: Tp'Val (INTEGER (REAL (Tp'Pos (P)) * F)) + -- FIXME: we do not restrict with INTEGER. + when Iir_Predefined_Physical_Real_Mul => + declare + Right_Otype : O_Tnode; + begin + Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value); + return New_Convert_Ov + (New_Dyadic_Op (ON_Mul_Ov, + New_Convert_Ov (Left_Tree, Right_Otype), + Right_Tree), + Res_Otype); + end; + when Iir_Predefined_Physical_Real_Div => + declare + Right_Otype : O_Tnode; + begin + Right_Otype := Get_Ortho_Type (Right_Type, Mode_Value); + return New_Convert_Ov + (New_Dyadic_Op (ON_Div_Ov, + New_Convert_Ov (Left_Tree, Right_Otype), + Right_Tree), + Res_Otype); + end; + when Iir_Predefined_Real_Physical_Mul => + declare + Left_Otype : O_Tnode; + begin + Left_Otype := Get_Ortho_Type (Left_Type, Mode_Value); + return New_Convert_Ov + (New_Dyadic_Op (ON_Mul_Ov, + Left_Tree, + New_Convert_Ov (Right_Tree, Left_Otype)), + Res_Otype); + end; + + when Iir_Predefined_Universal_R_I_Mul => + return New_Dyadic_Op (ON_Mul_Ov, + Left_Tree, + New_Convert_Ov (Right_Tree, Res_Otype)); + + when Iir_Predefined_Floating_Exp => + Res := Translate_Lib_Operator + (New_Convert_Ov (Left_Tree, Std_Real_Otype), + Right_Tree, Ghdl_Real_Exp); + return New_Convert_Ov (Res, Res_Otype); + when Iir_Predefined_Integer_Exp => + Res := Translate_Lib_Operator + (New_Convert_Ov (Left_Tree, Std_Integer_Otype), + Right_Tree, + Ghdl_Integer_Exp); + return New_Convert_Ov (Res, Res_Otype); + + when Iir_Predefined_Array_Inequality + | Iir_Predefined_Record_Inequality => + return New_Monadic_Op + (ON_Not, Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp)); + when Iir_Predefined_Array_Equality + | Iir_Predefined_Record_Equality => + return Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp); + + when Iir_Predefined_Array_Greater => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Gt), + Std_Boolean_Type_Node); + when Iir_Predefined_Array_Greater_Equal => + return New_Compare_Op + (ON_Ge, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Eq), + Std_Boolean_Type_Node); + when Iir_Predefined_Array_Less => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Lt), + Std_Boolean_Type_Node); + when Iir_Predefined_Array_Less_Equal => + return New_Compare_Op + (ON_Le, + Translate_Predefined_Lib_Operator (Left_Tree, Right_Tree, + Imp), + New_Lit (Ghdl_Compare_Eq), + Std_Boolean_Type_Node); + + when Iir_Predefined_TF_Array_And + | Iir_Predefined_TF_Array_Or + | Iir_Predefined_TF_Array_Nand + | Iir_Predefined_TF_Array_Nor + | Iir_Predefined_TF_Array_Xor + | Iir_Predefined_TF_Array_Xnor + | Iir_Predefined_TF_Array_Not + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Ror => + return Translate_Predefined_Array_Operator_Convert + (Left_Tree, Right_Tree, Imp, Res_Type); + + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Rol => + Right_Tree := New_Monadic_Op (ON_Neg_Ov, Right_Tree); + return Translate_Predefined_Array_Operator_Convert + (Left_Tree, Right_Tree, Imp, Res_Type); + + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + return Translate_Concat_Operator + (Left_Tree, Right_Tree, Imp, Res_Type, Loc); + + when Iir_Predefined_Endfile => + return Translate_Lib_Operator + (Left_Tree, O_Enode_Null, Ghdl_File_Endfile); + + when Iir_Predefined_Now_Function => + return New_Obj_Value (Ghdl_Now); + + when Iir_Predefined_Std_Ulogic_Match_Equality => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Eq, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Inequality => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Ne, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Less => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Lt, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Less_Equal => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Le, + Left_Tree, Right_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Greater => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Lt, + Right_Tree, Left_Tree, Res_Otype); + when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => + return Translate_Std_Ulogic_Match + (Ghdl_Std_Ulogic_Match_Le, + Right_Tree, Left_Tree, Res_Otype); + + when Iir_Predefined_Bit_Array_Match_Equality => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp), + New_Lit (Std_Boolean_True_Node), + Res_Otype); + when Iir_Predefined_Bit_Array_Match_Inequality => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp), + New_Lit (Std_Boolean_False_Node), + Res_Otype); + + when Iir_Predefined_Array_Minimum => + return Translate_Predefined_Array_Min_Max + (True, Left_Tree, Right_Tree, Left_Type, Right_Type, + Res_Type, Imp, Loc); + when Iir_Predefined_Array_Maximum => + return Translate_Predefined_Array_Min_Max + (False, Left_Tree, Right_Tree, Left_Type, Right_Type, + Res_Type, Imp, Loc); + + when Iir_Predefined_Integer_To_String => + case Get_Info (Left_Type).Type_Mode is + when Type_Mode_I32 => + return Translate_To_String + (Ghdl_To_String_I32, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_I32_Type)); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_To_String => + -- LRM08 5.7 String representations + -- - For a given value of type CHARACTER, [...] + -- + -- So special case for character. + if Get_Base_Type (Left_Type) = Character_Type_Definition then + return Translate_To_String + (Ghdl_To_String_Char, Res_Type, Loc, Left_Tree); + end if; + + -- LRM08 5.7 String representations + -- - For a given value of type other than CHARACTER, [...] + declare + Conv : O_Tnode; + Subprg : O_Dnode; + begin + case Get_Info (Left_Type).Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_To_String_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_To_String_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_To_String_E32; + Conv := Ghdl_I32_Type; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Conv), + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); + end; + when Iir_Predefined_Floating_To_String => + return Translate_To_String + (Ghdl_To_String_F64, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_Real_Type)); + when Iir_Predefined_Real_To_String_Digits => + return Translate_To_String + (Ghdl_To_String_F64_Digits, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_Real_Type), + New_Convert_Ov (Right_Tree, Ghdl_I32_Type)); + when Iir_Predefined_Real_To_String_Format => + return Translate_To_String + (Ghdl_To_String_F64_Format, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_Real_Type), + Right_Tree); + when Iir_Predefined_Physical_To_String => + declare + Conv : O_Tnode; + Subprg : O_Dnode; + begin + case Get_Info (Left_Type).Type_Mode is + when Type_Mode_P32 => + Subprg := Ghdl_To_String_P32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 => + Subprg := Ghdl_To_String_P64; + Conv := Ghdl_I64_Type; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Conv), + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); + end; + when Iir_Predefined_Time_To_String_Unit => + return Translate_To_String + (Ghdl_Time_To_String_Unit, Res_Type, Loc, + Left_Tree, Right_Tree, + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); + when Iir_Predefined_Bit_Vector_To_Ostring => + return Translate_Bv_To_String + (Ghdl_BV_To_Ostring, Left_Tree, Left_Type, Res_Type, Loc); + when Iir_Predefined_Bit_Vector_To_Hstring => + return Translate_Bv_To_String + (Ghdl_BV_To_Hstring, Left_Tree, Left_Type, Res_Type, Loc); + when Iir_Predefined_Array_Char_To_String => + declare + El_Type : constant Iir := Get_Element_Subtype (Left_Type); + Subprg : O_Dnode; + Arg : Mnode; + begin + Arg := Stabilize + (E2M (Left_Tree, Get_Info (Left_Type), Mode_Value)); + case Get_Info (El_Type).Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Array_Char_To_String_B1; + when Type_Mode_E8 => + Subprg := Ghdl_Array_Char_To_String_E8; + when Type_Mode_E32 => + Subprg := Ghdl_Array_Char_To_String_E32; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (Arg)), + Ghdl_Ptr_Type), + Chap3.Get_Array_Length (Arg, Left_Type), + New_Lit (Rtis.New_Rti_Address + (Get_Info (El_Type).Type_Rti))); + end; + + when others => + Ada.Text_IO.Put_Line + ("translate_predefined_operator(2): cannot handle " + & Iir_Predefined_Functions'Image (Kind)); + raise Internal_Error; + return O_Enode_Null; + end case; + end Translate_Predefined_Operator; + + -- Assign EXPR to TARGET. + procedure Translate_Assign + (Target : Mnode; + Val : O_Enode; Expr : Iir; Target_Type : Iir; Loc : Iir) + is + T_Info : constant Type_Info_Acc := Get_Info (Target_Type); + begin + case T_Info.Type_Mode is + when Type_Mode_Scalar => + New_Assign_Stmt + (M2Lv (Target), + Chap3.Maybe_Insert_Scalar_Check (Val, Expr, Target_Type)); + when Type_Mode_Acc + | Type_Mode_File => + New_Assign_Stmt (M2Lv (Target), Val); + when Type_Mode_Fat_Acc => + Chap3.Translate_Object_Copy (Target, Val, Target_Type); + when Type_Mode_Fat_Array => + declare + T : Mnode; + E : O_Dnode; + begin + T := Stabilize (Target); + E := Create_Temp_Init + (T_Info.Ortho_Ptr_Type (Mode_Value), Val); + Chap3.Check_Array_Match + (Target_Type, T, + Get_Type (Expr), Dp2M (E, T_Info, Mode_Value), Loc); + Chap3.Translate_Object_Copy + (T, New_Obj_Value (E), Target_Type); + end; + when Type_Mode_Array => + -- Source is of type TARGET_TYPE, so no length check is + -- necessary. + Chap3.Translate_Object_Copy (Target, Val, Target_Type); + when Type_Mode_Record => + Chap3.Translate_Object_Copy (Target, Val, Target_Type); + when Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Assign; + + procedure Translate_Assign + (Target : Mnode; Expr : Iir; Target_Type : Iir) + is + Val : O_Enode; + begin + if Get_Kind (Expr) = Iir_Kind_Aggregate then + -- FIXME: handle overlap between TARGET and EXPR. + Translate_Aggregate (Target, Target_Type, Expr); + else + Open_Temp; + Val := Chap7.Translate_Expression (Expr, Target_Type); + Translate_Assign (Target, Val, Expr, Target_Type, Expr); + Close_Temp; + end if; + end Translate_Assign; + + -- If AGGR is of the form (others => (others => EXPR)) (where the + -- number of (others => ) sub-aggregate is at least 1, return EXPR + -- otherwise return NULL_IIR. + function Is_Aggregate_Others (Aggr : Iir_Aggregate) return Iir + is + Chain : Iir; + Aggr1 : Iir; + --Type_Info : Type_Info_Acc; + begin + Aggr1 := Aggr; + -- Do not use translate_aggregate_others for a complex type. + --Type_Info := Get_Info (Get_Type (Aggr)); + --if Type_Info.C /= null and then Type_Info.C.Builder_Need_Func then + -- return Null_Iir; + --end if; + loop + Chain := Get_Association_Choices_Chain (Aggr1); + if not Is_Chain_Length_One (Chain) then + return Null_Iir; + end if; + if Get_Kind (Chain) /= Iir_Kind_Choice_By_Others then + return Null_Iir; + end if; + Aggr1 := Get_Associated_Expr (Chain); + case Get_Kind (Aggr1) is + when Iir_Kind_Aggregate => + if Get_Type (Aggr1) /= Null_Iir then + -- Stop when a sub-aggregate is in fact an aggregate. + return Aggr1; + end if; + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + return Null_Iir; + --Error_Kind ("is_aggregate_others", Aggr1); + when others => + return Aggr1; + end case; + end loop; + end Is_Aggregate_Others; + + -- Generate code for (others => EL). + procedure Translate_Aggregate_Others + (Target : Mnode; Target_Type : Iir; El : Iir) + is + Base_Ptr : Mnode; + Info : Type_Info_Acc; + It : O_Dnode; + Len : O_Dnode; + Len_Val : O_Enode; + Label : O_Snode; + Arr_Var : Mnode; + El_Node : Mnode; + begin + Open_Temp; + + Info := Get_Info (Target_Type); + case Info.Type_Mode is + when Type_Mode_Fat_Array => + Arr_Var := Stabilize (Target); + Base_Ptr := Stabilize (Chap3.Get_Array_Base (Arr_Var)); + Len_Val := Chap3.Get_Array_Length (Arr_Var, Target_Type); + when Type_Mode_Array => + Base_Ptr := Stabilize (Chap3.Get_Array_Base (Target)); + Len_Val := Chap3.Get_Array_Type_Length (Target_Type); + when others => + raise Internal_Error; + end case; + -- FIXME: use this (since this use one variable instead of two): + -- I := length; + -- loop + -- exit when I = 0; + -- I := I - 1; + -- A[I] := xxx; + -- end loop; + Len := Create_Temp_Init (Ghdl_Index_Type, Len_Val); + if True then + It := Create_Temp (Ghdl_Index_Type); + else + New_Var_Decl (It, Wki_I, O_Storage_Local, Ghdl_Index_Type); + end if; + Init_Var (It); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, New_Compare_Op (ON_Eq, + New_Obj_Value (It), New_Obj_Value (Len), + Ghdl_Bool_Type)); + El_Node := Chap3.Index_Base (Base_Ptr, Target_Type, + New_Obj_Value (It)); + --New_Assign_Stmt (El_Node, Chap7.Translate_Expression (El)); + Translate_Assign (El_Node, El, Get_Element_Subtype (Target_Type)); + Inc_Var (It); + Finish_Loop_Stmt (Label); + + Close_Temp; + end Translate_Aggregate_Others; + + procedure Translate_Array_Aggregate_Gen + (Base_Ptr : Mnode; + Bounds_Ptr : Mnode; + Aggr : Iir; + Aggr_Type : Iir; + Dim : Natural; + Var_Index : O_Dnode) + is + Index_List : Iir_List; + Expr_Type : Iir; + Final : Boolean; + + procedure Do_Assign (Expr : Iir) + is + begin + if Final then + Translate_Assign (Chap3.Index_Base (Base_Ptr, Aggr_Type, + New_Obj_Value (Var_Index)), + Expr, Expr_Type); + Inc_Var (Var_Index); + else + Translate_Array_Aggregate_Gen + (Base_Ptr, Bounds_Ptr, Expr, Aggr_Type, Dim + 1, Var_Index); + end if; + end Do_Assign; + + P : Natural; + El : Iir; + begin + case Get_Kind (Aggr) is + when Iir_Kind_Aggregate => + -- Continue below. + null; + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal => + declare + Len : constant Nat32 := Get_String_Length (Aggr); + + -- Type of the unconstrained array type. + Arr_Type : O_Tnode; + + -- Type of the constrained array type. + Str_Type : O_Tnode; + + Cst : Var_Type; + Var_I : O_Dnode; + Label : O_Snode; + begin + Expr_Type := Get_Element_Subtype (Aggr_Type); + + -- Create a constant for the string. + -- First, create its type, because the literal has no + -- type (subaggregate). + Arr_Type := New_Array_Type + (Get_Ortho_Type (Expr_Type, Mode_Value), + Ghdl_Index_Type); + New_Type_Decl (Create_Uniq_Identifier, Arr_Type); + Str_Type := New_Constrained_Array_Type + (Arr_Type, New_Index_Lit (Unsigned_64 (Len))); + Cst := Create_String_Literal_Var_Inner + (Aggr, Expr_Type, Str_Type); + + -- Copy it. + Open_Temp; + Var_I := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Lit (New_Index_Lit (Nat32'Pos (Len))), + Ghdl_Bool_Type)); + New_Assign_Stmt + (M2Lv (Chap3.Index_Base (Base_Ptr, Aggr_Type, + New_Obj_Value (Var_Index))), + New_Value (New_Indexed_Element (Get_Var (Cst), + New_Obj_Value (Var_I)))); + Inc_Var (Var_I); + Inc_Var (Var_Index); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + return; + when others => + raise Internal_Error; + end case; + + Index_List := Get_Index_Subtype_List (Aggr_Type); + + -- FINAL is true if the elements of the aggregate are elements of + -- the array. + if Get_Nbr_Elements (Index_List) = Dim then + Expr_Type := Get_Element_Subtype (Aggr_Type); + Final:= True; + else + Final := False; + end if; + + El := Get_Association_Choices_Chain (Aggr); + + -- First, assign positionnal association. + -- FIXME: count the number of positionnal association and generate + -- an error if there is more positionnal association than elements + -- in the array. + P := 0; + loop + if El = Null_Iir then + -- There is only positionnal associations. + return; + end if; + exit when Get_Kind (El) /= Iir_Kind_Choice_By_None; + Do_Assign (Get_Associated_Expr (El)); + P := P + 1; + El := Get_Chain (El); + end loop; + + -- Then, assign named or others association. + if Get_Chain (El) = Null_Iir then + -- There is only one choice + case Get_Kind (El) is + when Iir_Kind_Choice_By_Others => + -- falltrough... + null; + when Iir_Kind_Choice_By_Expression => + Do_Assign (Get_Associated_Expr (El)); + return; + when Iir_Kind_Choice_By_Range => + declare + Var_Length : O_Dnode; + Var_I : O_Dnode; + Label : O_Snode; + begin + Open_Temp; + Var_Length := Create_Temp_Init + (Ghdl_Index_Type, + Chap7.Translate_Range_Length (Get_Choice_Range (El))); + Var_I := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + Do_Assign (Get_Associated_Expr (El)); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + return; + when others => + Error_Kind ("translate_array_aggregate_gen", El); + end case; + end if; + + -- Several choices.. + declare + Range_Type : Iir; + Var_Pos : O_Dnode; + Var_Len : O_Dnode; + Range_Ptr : Mnode; + Rtinfo : Type_Info_Acc; + If_Blk : O_If_Block; + Case_Blk : O_Case_Block; + Label : O_Snode; + El_Assoc : Iir; + Len_Tmp : O_Enode; + begin + Open_Temp; + -- Create a loop from left +- number of positionnals associations + -- to/downto right. + Range_Type := + Get_Base_Type (Get_Nth_Element (Index_List, Dim - 1)); + Rtinfo := Get_Info (Range_Type); + Var_Pos := Create_Temp (Rtinfo.Ortho_Type (Mode_Value)); + Range_Ptr := Stabilize + (Chap3.Bounds_To_Range (Bounds_Ptr, Aggr_Type, Dim)); + New_Assign_Stmt (New_Obj (Var_Pos), + M2E (Chap3.Range_To_Left (Range_Ptr))); + Var_Len := Create_Temp (Ghdl_Index_Type); + if P /= 0 then + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Range_Ptr)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_To, Unsigned_64 (P), + Range_Type); + New_Else_Stmt (If_Blk); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_Downto, Unsigned_64 (P), + Range_Type); + Finish_If_Stmt (If_Blk); + end if; + + Len_Tmp := M2E (Chap3.Range_To_Length (Range_Ptr)); + if P /= 0 then + Len_Tmp := New_Dyadic_Op + (ON_Sub_Ov, + Len_Tmp, + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (P)))); + end if; + New_Assign_Stmt (New_Obj (Var_Len), Len_Tmp); + + -- Start loop. + Start_Loop_Stmt (Label); + -- Check if end of loop. + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + + -- convert aggr into a case statement. + Start_Case_Stmt (Case_Blk, New_Obj_Value (Var_Pos)); + El_Assoc := Null_Iir; + while El /= Null_Iir loop + Start_Choice (Case_Blk); + Chap8.Translate_Case_Choice (El, Range_Type, Case_Blk); + if Get_Associated_Expr (El) /= Null_Iir then + El_Assoc := Get_Associated_Expr (El); + end if; + Finish_Choice (Case_Blk); + Do_Assign (El_Assoc); + P := P + 1; + El := Get_Chain (El); + end loop; + Finish_Case_Stmt (Case_Blk); + -- Update var_pos + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Range_Ptr)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_To, Unsigned_64 (1), + Range_Type); + New_Else_Stmt (If_Blk); + Chap8.Gen_Update_Iterator (Var_Pos, Iir_Downto, Unsigned_64 (1), + Range_Type); + Finish_If_Stmt (If_Blk); + New_Assign_Stmt + (New_Obj (Var_Len), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Len), + New_Lit (Ghdl_Index_1))); + Finish_Loop_Stmt (Label); + Close_Temp; + end; + end Translate_Array_Aggregate_Gen; + + procedure Translate_Record_Aggregate (Target : Mnode; Aggr : Iir) + is + Targ : Mnode; + Aggr_Type : constant Iir := Get_Type (Aggr); + Aggr_Base_Type : constant Iir_Record_Type_Definition := + Get_Base_Type (Aggr_Type); + El_List : constant Iir_List := + Get_Elements_Declaration_List (Aggr_Base_Type); + El_Index : Natural; + Nbr_El : constant Natural := Get_Nbr_Elements (El_List); + + -- Record which elements of the record have been set. The 'others' + -- clause applies to all elements not already set. + type Bool_Array_Type is array (0 .. Nbr_El - 1) of Boolean; + pragma Pack (Bool_Array_Type); + Set_Array : Bool_Array_Type := (others => False); + + -- The expression associated. + El_Expr : Iir; + + -- Set an elements. + procedure Set_El (El : Iir_Element_Declaration) is + begin + Translate_Assign (Chap6.Translate_Selected_Element (Targ, El), + El_Expr, Get_Type (El)); + Set_Array (Natural (Get_Element_Position (El))) := True; + end Set_El; + + Assoc : Iir; + N_El_Expr : Iir; + begin + Open_Temp; + Targ := Stabilize (Target); + El_Index := 0; + Assoc := Get_Association_Choices_Chain (Aggr); + while Assoc /= Null_Iir loop + N_El_Expr := Get_Associated_Expr (Assoc); + if N_El_Expr /= Null_Iir then + El_Expr := N_El_Expr; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + Set_El (Get_Nth_Element (El_List, El_Index)); + El_Index := El_Index + 1; + when Iir_Kind_Choice_By_Name => + Set_El (Get_Choice_Name (Assoc)); + El_Index := Natural'Last; + when Iir_Kind_Choice_By_Others => + for J in Set_Array'Range loop + if not Set_Array (J) then + Set_El (Get_Nth_Element (El_List, J)); + end if; + end loop; + when others => + Error_Kind ("translate_record_aggregate", Assoc); + end case; + Assoc := Get_Chain (Assoc); + end loop; + Close_Temp; + end Translate_Record_Aggregate; + + procedure Translate_Array_Aggregate + (Target : Mnode; Target_Type : Iir; Aggr : Iir) + is + Aggr_Type : constant Iir := Get_Type (Aggr); + Index_List : constant Iir_List := Get_Index_Subtype_List (Aggr_Type); + Targ_Index_List : constant Iir_List := + Get_Index_Subtype_List (Target_Type); + + Aggr_Info : Iir_Aggregate_Info; + Base : Mnode; + Bounds : Mnode; + Var_Index : O_Dnode; + Targ : Mnode; + + Rinfo : Type_Info_Acc; + Bt : Iir; + + -- Generate code for: (LVAL lop RNG.left) or (RVAL rop RNG.right) + function Check_Value (Lval : Iir; + Lop : ON_Op_Kind; + Rval : Iir; + Rop : ON_Op_Kind; + Rng : Mnode) + return O_Enode + is + L, R : O_Enode; + begin + L := New_Compare_Op + (Lop, + New_Lit (Translate_Static_Expression (Lval, Bt)), + M2E (Chap3.Range_To_Left (Rng)), + Ghdl_Bool_Type); + R := New_Compare_Op + (Rop, + New_Lit (Translate_Static_Expression (Rval, Bt)), + M2E (Chap3.Range_To_Right (Rng)), + Ghdl_Bool_Type); + return New_Dyadic_Op (ON_Or, L, R); + end Check_Value; + + Range_Ptr : Mnode; + Subtarg_Type : Iir; + Subaggr_Type : Iir; + L, H : Iir; + Min : Iir_Int32; + Has_Others : Boolean; + + Var_Err : O_Dnode; + E : O_Enode; + If_Blk : O_If_Block; + Op : ON_Op_Kind; + begin + Open_Temp; + Targ := Stabilize (Target); + Base := Stabilize (Chap3.Get_Array_Base (Targ)); + Bounds := Stabilize (Chap3.Get_Array_Bounds (Targ)); + Aggr_Info := Get_Aggregate_Info (Aggr); + + -- Check type + for I in Natural loop + Subaggr_Type := Get_Index_Type (Index_List, I); + exit when Subaggr_Type = Null_Iir; + Subtarg_Type := Get_Index_Type (Targ_Index_List, I); + + Bt := Get_Base_Type (Subaggr_Type); + Rinfo := Get_Info (Bt); + + if Get_Aggr_Dynamic_Flag (Aggr_Info) then + -- Dynamic range, must evaluate it. + Open_Temp; + declare + A_Range : O_Dnode; + Rng_Ptr : O_Dnode; + begin + -- Evaluate the range. + Chap3.Translate_Anonymous_Type_Definition + (Subaggr_Type, True); + + A_Range := Create_Temp (Rinfo.T.Range_Type); + Rng_Ptr := Create_Temp_Ptr + (Rinfo.T.Range_Ptr_Type, New_Obj (A_Range)); + Chap7.Translate_Range_Ptr + (Rng_Ptr, + Get_Range_Constraint (Subaggr_Type), + Subaggr_Type); + + -- Check range length VS target length. + Chap6.Check_Bound_Error + (New_Compare_Op + (ON_Neq, + M2E (Chap3.Range_To_Length + (Dv2M (A_Range, + Rinfo, + Mode_Value, + Rinfo.T.Range_Type, + Rinfo.T.Range_Ptr_Type))), + M2E (Chap3.Range_To_Length + (Chap3.Bounds_To_Range + (Bounds, Target_Type, I + 1))), + Ghdl_Bool_Type), + Aggr, I); + end; + Close_Temp; + elsif Get_Type_Staticness (Subaggr_Type) /= Locally + or else Subaggr_Type /= Subtarg_Type + then + -- Note: if the aggregate has no others, then the bounds + -- must be the same, otherwise, aggregate bounds must be + -- inside type bounds. + Has_Others := Get_Aggr_Others_Flag (Aggr_Info); + Min := Get_Aggr_Min_Length (Aggr_Info); + L := Get_Aggr_Low_Limit (Aggr_Info); + + if Min > 0 or L /= Null_Iir then + Open_Temp; + + -- Pointer to the range. + Range_Ptr := Stabilize + (Chap3.Bounds_To_Range (Bounds, Target_Type, I + 1)); + Var_Err := Create_Temp (Ghdl_Bool_Type); + H := Get_Aggr_High_Limit (Aggr_Info); + + if L /= Null_Iir then + -- Check the index range of the aggregrate is equal + -- (or within in presence of 'others') the index range + -- of the target. + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Range_Ptr)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + if Has_Others then + E := Check_Value (L, ON_Lt, H, ON_Gt, Range_Ptr); + else + E := Check_Value (L, ON_Neq, H, ON_Neq, Range_Ptr); + end if; + New_Assign_Stmt (New_Obj (Var_Err), E); + New_Else_Stmt (If_Blk); + if Has_Others then + E := Check_Value (H, ON_Gt, L, ON_Lt, Range_Ptr); + else + E := Check_Value (H, ON_Neq, L, ON_Neq, Range_Ptr); + end if; + New_Assign_Stmt (New_Obj (Var_Err), E); + Finish_If_Stmt (If_Blk); + -- If L and H are greather than the minimum length, + -- then there is no need to check with min. + if Iir_Int32 (Eval_Pos (H) - Eval_Pos (L) + 1) >= Min then + Min := 0; + end if; + end if; + + if Min > 0 then + -- Check the number of elements is equal (or less in + -- presence of 'others') than the length of the index + -- range of the target. + if Has_Others then + Op := ON_Lt; + else + Op := ON_Neq; + end if; + E := New_Compare_Op + (Op, + M2E (Chap3.Range_To_Length (Range_Ptr)), + New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Min))), + Ghdl_Bool_Type); + if L /= Null_Iir then + E := New_Dyadic_Op (ON_Or, E, New_Obj_Value (Var_Err)); + end if; + New_Assign_Stmt (New_Obj (Var_Err), E); + end if; + Chap6.Check_Bound_Error (New_Obj_Value (Var_Err), Aggr, I); + Close_Temp; + end if; + end if; + + -- Next dimension. + Aggr_Info := Get_Sub_Aggregate_Info (Aggr_Info); + end loop; + + Var_Index := Create_Temp_Init + (Ghdl_Index_Type, New_Lit (Ghdl_Index_0)); + Translate_Array_Aggregate_Gen + (Base, Bounds, Aggr, Aggr_Type, 1, Var_Index); + Close_Temp; + + -- FIXME: creating aggregate subtype is expensive and rarely used. + -- (one of the current use - only ? - is check_array_match). + Chap3.Translate_Anonymous_Type_Definition (Aggr_Type, False); + end Translate_Array_Aggregate; + + procedure Translate_Aggregate + (Target : Mnode; Target_Type : Iir; Aggr : Iir) + is + Aggr_Type : constant Iir := Get_Type (Aggr); + El : Iir; + begin + case Get_Kind (Aggr_Type) is + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition => + El := Is_Aggregate_Others (Aggr); + if El /= Null_Iir then + Translate_Aggregate_Others (Target, Target_Type, El); + else + Translate_Array_Aggregate (Target, Target_Type, Aggr); + end if; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Translate_Record_Aggregate (Target, Aggr); + when others => + Error_Kind ("translate_aggregate", Aggr_Type); + end case; + end Translate_Aggregate; + + function Translate_Allocator_By_Expression (Expr : Iir) + return O_Enode + is + Val : O_Enode; + Val_M : Mnode; + A_Type : constant Iir := Get_Type (Expr); + A_Info : constant Type_Info_Acc := Get_Info (A_Type); + D_Type : constant Iir := Get_Designated_Type (A_Type); + D_Info : constant Type_Info_Acc := Get_Info (D_Type); + R : Mnode; + Rtype : O_Tnode; + begin + -- Compute the expression. + Val := Translate_Expression (Get_Expression (Expr), D_Type); + -- Allocate memory for the object. + case A_Info.Type_Mode is + when Type_Mode_Fat_Acc => + R := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), + D_Info, Mode_Value); + Val_M := Stabilize (E2M (Val, D_Info, Mode_Value)); + Chap3.Translate_Object_Allocation + (R, Alloc_Heap, D_Type, + Chap3.Get_Array_Bounds (Val_M)); + Val := M2E (Val_M); + Rtype := A_Info.Ortho_Ptr_Type (Mode_Value); + when Type_Mode_Acc => + R := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), + D_Info, Mode_Value); + Chap3.Translate_Object_Allocation + (R, Alloc_Heap, D_Type, Mnode_Null); + Rtype := A_Info.Ortho_Type (Mode_Value); + when others => + raise Internal_Error; + end case; + Chap3.Translate_Object_Copy (R, Val, D_Type); + return New_Convert_Ov (M2Addr (R), Rtype); + end Translate_Allocator_By_Expression; + + function Translate_Allocator_By_Subtype (Expr : Iir) + return O_Enode + is + P_Type : constant Iir := Get_Type (Expr); + P_Info : constant Type_Info_Acc := Get_Info (P_Type); + D_Type : constant Iir := Get_Designated_Type (P_Type); + D_Info : constant Type_Info_Acc := Get_Info (D_Type); + Sub_Type : Iir; + Bounds : Mnode; + Res : Mnode; + Rtype : O_Tnode; + begin + case P_Info.Type_Mode is + when Type_Mode_Fat_Acc => + Res := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), + D_Info, Mode_Value); + -- FIXME: should allocate bounds, and directly set bounds + -- from the range. + Sub_Type := Get_Subtype_Indication (Expr); + Sub_Type := Get_Type_Of_Subtype_Indication (Sub_Type); + Chap3.Create_Array_Subtype (Sub_Type, True); + Bounds := Chap3.Get_Array_Type_Bounds (Sub_Type); + Rtype := P_Info.Ortho_Ptr_Type (Mode_Value); + when Type_Mode_Acc => + Res := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), + D_Info, Mode_Value); + Bounds := Mnode_Null; + Rtype := P_Info.Ortho_Type (Mode_Value); + when others => + raise Internal_Error; + end case; + Chap3.Translate_Object_Allocation (Res, Alloc_Heap, D_Type, Bounds); + Chap4.Init_Object (Res, D_Type); + return New_Convert_Ov (M2Addr (Res), Rtype); + end Translate_Allocator_By_Subtype; + + function Translate_Fat_Array_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode; + + function Translate_Array_Subtype_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode + is + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); + E : Mnode; + begin + E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); + case Res_Info.Type_Mode is + when Type_Mode_Array => + Chap3.Check_Array_Match + (Res_Type, T2M (Res_Type, Mode_Value), + Expr_Type, E, + Loc); + return New_Convert_Ov + (M2Addr (Chap3.Get_Array_Base (E)), + Res_Info.Ortho_Ptr_Type (Mode_Value)); + when Type_Mode_Fat_Array => + declare + Res : Mnode; + begin + Res := Create_Temp (Res_Info); + Copy_Fat_Pointer (Res, E); + Chap3.Check_Array_Match (Res_Type, Res, Expr_Type, E, Loc); + return M2Addr (Res); + end; + when others => + Error_Kind ("translate_array_subtype_conversion", Res_Type); + end case; + end Translate_Array_Subtype_Conversion; + + function Translate_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode + is + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Res : O_Enode; + begin + case Get_Kind (Res_Type) is + when Iir_Kinds_Scalar_Type_Definition => + Res := New_Convert_Ov (Expr, Res_Info.Ortho_Type (Mode_Value)); + if Chap3.Need_Range_Check (Null_Iir, Res_Type) then + Res := Chap3.Insert_Scalar_Check + (Res, Null_Iir, Res_Type, Loc); + end if; + return Res; + when Iir_Kinds_Array_Type_Definition => + if Get_Constraint_State (Res_Type) = Fully_Constrained then + return Translate_Array_Subtype_Conversion + (Expr, Expr_Type, Res_Type, Loc); + else + return Translate_Fat_Array_Type_Conversion + (Expr, Expr_Type, Res_Type, Loc); + end if; + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + return Expr; + when others => + Error_Kind ("translate_type_conversion", Res_Type); + end case; + end Translate_Type_Conversion; + + function Translate_Fat_Array_Type_Conversion + (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return O_Enode + is + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); + Res_Indexes : constant Iir_List := + Get_Index_Subtype_List (Res_Type); + Expr_Indexes : constant Iir_List := + Get_Index_Subtype_List (Expr_Type); + + Res_Base_Type : constant Iir := Get_Base_Type (Res_Type); + Expr_Base_Type : constant Iir := Get_Base_Type (Expr_Type); + Res_Base_Indexes : constant Iir_List := + Get_Index_Subtype_List (Res_Base_Type); + Expr_Base_Indexes : constant Iir_List := + Get_Index_Subtype_List (Expr_Base_Type); + Res : Mnode; + E : Mnode; + Bounds : O_Dnode; + R_El : Iir; + E_El : Iir; + begin + Res := Create_Temp (Res_Info, Mode_Value); + Bounds := Create_Temp (Res_Info.T.Bounds_Type); + E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); + Open_Temp; + -- Set base. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (E)), + Res_Info.T.Base_Ptr_Type (Mode_Value))); + -- Set bounds. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + New_Address (New_Obj (Bounds), Res_Info.T.Bounds_Ptr_Type)); + + -- Convert bounds. + for I in Natural loop + R_El := Get_Index_Type (Res_Indexes, I); + E_El := Get_Index_Type (Expr_Indexes, I); + exit when R_El = Null_Iir; + declare + Rb_Ptr : Mnode; + Eb_Ptr : Mnode; + Ee : O_Enode; + Same_Index_Type : constant Boolean := + (Get_Index_Type (Res_Base_Indexes, I) + = Get_Index_Type (Expr_Base_Indexes, I)); + begin + Open_Temp; + Rb_Ptr := Stabilize + (Chap3.Get_Array_Range (Res, Res_Type, I + 1)); + Eb_Ptr := Stabilize + (Chap3.Get_Array_Range (E, Expr_Type, I + 1)); + -- Convert left and right (unless they have the same type - + -- this is an optimization but also this deals with null + -- array in common cases). + Ee := M2E (Chap3.Range_To_Left (Eb_Ptr)); + if not Same_Index_Type then + Ee := Translate_Type_Conversion (Ee, E_El, R_El, Loc); + end if; + New_Assign_Stmt (M2Lv (Chap3.Range_To_Left (Rb_Ptr)), Ee); + Ee := M2E (Chap3.Range_To_Right (Eb_Ptr)); + if not Same_Index_Type then + Ee := Translate_Type_Conversion (Ee, E_El, R_El, Loc); + end if; + New_Assign_Stmt (M2Lv (Chap3.Range_To_Right (Rb_Ptr)), Ee); + -- Copy Dir and Length. + New_Assign_Stmt (M2Lv (Chap3.Range_To_Dir (Rb_Ptr)), + M2E (Chap3.Range_To_Dir (Eb_Ptr))); + New_Assign_Stmt (M2Lv (Chap3.Range_To_Length (Rb_Ptr)), + M2E (Chap3.Range_To_Length (Eb_Ptr))); + Close_Temp; + end; + end loop; + Close_Temp; + return M2E (Res); + end Translate_Fat_Array_Type_Conversion; + + function Sig2val_Prepare_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Mnode) + return Mnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + if Get_Type_Info (Data).Type_Mode = Type_Mode_Fat_Array then + return Stabilize (Chap3.Get_Array_Base (Data)); + else + return Stabilize (Data); + end if; + end Sig2val_Prepare_Composite; + + function Sig2val_Update_Data_Array + (Val : Mnode; Targ_Type : Iir; Index : O_Dnode) return Mnode + is + begin + return Chap3.Index_Base (Val, Targ_Type, New_Obj_Value (Index)); + end Sig2val_Update_Data_Array; + + function Sig2val_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return Mnode + is + pragma Unreferenced (Targ_Type); + begin + return Chap6.Translate_Selected_Element (Val, El); + end Sig2val_Update_Data_Record; + + procedure Sig2val_Finish_Data_Composite (Data : in out Mnode) + is + pragma Unreferenced (Data); + begin + null; + end Sig2val_Finish_Data_Composite; + + procedure Translate_Signal_Assign_Effective_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Mnode) + is + pragma Unreferenced (Targ_Type); + begin + New_Assign_Stmt (New_Access_Element (M2E (Targ)), M2E (Data)); + end Translate_Signal_Assign_Effective_Non_Composite; + + procedure Translate_Signal_Assign_Effective is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Translate_Signal_Assign_Effective_Non_Composite, + Prepare_Data_Array => Sig2val_Prepare_Composite, + Update_Data_Array => Sig2val_Update_Data_Array, + Finish_Data_Array => Sig2val_Finish_Data_Composite, + Prepare_Data_Record => Sig2val_Prepare_Composite, + Update_Data_Record => Sig2val_Update_Data_Record, + Finish_Data_Record => Sig2val_Finish_Data_Composite); + + procedure Translate_Signal_Assign_Driving_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data: Mnode) + is + begin + New_Assign_Stmt + (Chap14.Get_Signal_Value_Field (M2E (Targ), Targ_Type, + Ghdl_Signal_Driving_Value_Field), + M2E (Data)); + end Translate_Signal_Assign_Driving_Non_Composite; + + procedure Translate_Signal_Assign_Driving is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Translate_Signal_Assign_Driving_Non_Composite, + Prepare_Data_Array => Sig2val_Prepare_Composite, + Update_Data_Array => Sig2val_Update_Data_Array, + Finish_Data_Array => Sig2val_Finish_Data_Composite, + Prepare_Data_Record => Sig2val_Prepare_Composite, + Update_Data_Record => Sig2val_Update_Data_Record, + Finish_Data_Record => Sig2val_Finish_Data_Composite); + + function Translate_Signal_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode + is + procedure Translate_Signal_Non_Composite + (Targ : Mnode; + Targ_Type : Iir; + Data : Mnode) + is + begin + New_Assign_Stmt (M2Lv (Targ), + Read_Value (M2E (Data), Targ_Type)); + end Translate_Signal_Non_Composite; + + procedure Translate_Signal_Target is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Translate_Signal_Non_Composite, + Prepare_Data_Array => Sig2val_Prepare_Composite, + Update_Data_Array => Sig2val_Update_Data_Array, + Finish_Data_Array => Sig2val_Finish_Data_Composite, + Prepare_Data_Record => Sig2val_Prepare_Composite, + Update_Data_Record => Sig2val_Update_Data_Record, + Finish_Data_Record => Sig2val_Finish_Data_Composite); + + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Info (Sig_Type); + if Tinfo.Type_Mode in Type_Mode_Scalar then + return Read_Value (Sig, Sig_Type); + else + declare + Res : Mnode; + Var_Val : Mnode; + begin + -- allocate result array + if Tinfo.Type_Mode = Type_Mode_Fat_Array then + Res := Create_Temp (Tinfo); + + Var_Val := Stabilize (E2M (Sig, Tinfo, Mode_Signal)); + + -- Copy bounds. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (Var_Val))); + + -- Allocate base. + Chap3.Allocate_Fat_Array_Base (Alloc_Stack, Res, Sig_Type); + elsif Is_Complex_Type (Tinfo) then + Res := Create_Temp (Tinfo); + Chap4.Allocate_Complex_Object (Sig_Type, Alloc_Stack, Res); + else + Res := Create_Temp (Tinfo); + end if; + + Open_Temp; + + if Tinfo.Type_Mode /= Type_Mode_Fat_Array then + Var_Val := Stabilize (E2M (Sig, Tinfo, Mode_Signal)); + end if; + + Translate_Signal_Target (Res, Sig_Type, Var_Val); + Close_Temp; + return M2Addr (Res); + end; + end if; + end Translate_Signal_Value; + + -- Get the effective value of a simple signal SIG. + function Read_Signal_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode + is + pragma Unreferenced (Sig_Type); + begin + return New_Value (New_Access_Element (Sig)); + end Read_Signal_Value; + + -- Get the value of signal SIG. + function Translate_Signal is new Translate_Signal_Value + (Read_Value => Read_Signal_Value); + + function Translate_Signal_Effective_Value + (Sig : O_Enode; Sig_Type : Iir) return O_Enode + renames Translate_Signal; + + function Read_Signal_Driving_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode is + begin + return New_Value (Chap14.Get_Signal_Value_Field + (Sig, Sig_Type, Ghdl_Signal_Driving_Value_Field)); + end Read_Signal_Driving_Value; + + function Translate_Signal_Driving_Value_1 is new Translate_Signal_Value + (Read_Value => Read_Signal_Driving_Value); + + function Translate_Signal_Driving_Value + (Sig : O_Enode; Sig_Type : Iir) return O_Enode + renames Translate_Signal_Driving_Value_1; + + procedure Set_Effective_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode) + renames Translate_Signal_Assign_Effective; + procedure Set_Driving_Value + (Sig : Mnode; Sig_Type : Iir; Val : Mnode) + renames Translate_Signal_Assign_Driving; + + function Translate_Expression (Expr : Iir; Rtype : Iir := Null_Iir) + return O_Enode + is + Imp : Iir; + Expr_Type : Iir; + Res_Type : Iir; + Res : O_Enode; + begin + Expr_Type := Get_Type (Expr); + if Rtype = Null_Iir then + Res_Type := Expr_Type; + else + Res_Type := Rtype; + end if; + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Floating_Point_Literal => + return New_Lit (Translate_Static_Expression (Expr, Rtype)); + + when Iir_Kind_Physical_Int_Literal => + declare + Unit : Iir; + Unit_Info : Object_Info_Acc; + begin + Unit := Get_Unit_Name (Expr); + Unit_Info := Get_Info (Unit); + if Unit_Info = null then + return New_Lit + (Translate_Static_Expression (Expr, Rtype)); + else + -- Time units might be not locally static. + return New_Dyadic_Op + (ON_Mul_Ov, + New_Lit (New_Signed_Literal + (Get_Ortho_Type (Expr_Type, Mode_Value), + Integer_64 (Get_Value (Expr)))), + New_Value (Get_Var (Unit_Info.Object_Var))); + end if; + end; + + when Iir_Kind_Physical_Fp_Literal => + declare + Unit : Iir; + Unit_Info : Object_Info_Acc; + L, R : O_Enode; + begin + Unit := Get_Unit_Name (Expr); + Unit_Info := Get_Info (Unit); + if Unit_Info = null then + return New_Lit + (Translate_Static_Expression (Expr, Rtype)); + else + -- Time units might be not locally static. + L := New_Lit + (New_Float_Literal + (Ghdl_Real_Type, IEEE_Float_64 (Get_Fp_Value (Expr)))); + R := New_Convert_Ov + (New_Value (Get_Var (Unit_Info.Object_Var)), + Ghdl_Real_Type); + return New_Convert_Ov + (New_Dyadic_Op (ON_Mul_Ov, L, R), + Get_Ortho_Type (Expr_Type, Mode_Value)); + end if; + end; + + when Iir_Kind_Unit_Declaration => + declare + Unit_Info : Object_Info_Acc; + begin + Unit_Info := Get_Info (Expr); + if Unit_Info = null then + return New_Lit + (Translate_Static_Expression (Expr, Rtype)); + else + -- Time units might be not locally static. + return New_Value (Get_Var (Unit_Info.Object_Var)); + end if; + end; + + when Iir_Kind_String_Literal + | Iir_Kind_Bit_String_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Simple_Name_Attribute => + Res := Translate_String_Literal (Expr); + + when Iir_Kind_Aggregate => + declare + Aggr_Type : Iir; + Tinfo : Type_Info_Acc; + Mres : Mnode; + begin + -- Extract the type of the aggregate. Use the type of the + -- context if it is fully constrained. + pragma Assert (Rtype /= Null_Iir); + if Is_Fully_Constrained_Type (Rtype) then + Aggr_Type := Rtype; + else + Aggr_Type := Expr_Type; + end if; + if Get_Kind (Aggr_Type) = Iir_Kind_Array_Subtype_Definition + then + Chap3.Create_Array_Subtype (Aggr_Type, True); + end if; + + -- FIXME: this may be not necessary + Tinfo := Get_Info (Aggr_Type); + + -- The result area has to be created + if Is_Complex_Type (Tinfo) then + Mres := Create_Temp (Tinfo); + Chap4.Allocate_Complex_Object + (Aggr_Type, Alloc_Stack, Mres); + else + -- if thin array/record: + -- create result + Mres := Create_Temp (Tinfo); + end if; + + Translate_Aggregate (Mres, Aggr_Type, Expr); + Res := M2E (Mres); + + if Aggr_Type /= Rtype then + Res := Translate_Implicit_Conv + (Res, Aggr_Type, Rtype, Mode_Value, Expr); + end if; + return Res; + end; + + when Iir_Kind_Null_Literal => + declare + Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); + Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); + L : O_Dnode; + B : Type_Info_Acc; + begin + if Tinfo.Type_Mode = Type_Mode_Fat_Acc then + -- Create a fat null pointer. + -- FIXME: should be optimized!! + L := Create_Temp (Otype); + B := Get_Info (Get_Designated_Type (Expr_Type)); + New_Assign_Stmt + (New_Selected_Element (New_Obj (L), + B.T.Base_Field (Mode_Value)), + New_Lit + (New_Null_Access (B.T.Base_Ptr_Type (Mode_Value)))); + New_Assign_Stmt + (New_Selected_Element + (New_Obj (L), B.T.Bounds_Field (Mode_Value)), + New_Lit (New_Null_Access (B.T.Bounds_Ptr_Type))); + return New_Address (New_Obj (L), + Tinfo.Ortho_Ptr_Type (Mode_Value)); + else + return New_Lit (New_Null_Access (Otype)); + end if; + end; + + when Iir_Kind_Overflow_Literal => + declare + Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); + Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); + L : O_Dnode; + begin + -- Generate the error message + Chap6.Gen_Bound_Error (Expr); + + -- Create a dummy value + L := Create_Temp (Otype); + if Tinfo.Type_Mode = Type_Mode_Fat_Acc then + return New_Address (New_Obj (L), + Tinfo.Ortho_Ptr_Type (Mode_Value)); + else + return New_Obj_Value (L); + end if; + end; + + when Iir_Kind_Parenthesis_Expression => + return Translate_Expression (Get_Expression (Expr), Rtype); + + when Iir_Kind_Allocator_By_Expression => + return Translate_Allocator_By_Expression (Expr); + when Iir_Kind_Allocator_By_Subtype => + return Translate_Allocator_By_Subtype (Expr); + + when Iir_Kind_Qualified_Expression => + -- FIXME: check type. + Res := Translate_Expression (Get_Expression (Expr), Expr_Type); + + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Attribute_Value + | Iir_Kind_Attribute_Name => + declare + L : Mnode; + begin + L := Chap6.Translate_Name (Expr); + + Res := M2E (L); + if Get_Object_Kind (L) = Mode_Signal then + Res := Translate_Signal (Res, Expr_Type); + end if; + end; + + when Iir_Kind_Iterator_Declaration => + declare + Expr_Info : Ortho_Info_Acc; + begin + Expr_Info := Get_Info (Expr); + Res := New_Value (Get_Var (Expr_Info.Iterator_Var)); + if Rtype /= Null_Iir then + Res := New_Convert_Ov + (Res, Get_Ortho_Type (Rtype, Mode_Value)); + end if; + return Res; + end; + + when Iir_Kinds_Dyadic_Operator => + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration then + return Translate_Predefined_Operator + (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type, Expr); + else + return Translate_Operator_Function_Call + (Imp, Get_Left (Expr), Get_Right (Expr), Res_Type); + end if; + when Iir_Kinds_Monadic_Operator => + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration then + return Translate_Predefined_Operator + (Imp, Get_Operand (Expr), Null_Iir, Res_Type, Expr); + else + return Translate_Operator_Function_Call + (Imp, Get_Operand (Expr), Null_Iir, Res_Type); + end if; + when Iir_Kind_Function_Call => + Imp := Get_Implementation (Expr); + declare + Assoc_Chain : Iir; + begin + if Get_Kind (Imp) = Iir_Kind_Implicit_Function_Declaration + then + declare + Left, Right : Iir; + begin + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + if Assoc_Chain = Null_Iir then + Left := Null_Iir; + Right := Null_Iir; + else + Left := Get_Actual (Assoc_Chain); + Assoc_Chain := Get_Chain (Assoc_Chain); + if Assoc_Chain = Null_Iir then + Right := Null_Iir; + else + Right := Get_Actual (Assoc_Chain); + end if; + end if; + return Translate_Predefined_Operator + (Imp, Left, Right, Res_Type, Expr); + end; + else + Canon.Canon_Subprogram_Call (Expr); + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Res := Translate_Function_Call + (Imp, Assoc_Chain, Get_Method_Object (Expr)); + Expr_Type := Get_Return_Type (Imp); + end if; + end; + + when Iir_Kind_Type_Conversion => + declare + Conv_Expr : Iir; + begin + Conv_Expr := Get_Expression (Expr); + Res := Translate_Type_Conversion + (Translate_Expression (Conv_Expr), Get_Type (Conv_Expr), + Expr_Type, Expr); + end; + + when Iir_Kind_Length_Array_Attribute => + return Chap14.Translate_Length_Array_Attribute + (Expr, Res_Type); + when Iir_Kind_Low_Array_Attribute => + return Chap14.Translate_Low_Array_Attribute (Expr); + when Iir_Kind_High_Array_Attribute => + return Chap14.Translate_High_Array_Attribute (Expr); + when Iir_Kind_Left_Array_Attribute => + return Chap14.Translate_Left_Array_Attribute (Expr); + when Iir_Kind_Right_Array_Attribute => + return Chap14.Translate_Right_Array_Attribute (Expr); + when Iir_Kind_Ascending_Array_Attribute => + return Chap14.Translate_Ascending_Array_Attribute (Expr); + + when Iir_Kind_Val_Attribute => + return Chap14.Translate_Val_Attribute (Expr); + when Iir_Kind_Pos_Attribute => + return Chap14.Translate_Pos_Attribute (Expr, Res_Type); + + when Iir_Kind_Succ_Attribute + | Iir_Kind_Pred_Attribute => + return Chap14.Translate_Succ_Pred_Attribute (Expr); + + when Iir_Kind_Image_Attribute => + Res := Chap14.Translate_Image_Attribute (Expr); + + when Iir_Kind_Value_Attribute => + return Chap14.Translate_Value_Attribute (Expr); + + when Iir_Kind_Event_Attribute => + return Chap14.Translate_Event_Attribute (Expr); + when Iir_Kind_Active_Attribute => + return Chap14.Translate_Active_Attribute (Expr); + when Iir_Kind_Last_Value_Attribute => + Res := Chap14.Translate_Last_Value_Attribute (Expr); + + when Iir_Kind_High_Type_Attribute => + return Chap14.Translate_High_Low_Type_Attribute + (Get_Type (Expr), True); + when Iir_Kind_Low_Type_Attribute => + return Chap14.Translate_High_Low_Type_Attribute + (Get_Type (Expr), False); + when Iir_Kind_Left_Type_Attribute => + return M2E + (Chap3.Range_To_Left + (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type), + Get_Info (Get_Base_Type (Expr_Type)), Mode_Value))); + when Iir_Kind_Right_Type_Attribute => + return M2E + (Chap3.Range_To_Right + (Lv2M (Translate_Range (Get_Prefix (Expr), Expr_Type), + Get_Info (Get_Base_Type (Expr_Type)), Mode_Value))); + + when Iir_Kind_Last_Event_Attribute => + return Chap14.Translate_Last_Time_Attribute + (Get_Prefix (Expr), Ghdl_Signal_Last_Event_Field); + when Iir_Kind_Last_Active_Attribute => + return Chap14.Translate_Last_Time_Attribute + (Get_Prefix (Expr), Ghdl_Signal_Last_Active_Field); + + when Iir_Kind_Driving_Value_Attribute => + Res := Chap14.Translate_Driving_Value_Attribute (Expr); + when Iir_Kind_Driving_Attribute => + Res := Chap14.Translate_Driving_Attribute (Expr); + + when Iir_Kind_Path_Name_Attribute + | Iir_Kind_Instance_Name_Attribute => + Res := Chap14.Translate_Path_Instance_Name_Attribute (Expr); + + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Selected_Name => + return Translate_Expression (Get_Named_Entity (Expr), Rtype); + + when others => + Error_Kind ("translate_expression", Expr); + end case; + + -- Quick test to avoid useless calls. + if Expr_Type /= Res_Type then + Res := Translate_Implicit_Conv + (Res, Expr_Type, Res_Type, Mode_Value, Expr); + end if; + + return Res; + end Translate_Expression; + + -- Check if RNG is of the form: + -- 1 to T'length + -- or T'Length downto 1 + -- or 0 to T'length - 1 + -- or T'Length - 1 downto 0 + -- In either of these cases, return T'Length + function Is_Length_Range_Expression (Rng : Iir_Range_Expression) + return Iir + is + -- Pattern of a bound. + type Length_Pattern is + ( + Pat_Unknown, + Pat_Length, + Pat_Length_1, -- Length - 1 + Pat_1, + Pat_0 + ); + Length_Attr : Iir := Null_Iir; + + -- Classify the bound. + -- Set LENGTH_ATTR is the pattern is Pat_Length. + function Get_Length_Pattern (Expr : Iir; Recurse : Boolean) + return Length_Pattern + is + begin + case Get_Kind (Expr) is + when Iir_Kind_Length_Array_Attribute => + Length_Attr := Expr; + return Pat_Length; + when Iir_Kind_Integer_Literal => + case Get_Value (Expr) is + when 0 => + return Pat_0; + when 1 => + return Pat_1; + when others => + return Pat_Unknown; + end case; + when Iir_Kind_Substraction_Operator => + if not Recurse then + return Pat_Unknown; + end if; + if Get_Length_Pattern (Get_Left (Expr), False) = Pat_Length + and then + Get_Length_Pattern (Get_Right (Expr), False) = Pat_1 + then + return Pat_Length_1; + else + return Pat_Unknown; + end if; + when others => + return Pat_Unknown; + end case; + end Get_Length_Pattern; + Left_Pat, Right_Pat : Length_Pattern; + begin + Left_Pat := Get_Length_Pattern (Get_Left_Limit (Rng), True); + if Left_Pat = Pat_Unknown then + return Null_Iir; + end if; + Right_Pat := Get_Length_Pattern (Get_Right_Limit (Rng), True); + if Right_Pat = Pat_Unknown then + return Null_Iir; + end if; + case Get_Direction (Rng) is + when Iir_To => + if (Left_Pat = Pat_1 and Right_Pat = Pat_Length) + or else (Left_Pat = Pat_0 and Right_Pat = Pat_Length_1) + then + return Length_Attr; + end if; + when Iir_Downto => + if (Left_Pat = Pat_Length and Right_Pat = Pat_1) + or else (Left_Pat = Pat_Length_1 and Right_Pat = Pat_0) + then + return Length_Attr; + end if; + end case; + return Null_Iir; + end Is_Length_Range_Expression; + + procedure Translate_Range_Expression_Ptr + (Res_Ptr : O_Dnode; Expr : Iir; Range_Type : Iir) + is + T_Info : Type_Info_Acc; + Length_Attr : Iir; + begin + T_Info := Get_Info (Range_Type); + Open_Temp; + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Left), + Chap7.Translate_Range_Expression_Left (Expr, Range_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Right), + Chap7.Translate_Range_Expression_Right (Expr, Range_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), T_Info.T.Range_Dir), + New_Lit (Chap7.Translate_Static_Range_Dir (Expr))); + if T_Info.T.Range_Length /= O_Fnode_Null then + if Get_Expr_Staticness (Expr) = Locally then + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + New_Lit (Translate_Static_Range_Length (Expr))); + else + Length_Attr := Is_Length_Range_Expression (Expr); + if Length_Attr = Null_Iir then + Open_Temp; + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + Compute_Range_Length + (New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Left), + New_Value_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Right), + Get_Direction (Expr))); + Close_Temp; + else + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), + T_Info.T.Range_Length), + Chap14.Translate_Length_Array_Attribute + (Length_Attr, Null_Iir)); + end if; + end if; + end if; + Close_Temp; + end Translate_Range_Expression_Ptr; + + -- Reverse range ARANGE. + procedure Translate_Reverse_Range_Ptr + (Res_Ptr : O_Dnode; Arange : O_Lnode; Range_Type : Iir) + is + Rinfo : Type_Info_Acc; + Ptr : O_Dnode; + If_Blk : O_If_Block; + begin + Rinfo := Get_Info (Get_Base_Type (Range_Type)); + Open_Temp; + Ptr := Create_Temp_Ptr (Rinfo.T.Range_Ptr_Type, Arange); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Left), + New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Right)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Right), + New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Left)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Length), + New_Value_Selected_Acc_Value (New_Obj (Ptr), + Rinfo.T.Range_Length)); + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Eq, + New_Value_Selected_Acc_Value (New_Obj (Ptr), Rinfo.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Dir), + New_Lit (Ghdl_Dir_Downto_Node)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Res_Ptr), Rinfo.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node)); + Finish_If_Stmt (If_Blk); + Close_Temp; + end Translate_Reverse_Range_Ptr; + + procedure Copy_Range (Dest_Ptr : O_Dnode; + Src_Ptr : O_Dnode; + Info : Type_Info_Acc) + is + begin + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Left), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Left)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Right), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Right)); + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), Info.T.Range_Dir), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Dir)); + if Info.T.Range_Length /= O_Fnode_Null then + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Dest_Ptr), + Info.T.Range_Length), + New_Value_Selected_Acc_Value (New_Obj (Src_Ptr), + Info.T.Range_Length)); + end if; + end Copy_Range; + + procedure Translate_Range_Ptr + (Res_Ptr : O_Dnode; Arange : Iir; Range_Type : Iir) + is + begin + case Get_Kind (Arange) is + when Iir_Kind_Range_Array_Attribute => + declare + Ptr : O_Dnode; + Rinfo : Type_Info_Acc; + begin + Rinfo := Get_Info (Get_Base_Type (Range_Type)); + Open_Temp; + Ptr := Create_Temp_Ptr + (Rinfo.T.Range_Ptr_Type, + Chap14.Translate_Range_Array_Attribute (Arange)); + Copy_Range (Res_Ptr, Ptr, Rinfo); + Close_Temp; + end; + when Iir_Kind_Reverse_Range_Array_Attribute => + Translate_Reverse_Range_Ptr + (Res_Ptr, + Chap14.Translate_Range_Array_Attribute (Arange), + Range_Type); + when Iir_Kind_Range_Expression => + Translate_Range_Expression_Ptr (Res_Ptr, Arange, Range_Type); + when others => + Error_Kind ("translate_range_ptr", Arange); + end case; + end Translate_Range_Ptr; + + procedure Translate_Discrete_Range_Ptr (Res_Ptr : O_Dnode; Arange : Iir) + is + begin + case Get_Kind (Arange) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + if not Is_Anonymous_Type_Definition (Arange) then + declare + Ptr : O_Dnode; + Rinfo : Type_Info_Acc; + begin + Rinfo := Get_Info (Arange); + Open_Temp; + Ptr := Create_Temp_Ptr + (Rinfo.T.Range_Ptr_Type, Get_Var (Rinfo.T.Range_Var)); + Copy_Range (Res_Ptr, Ptr, Rinfo); + Close_Temp; + end; + else + Translate_Range_Ptr (Res_Ptr, + Get_Range_Constraint (Arange), + Get_Base_Type (Arange)); + end if; + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute + | Iir_Kind_Range_Expression => + Translate_Range_Ptr (Res_Ptr, Arange, Get_Type (Arange)); + when others => + Error_Kind ("translate_discrete_range_ptr", Arange); + end case; + end Translate_Discrete_Range_Ptr; + + function Translate_Range (Arange : Iir; Range_Type : Iir) + return O_Lnode is + begin + case Get_Kind (Arange) is + when Iir_Kinds_Denoting_Name => + return Translate_Range (Get_Named_Entity (Arange), Range_Type); + when Iir_Kind_Subtype_Declaration => + -- Must be a scalar subtype. Range of types is static. + return Get_Var (Get_Info (Get_Type (Arange)).T.Range_Var); + when Iir_Kind_Range_Array_Attribute => + return Chap14.Translate_Range_Array_Attribute (Arange); + when Iir_Kind_Reverse_Range_Array_Attribute => + declare + Res : O_Dnode; + Res_Ptr : O_Dnode; + Rinfo : Type_Info_Acc; + begin + Rinfo := Get_Info (Range_Type); + Res := Create_Temp (Rinfo.T.Range_Type); + Open_Temp; + Res_Ptr := Create_Temp_Ptr (Rinfo.T.Range_Ptr_Type, + New_Obj (Res)); + Translate_Reverse_Range_Ptr + (Res_Ptr, + Chap14.Translate_Range_Array_Attribute (Arange), + Range_Type); + Close_Temp; + return New_Obj (Res); + end; + when Iir_Kind_Range_Expression => + declare + Res : O_Dnode; + Ptr : O_Dnode; + T_Info : Type_Info_Acc; + begin + T_Info := Get_Info (Range_Type); + Res := Create_Temp (T_Info.T.Range_Type); + Open_Temp; + Ptr := Create_Temp_Ptr (T_Info.T.Range_Ptr_Type, + New_Obj (Res)); + Translate_Range_Expression_Ptr (Ptr, Arange, Range_Type); + Close_Temp; + return New_Obj (Res); + end; + when others => + Error_Kind ("translate_range", Arange); + end case; + return O_Lnode_Null; + end Translate_Range; + + function Translate_Static_Range (Arange : Iir; Range_Type : Iir) + return O_Cnode + is + Constr : O_Record_Aggr_List; + Res : O_Cnode; + T_Info : Type_Info_Acc; + begin + T_Info := Get_Info (Range_Type); + Start_Record_Aggr (Constr, T_Info.T.Range_Type); + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Left (Arange, Range_Type)); + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Right (Arange, Range_Type)); + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Dir (Arange)); + if T_Info.T.Range_Length /= O_Fnode_Null then + New_Record_Aggr_El + (Constr, Chap7.Translate_Static_Range_Length (Arange)); + end if; + Finish_Record_Aggr (Constr, Res); + return Res; + end Translate_Static_Range; + + procedure Translate_Predefined_Array_Compare (Subprg : Iir) + is + procedure Gen_Compare (L, R : O_Dnode) + is + If_Blk1, If_Blk2 : O_If_Block; + begin + Start_If_Stmt + (If_Blk1, + New_Compare_Op (ON_Neq, New_Obj_Value (L), New_Obj_Value (R), + Ghdl_Bool_Type)); + Start_If_Stmt + (If_Blk2, + New_Compare_Op (ON_Gt, New_Obj_Value (L), New_Obj_Value (R), + Ghdl_Bool_Type)); + New_Return_Stmt (New_Lit (Ghdl_Compare_Gt)); + New_Else_Stmt (If_Blk2); + New_Return_Stmt (New_Lit (Ghdl_Compare_Lt)); + Finish_If_Stmt (If_Blk2); + Finish_If_Stmt (If_Blk1); + end Gen_Compare; + + Arr_Type : constant Iir_Array_Type_Definition := + Get_Type (Get_Interface_Declaration_Chain (Subprg)); + Info : constant Type_Info_Acc := Get_Info (Arr_Type); + Id : constant Name_Id := + Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info : Subprg_Info_Acc; + L, R : O_Dnode; + Interface_List : O_Inter_List; + If_Blk : O_If_Block; + Var_L_Len, Var_R_Len : O_Dnode; + Var_L_El, Var_R_El : O_Dnode; + Var_I, Var_Len : O_Dnode; + Label : O_Snode; + El_Otype : O_Tnode; + begin + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + + -- Create function. + Start_Function_Decl (Interface_List, Create_Identifier (Id, "_CMP"), + Global_Storage, Ghdl_Compare_Type); + New_Interface_Decl (Interface_List, L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, R, Wki_Right, Arr_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + El_Otype := Get_Ortho_Type + (Get_Element_Subtype (Arr_Type), Mode_Value); + Start_Subprogram_Body (F_Info.Ortho_Func); + -- Compute length of L and R. + New_Var_Decl (Var_L_Len, Wki_L_Len, + O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_R_Len, Wki_R_Len, + O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Assign_Stmt (New_Obj (Var_L_Len), + Chap6.Get_Array_Bound_Length + (Dp2M (L, Info, Mode_Value), Arr_Type, 1)); + New_Assign_Stmt (New_Obj (Var_R_Len), + Chap6.Get_Array_Bound_Length + (Dp2M (R, Info, Mode_Value), Arr_Type, 1)); + -- Find the minimum length. + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_L_Len), + New_Obj_Value (Var_R_Len), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_R_Len)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Var_Len), New_Obj_Value (Var_L_Len)); + Finish_If_Stmt (If_Blk); + + -- for each element, compare elements; if not equal return the + -- comparaison result. + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Len), + Ghdl_Bool_Type)); + -- Compare the length and return the result. + Gen_Compare (Var_L_Len, Var_R_Len); + New_Return_Stmt (New_Lit (Ghdl_Compare_Eq)); + Finish_If_Stmt (If_Blk); + Start_Declare_Stmt; + New_Var_Decl (Var_L_El, Get_Identifier ("l_el"), O_Storage_Local, + El_Otype); + New_Var_Decl (Var_R_El, Get_Identifier ("r_el"), O_Storage_Local, + El_Otype); + New_Assign_Stmt + (New_Obj (Var_L_El), + M2E (Chap3.Index_Base + (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value)), + Arr_Type, + New_Obj_Value (Var_I)))); + New_Assign_Stmt + (New_Obj (Var_R_El), + M2E (Chap3.Index_Base + (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value)), + Arr_Type, + New_Obj_Value (Var_I)))); + Gen_Compare (Var_L_El, Var_R_El); + Finish_Declare_Stmt; + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Subprogram_Body; + end Translate_Predefined_Array_Compare; + + -- Find the declaration of the predefined function IMP in type + -- definition BASE_TYPE. + function Find_Predefined_Function + (Base_Type : Iir; Imp : Iir_Predefined_Functions) + return Iir + is + El : Iir; + begin + El := Get_Chain (Get_Type_Declarator (Base_Type)); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + if Get_Implicit_Definition (El) = Imp then + return El; + else + El := Get_Chain (El); + end if; + when others => + raise Internal_Error; + end case; + end loop; + raise Internal_Error; + end Find_Predefined_Function; + + function Translate_Equality (L, R : Mnode; Etype : Iir) + return O_Enode + is + Tinfo : Type_Info_Acc; + begin + Tinfo := Get_Type_Info (L); + case Tinfo.Type_Mode is + when Type_Mode_Scalar + | Type_Mode_Acc => + return New_Compare_Op (ON_Eq, M2E (L), M2E (R), + Ghdl_Bool_Type); + when Type_Mode_Fat_Acc => + -- a fat pointer. + declare + B : Type_Info_Acc; + Ln, Rn : Mnode; + V1, V2 : O_Enode; + begin + B := Get_Info (Get_Designated_Type (Etype)); + Ln := Stabilize (L); + Rn := Stabilize (R); + V1 := New_Compare_Op + (ON_Eq, + New_Value (New_Selected_Element + (M2Lv (Ln), B.T.Base_Field (Mode_Value))), + New_Value (New_Selected_Element + (M2Lv (Rn), B.T.Base_Field (Mode_Value))), + Std_Boolean_Type_Node); + V2 := New_Compare_Op + (ON_Eq, + New_Value (New_Selected_Element + (M2Lv (Ln), B.T.Bounds_Field (Mode_Value))), + New_Value (New_Selected_Element + (M2Lv (Rn), B.T.Bounds_Field (Mode_Value))), + Std_Boolean_Type_Node); + return New_Dyadic_Op (ON_And, V1, V2); + end; + + when Type_Mode_Array => + declare + Lc, Rc : O_Enode; + Base_Type : Iir_Array_Type_Definition; + Func : Iir; + begin + Base_Type := Get_Base_Type (Etype); + Lc := Translate_Implicit_Conv + (M2E (L), Etype, Base_Type, Mode_Value, Null_Iir); + Rc := Translate_Implicit_Conv + (M2E (R), Etype, Base_Type, Mode_Value, Null_Iir); + Func := Find_Predefined_Function + (Base_Type, Iir_Predefined_Array_Equality); + return Translate_Predefined_Lib_Operator (Lc, Rc, Func); + end; + + when Type_Mode_Record => + declare + Func : Iir; + begin + Func := Find_Predefined_Function + (Get_Base_Type (Etype), Iir_Predefined_Record_Equality); + return Translate_Predefined_Lib_Operator + (M2E (L), M2E (R), Func); + end; + + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Fat_Array + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Equality; + + procedure Translate_Predefined_Array_Equality (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + Info : Type_Info_Acc; + Id : Name_Id; + Var_L, Var_R : O_Dnode; + L, R : Mnode; + Interface_List : O_Inter_List; + Indexes : Iir_List; + Nbr_Indexes : Natural; + If_Blk : O_If_Block; + Var_I : O_Dnode; + Var_Len : O_Dnode; + Label : O_Snode; + Le, Re : Mnode; + El_Type : Iir; + begin + Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); + El_Type := Get_Element_Subtype (Arr_Type); + Info := Get_Info (Arr_Type); + Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + + -- Create function. + Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), + Global_Storage, Std_Boolean_Type_Node); + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + L := Dp2M (Var_L, Info, Mode_Value); + R := Dp2M (Var_R, Info, Mode_Value); + + Indexes := Get_Index_Subtype_List (Arr_Type); + Nbr_Indexes := Get_Nbr_Elements (Indexes); + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + -- for each dimension: if length mismatch: return false + for I in 1 .. Nbr_Indexes loop + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Neq, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (L, Arr_Type, I))), + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (R, Arr_Type, I))), + Std_Boolean_Type_Node)); + New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); + Finish_If_Stmt (If_Blk); + end loop; + + -- for each element: if element is not equal, return false + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); + Open_Temp; + New_Assign_Stmt (New_Obj (Var_Len), + Chap3.Get_Array_Length (L, Arr_Type)); + Close_Temp; + Init_Var (Var_I); + Start_Loop_Stmt (Label); + -- If the end of the array is reached, return TRUE. + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Len), + Ghdl_Bool_Type)); + New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); + Finish_If_Stmt (If_Blk); + Open_Temp; + Le := Chap3.Index_Base (Chap3.Get_Array_Base (L), Arr_Type, + New_Obj_Value (Var_I)); + Re := Chap3.Index_Base (Chap3.Get_Array_Base (R), Arr_Type, + New_Obj_Value (Var_I)); + Start_If_Stmt + (If_Blk, + New_Monadic_Op (ON_Not, Translate_Equality (Le, Re, El_Type))); + New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); + Finish_If_Stmt (If_Blk); + Close_Temp; + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Array_Equality; + + procedure Translate_Predefined_Record_Equality (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Rec_Type : Iir_Record_Type_Definition; + Rec_Ptr_Type : O_Tnode; + Info : Type_Info_Acc; + Id : Name_Id; + Var_L, Var_R : O_Dnode; + L, R : Mnode; + Interface_List : O_Inter_List; + If_Blk : O_If_Block; + Le, Re : Mnode; + + El_List : Iir_List; + El : Iir_Element_Declaration; + begin + Rec_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); + Info := Get_Info (Rec_Type); + Id := Get_Identifier (Get_Type_Declarator (Rec_Type)); + Rec_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + + -- Create function. + Start_Function_Decl (Interface_List, Create_Identifier (Id, "_EQ"), + Global_Storage, Std_Boolean_Type_Node); + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Rec_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Rec_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + + L := Dp2M (Var_L, Info, Mode_Value); + R := Dp2M (Var_R, Info, Mode_Value); + + -- Compare each element. + El_List := Get_Elements_Declaration_List (Rec_Type); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + Le := Chap6.Translate_Selected_Element (L, El); + Re := Chap6.Translate_Selected_Element (R, El); + + Open_Temp; + Start_If_Stmt + (If_Blk, + New_Monadic_Op (ON_Not, + Translate_Equality (Le, Re, Get_Type (El)))); + New_Return_Stmt (New_Lit (Std_Boolean_False_Node)); + Finish_If_Stmt (If_Blk); + Close_Temp; + end loop; + New_Return_Stmt (New_Lit (Std_Boolean_True_Node)); + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Record_Equality; + + procedure Translate_Predefined_Array_Array_Concat (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + + -- Info for the array type. + Info : Type_Info_Acc; + + -- Info for the index type. + Iinfo : Type_Info_Acc; + Index_Type : Iir; + + Index_Otype : O_Tnode; + Id : Name_Id; + Interface_List : O_Inter_List; + Var_Res, Var_L, Var_R : O_Dnode; + Res, L, R : Mnode; + Var_Length, Var_L_Len, Var_R_Len : O_Dnode; + Var_Bounds, Var_Right : O_Dnode; + V_Bounds : Mnode; + If_Blk : O_If_Block; + begin + Arr_Type := Get_Return_Type (Subprg); + Info := Get_Info (Arr_Type); + Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + F_Info.Use_Stack2 := True; + + -- Create function. + Start_Procedure_Decl + (Interface_List, Create_Identifier (Id, "_CONCAT"), Global_Storage); + -- Note: contrary to user function which returns composite value + -- via a result record, a concatenation returns its value without + -- the use of the record. + Chap2.Create_Subprg_Instance (Interface_List, Subprg); + New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Arr_Ptr_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Index_Type := Get_Index_Type (Arr_Type, 0); + Iinfo := Get_Info (Index_Type); + Index_Otype := Iinfo.Ortho_Type (Mode_Value); + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_L_Len, Wki_L_Len, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_R_Len, Wki_R_Len, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Bounds, Get_Identifier ("bounds"), O_Storage_Local, + Info.T.Bounds_Ptr_Type); + + L := Dp2M (Var_L, Info, Mode_Value); + R := Dp2M (Var_R, Info, Mode_Value); + Res := Dp2M (Var_Res, Info, Mode_Value); + V_Bounds := Dp2M (Var_Bounds, Info, Mode_Value, + Info.T.Bounds_Type, Info.T.Bounds_Ptr_Type); + + -- Compute length. + New_Assign_Stmt + (New_Obj (Var_L_Len), Chap3.Get_Array_Length (L, Arr_Type)); + New_Assign_Stmt + (New_Obj (Var_R_Len), Chap3.Get_Array_Length (R, Arr_Type)); + New_Assign_Stmt + (New_Obj (Var_Length), New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_L_Len), + New_Obj_Value (Var_R_Len))); + + -- Check case where the result is the right operand. + declare + Len : O_Enode; + begin + if Flags.Vhdl_Std = Vhdl_87 then + -- LRM87 7.2.4 + -- [...], unless the left operand is a null array, in which + -- case the result of the concatenation is the right operand. + Len := New_Obj_Value (Var_L_Len); + + else + -- LRM93 7.2.4 + -- If both operands are null arrays, then the result of the + -- concatenation is the right operand. + -- GHDL: since the length type is unsigned, then both operands + -- are null arrays iff the result is a null array. + Len := New_Obj_Value (Var_Length); + end if; + + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + Len, + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Copy_Fat_Pointer (Res, R); + New_Return_Stmt; + Finish_If_Stmt (If_Blk); + end; + + -- Allocate bounds. + New_Assign_Stmt + (New_Obj (Var_Bounds), + Gen_Alloc (Alloc_Return, + New_Lit (New_Sizeof (Info.T.Bounds_Type, + Ghdl_Index_Type)), + Info.T.Bounds_Ptr_Type)); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), New_Obj_Value (Var_Bounds)); + + -- Set bound. + if Flags.Vhdl_Std = Vhdl_87 then + -- Set length. + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Length + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Length)); + + -- Set direction, left bound and right bound. + -- LRM87 7.2.4 + -- The left bound of this result is the left bound of the left + -- operand, unless the left operand is a null array, in which + -- case the result of the concatenation is the right operand. + -- The direction of the result is the direction of the left + -- operand, unless the left operand is a null array, in which + -- case the direction of the result is that of the right operand. + declare + Var_Dir, Var_Left : O_Dnode; + Var_Length1 : O_Dnode; + begin + Start_Declare_Stmt; + New_Var_Decl (Var_Right, Get_Identifier ("right_bound"), + O_Storage_Local, Index_Otype); + New_Var_Decl (Var_Dir, Wki_Dir, O_Storage_Local, + Ghdl_Dir_Type_Node); + New_Var_Decl (Var_Left, Get_Identifier ("left_bound"), + O_Storage_Local, Iinfo.Ortho_Type (Mode_Value)); + New_Var_Decl (Var_Length1, Get_Identifier ("length_1"), + O_Storage_Local, Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Var_Dir), + M2E (Chap3.Range_To_Dir + (Chap3.Get_Array_Range (L, Arr_Type, 1)))); + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Dir + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Dir)); + New_Assign_Stmt + (New_Obj (Var_Left), + M2E (Chap3.Range_To_Left + (Chap3.Get_Array_Range (L, Arr_Type, 1)))); + -- Note this substraction cannot overflow, since LENGTH >= 1. + New_Assign_Stmt + (New_Obj (Var_Length1), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Length), + New_Lit (Ghdl_Index_1))); + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Left + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Left)); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, New_Obj_Value (Var_Dir), + New_Lit (Ghdl_Dir_To_Node), Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Obj (Var_Right), + New_Dyadic_Op (ON_Add_Ov, + New_Obj_Value (Var_Left), + New_Convert_Ov (New_Obj_Value (Var_Length1), + Index_Otype))); + New_Else_Stmt (If_Blk); + New_Assign_Stmt + (New_Obj (Var_Right), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Var_Left), + New_Convert_Ov (New_Obj_Value (Var_Length1), + Index_Otype))); + Finish_If_Stmt (If_Blk); + -- Check the right bounds is inside the bounds of the + -- index type. + Chap3.Check_Range (Var_Right, Null_Iir, Index_Type, Subprg); + New_Assign_Stmt + (M2Lv (Chap3.Range_To_Right + (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))), + New_Obj_Value (Var_Right)); + Finish_Declare_Stmt; + end; + else + -- LRM93 7.2.4 + -- [...], the direction and bounds of the result are determined + -- as follows: Let S be the index subtype of the base type of the + -- result. The direction of the result of the concatenation is + -- the direction of S, and the left bound of the result is + -- S'LEFT. + declare + Var_Range_Ptr : O_Dnode; + begin + Start_Declare_Stmt; + New_Var_Decl (Var_Range_Ptr, Get_Identifier ("range_ptr"), + O_Storage_Local, Iinfo.T.Range_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Range_Ptr), + M2Addr (Chap3.Bounds_To_Range (V_Bounds, Arr_Type, 1))); + Chap3.Create_Range_From_Length + (Index_Type, Var_Length, Var_Range_Ptr, Subprg); + Finish_Declare_Stmt; + end; + end if; + + -- Allocate array base. + Chap3.Allocate_Fat_Array_Base (Alloc_Return, Res, Arr_Type); + + -- Copy left. + declare + V_Arr : O_Dnode; + Var_Arr : Mnode; + begin + Open_Temp; + V_Arr := Create_Temp (Info.Ortho_Type (Mode_Value)); + Var_Arr := Dv2M (V_Arr, Info, Mode_Value); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Var_Arr)), + M2Addr (Chap3.Get_Array_Bounds (L))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Var_Arr)), + M2Addr (Chap3.Get_Array_Base (Res))); + Chap3.Translate_Object_Copy + (Var_Arr, New_Obj_Value (Var_L), Arr_Type); + Close_Temp; + end; + + -- Copy right. + declare + V_Arr : O_Dnode; + Var_Arr : Mnode; + begin + Open_Temp; + V_Arr := Create_Temp (Info.Ortho_Type (Mode_Value)); + Var_Arr := Dv2M (V_Arr, Info, Mode_Value); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Var_Arr)), + M2Addr (Chap3.Get_Array_Bounds (R))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Var_Arr)), + M2Addr (Chap3.Slice_Base (Chap3.Get_Array_Base (Res), + Arr_Type, + New_Obj_Value (Var_L_Len)))); + Chap3.Translate_Object_Copy + (Var_Arr, New_Obj_Value (Var_R), Arr_Type); + Close_Temp; + end; + Chap2.Finish_Subprg_Instance_Use (Subprg); + Finish_Subprogram_Body; + end Translate_Predefined_Array_Array_Concat; + + procedure Translate_Predefined_Array_Logical (Subprg : Iir) + is + Arr_Type : constant Iir_Array_Type_Definition := + Get_Type (Get_Interface_Declaration_Chain (Subprg)); + -- Info for the array type. + Info : constant Type_Info_Acc := Get_Info (Arr_Type); + -- Identifier of the type. + Id : constant Name_Id := + Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value); + F_Info : Subprg_Info_Acc; + Interface_List : O_Inter_List; + Var_Res : O_Dnode; + Res : Mnode; + L, R : O_Dnode; + Var_Length, Var_I : O_Dnode; + Var_Base, Var_L_Base, Var_R_Base : O_Dnode; + If_Blk : O_If_Block; + Label : O_Snode; + Name : O_Ident; + Is_Monadic : Boolean; + El, L_El : O_Enode; + Op : ON_Op_Kind; + Do_Invert : Boolean; + begin + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + F_Info.Use_Stack2 := True; + + Is_Monadic := False; + case Get_Implicit_Definition (Subprg) is + when Iir_Predefined_TF_Array_And => + Name := Create_Identifier (Id, "_AND"); + Op := ON_And; + Do_Invert := False; + when Iir_Predefined_TF_Array_Or => + Name := Create_Identifier (Id, "_OR"); + Op := ON_Or; + Do_Invert := False; + when Iir_Predefined_TF_Array_Nand => + Name := Create_Identifier (Id, "_NAND"); + Op := ON_And; + Do_Invert := True; + when Iir_Predefined_TF_Array_Nor => + Name := Create_Identifier (Id, "_NOR"); + Op := ON_Or; + Do_Invert := True; + when Iir_Predefined_TF_Array_Xor => + Name := Create_Identifier (Id, "_XOR"); + Op := ON_Xor; + Do_Invert := False; + when Iir_Predefined_TF_Array_Xnor => + Name := Create_Identifier (Id, "_XNOR"); + Op := ON_Xor; + Do_Invert := True; + when Iir_Predefined_TF_Array_Not => + Name := Create_Identifier (Id, "_NOT"); + Is_Monadic := True; + Op := ON_Not; + Do_Invert := False; + when others => + raise Internal_Error; + end case; + + -- Create function. + Start_Procedure_Decl (Interface_List, Name, Global_Storage); + -- Note: contrary to user function which returns composite value + -- via a result record, a concatenation returns its value without + -- the use of the record. + New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, L, Wki_Left, Arr_Ptr_Type); + if not Is_Monadic then + New_Interface_Decl (Interface_List, R, Wki_Right, Arr_Ptr_Type); + end if; + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Subprogram_Body (F_Info.Ortho_Func); + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_Base, Get_Identifier ("base"), O_Storage_Local, + Info.T.Base_Ptr_Type (Mode_Value)); + New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"), O_Storage_Local, + Info.T.Base_Ptr_Type (Mode_Value)); + if not Is_Monadic then + New_Var_Decl + (Var_R_Base, Get_Identifier ("r_base"), O_Storage_Local, + Info.T.Base_Ptr_Type (Mode_Value)); + end if; + Open_Temp; + -- Get length of LEFT. + New_Assign_Stmt (New_Obj (Var_Length), + Chap6.Get_Array_Bound_Length + (Dp2M (L, Info, Mode_Value), Arr_Type, 1)); + -- If dyadic, check RIGHT has the same length. + if not Is_Monadic then + Chap6.Check_Bound_Error + (New_Compare_Op (ON_Neq, + New_Obj_Value (Var_Length), + Chap6.Get_Array_Bound_Length + (Dp2M (R, Info, Mode_Value), Arr_Type, 1), + Ghdl_Bool_Type), + Subprg, 0); + end if; + + -- Create the result from LEFT bound. + Res := Dp2M (Var_Res, Info, Mode_Value); + Chap3.Translate_Object_Allocation + (Res, Alloc_Return, Arr_Type, + Chap3.Get_Array_Bounds (Dp2M (L, Info, Mode_Value))); + New_Assign_Stmt + (New_Obj (Var_Base), M2Addr (Chap3.Get_Array_Base (Res))); + New_Assign_Stmt + (New_Obj (Var_L_Base), + M2Addr (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value)))); + if not Is_Monadic then + New_Assign_Stmt + (New_Obj (Var_R_Base), + M2Addr (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value)))); + end if; + + -- Do the logical operation on each element. + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + New_Return_Stmt; + Finish_If_Stmt (If_Blk); + L_El := New_Value (New_Indexed_Element + (New_Acc_Value (New_Obj (Var_L_Base)), + New_Obj_Value (Var_I))); + if Is_Monadic then + El := New_Monadic_Op (Op, L_El); + else + El := New_Dyadic_Op + (Op, L_El, + New_Value (New_Indexed_Element + (New_Acc_Value (New_Obj (Var_R_Base)), + New_Obj_Value (Var_I)))); + end if; + if Do_Invert then + El := New_Monadic_Op (ON_Not, El); + end if; + + New_Assign_Stmt (New_Indexed_Element + (New_Acc_Value (New_Obj (Var_Base)), + New_Obj_Value (Var_I)), + El); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Close_Temp; + Finish_Subprogram_Body; + end Translate_Predefined_Array_Logical; + + procedure Translate_Predefined_Array_Shift (Subprg : Iir) + is + F_Info : Subprg_Info_Acc; + Inter : Iir; + Arr_Type : Iir_Array_Type_Definition; + Arr_Ptr_Type : O_Tnode; + Int_Type : O_Tnode; + -- Info for the array type. + Info : Type_Info_Acc; + Id : Name_Id; + Interface_List : O_Inter_List; + Var_Res : O_Dnode; + Var_L, Var_R : O_Dnode; + Name : O_Ident; + + type Shift_Kind is (Sh_Logical, Sh_Arith, Rotation); + Shift : Shift_Kind; + + -- Body; + Var_Length, Var_I, Var_I1 : O_Dnode; + Var_Res_Base, Var_L_Base : O_Dnode; + Var_Rl : O_Dnode; + Var_E : O_Dnode; + L : Mnode; + If_Blk, If_Blk1 : O_If_Block; + Label : O_Snode; + Res : Mnode; + + procedure Do_Shift (To_Right : Boolean) + is + Tmp : O_Enode; + begin + -- LEFT: + -- * I := 0; + if not To_Right then + Init_Var (Var_I); + end if; + + -- * If R < LENGTH then + Start_If_Stmt (If_Blk1, + New_Compare_Op (ON_Lt, + New_Obj_Value (Var_Rl), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + -- Shift the elements (that remains in the result). + -- RIGHT: + -- * for I = R to LENGTH - 1 loop + -- * RES[I] := L[I - R] + -- LEFT: + -- * for I = 0 to LENGTH - R loop + -- * RES[I] := L[R + I] + if To_Right then + New_Assign_Stmt (New_Obj (Var_I), New_Obj_Value (Var_Rl)); + Init_Var (Var_I1); + else + New_Assign_Stmt (New_Obj (Var_I1), New_Obj_Value (Var_Rl)); + end if; + Start_Loop_Stmt (Label); + if To_Right then + Tmp := New_Obj_Value (Var_I); + else + Tmp := New_Obj_Value (Var_I1); + end if; + Gen_Exit_When (Label, New_Compare_Op (ON_Ge, + Tmp, + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), + New_Obj_Value (Var_I)), + New_Value + (New_Indexed_Acc_Value (New_Obj (Var_L_Base), + New_Obj_Value (Var_I1)))); + Inc_Var (Var_I); + Inc_Var (Var_I1); + Finish_Loop_Stmt (Label); + -- RIGHT: + -- * else + -- * R := LENGTH; + if To_Right then + New_Else_Stmt (If_Blk1); + New_Assign_Stmt (New_Obj (Var_Rl), New_Obj_Value (Var_Length)); + end if; + Finish_If_Stmt (If_Blk1); + + -- Pad the result. + -- RIGHT: + -- * For I = 0 to R - 1 + -- * RES[I] := 0/L[0/LENGTH-1] + -- LEFT: + -- * For I = LENGTH - R to LENGTH - 1 + -- * RES[I] := 0/L[0/LENGTH-1] + if To_Right then + Init_Var (Var_I); + else + -- I is yet correctly set. + null; + end if; + if Shift = Sh_Arith then + if To_Right then + Tmp := New_Lit (Ghdl_Index_0); + else + Tmp := New_Dyadic_Op + (ON_Sub_Ov, + New_Obj_Value (Var_Length), + New_Lit (Ghdl_Index_1)); + end if; + New_Assign_Stmt + (New_Obj (Var_E), + New_Value (New_Indexed_Acc_Value (New_Obj (Var_L_Base), + Tmp))); + end if; + Start_Loop_Stmt (Label); + if To_Right then + Tmp := New_Obj_Value (Var_Rl); + else + Tmp := New_Obj_Value (Var_Length); + end if; + Gen_Exit_When (Label, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + Tmp, + Ghdl_Bool_Type)); + case Shift is + when Sh_Logical => + declare + Enum_List : Iir_List; + begin + Enum_List := Get_Enumeration_Literal_List + (Get_Base_Type (Get_Element_Subtype (Arr_Type))); + Tmp := New_Lit + (Get_Ortho_Expr (Get_First_Element (Enum_List))); + end; + when Sh_Arith => + Tmp := New_Obj_Value (Var_E); + when Rotation => + raise Internal_Error; + end case; + + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), + New_Obj_Value (Var_I)), Tmp); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + end Do_Shift; + begin + Inter := Get_Interface_Declaration_Chain (Subprg); + + Info := Get_Info (Get_Type (Get_Chain (Inter))); + Int_Type := Info.Ortho_Type (Mode_Value); + + Arr_Type := Get_Type (Inter); + Info := Get_Info (Arr_Type); + Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); + + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + F_Info.Use_Stack2 := True; + + case Get_Implicit_Definition (Subprg) is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl => + -- Shift logical. + Name := Create_Identifier (Id, "_SHL"); + Shift := Sh_Logical; + when Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + -- Shift arithmetic. + Name := Create_Identifier (Id, "_SHA"); + Shift := Sh_Arith; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + -- Rotation + Name := Create_Identifier (Id, "_ROT"); + Shift := Rotation; + when others => + raise Internal_Error; + end case; + + -- Create function. + Start_Procedure_Decl (Interface_List, Name, Global_Storage); + -- Note: contrary to user function which returns composite value + -- via a result record, a shift returns its value without + -- the use of the record. + New_Interface_Decl (Interface_List, Var_Res, Wki_Res, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_L, Wki_Left, Arr_Ptr_Type); + New_Interface_Decl (Interface_List, Var_R, Wki_Right, Int_Type); + Finish_Subprogram_Decl (Interface_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + -- Body + Start_Subprogram_Body (F_Info.Ortho_Func); + New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, + Ghdl_Index_Type); + if Shift /= Rotation then + New_Var_Decl (Var_Rl, Get_Identifier ("rl"), O_Storage_Local, + Ghdl_Index_Type); + end if; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_I1, Get_Identifier ("I1"), O_Storage_Local, + Ghdl_Index_Type); + New_Var_Decl (Var_Res_Base, Get_Identifier ("res_base"), + O_Storage_Local, Info.T.Base_Ptr_Type (Mode_Value)); + New_Var_Decl (Var_L_Base, Get_Identifier ("l_base"), + O_Storage_Local, Info.T.Base_Ptr_Type (Mode_Value)); + if Shift = Sh_Arith then + New_Var_Decl (Var_E, Get_Identifier ("E"), O_Storage_Local, + Get_Info (Get_Element_Subtype (Arr_Type)). + Ortho_Type (Mode_Value)); + end if; + Res := Dp2M (Var_Res, Info, Mode_Value); + L := Dp2M (Var_L, Info, Mode_Value); + + -- LRM93 7.2.3 + -- The index subtypes of the return values of all shift operators is + -- the same as the index subtype of their left arguments. + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (L))); + + -- Get length of LEFT. + New_Assign_Stmt (New_Obj (Var_Length), + Chap3.Get_Array_Length (L, Arr_Type)); + + -- LRM93 7.2.3 [6 times] + -- That is, if R is 0 or L is a null array, the return value is L. + Start_If_Stmt + (If_Blk, + New_Dyadic_Op + (ON_Or, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_R), + New_Lit (New_Signed_Literal (Int_Type, 0)), + Ghdl_Bool_Type), + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type))); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + M2Addr (Chap3.Get_Array_Base (L))); + New_Return_Stmt; + Finish_If_Stmt (If_Blk); + + -- Allocate base. + New_Assign_Stmt + (New_Obj (Var_Res_Base), + Gen_Alloc (Alloc_Return, New_Obj_Value (Var_Length), + Info.T.Base_Ptr_Type (Mode_Value))); + New_Assign_Stmt (M2Lp (Chap3.Get_Array_Base (Res)), + New_Obj_Value (Var_Res_Base)); + + New_Assign_Stmt (New_Obj (Var_L_Base), + M2Addr (Chap3.Get_Array_Base (L))); + + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Gt, + New_Obj_Value (Var_R), + New_Lit (New_Signed_Literal (Int_Type, + 0)), + Ghdl_Bool_Type)); + -- R > 0. + -- Ie, to the right + case Shift is + when Rotation => + -- * I1 := LENGTH - (R mod LENGTH) + New_Assign_Stmt + (New_Obj (Var_I1), + New_Dyadic_Op + (ON_Sub_Ov, + New_Obj_Value (Var_Length), + New_Dyadic_Op (ON_Mod_Ov, + New_Convert_Ov (New_Obj_Value (Var_R), + Ghdl_Index_Type), + New_Obj_Value (Var_Length)))); + + when Sh_Logical + | Sh_Arith => + -- Real SRL or SRA. + New_Assign_Stmt + (New_Obj (Var_Rl), + New_Convert_Ov (New_Obj_Value (Var_R), Ghdl_Index_Type)); + + Do_Shift (True); + end case; + + New_Else_Stmt (If_Blk); + + -- R < 0, to the left. + case Shift is + when Rotation => + -- * I1 := (-R) mod LENGTH + New_Assign_Stmt + (New_Obj (Var_I1), + New_Dyadic_Op (ON_Mod_Ov, + New_Convert_Ov + (New_Monadic_Op (ON_Neg_Ov, + New_Obj_Value (Var_R)), + Ghdl_Index_Type), + New_Obj_Value (Var_Length))); + when Sh_Logical + | Sh_Arith => + -- Real SLL or SLA. + New_Assign_Stmt + (New_Obj (Var_Rl), + New_Convert_Ov (New_Monadic_Op (ON_Neg_Ov, + New_Obj_Value (Var_R)), + Ghdl_Index_Type)); + + Do_Shift (False); + end case; + Finish_If_Stmt (If_Blk); + + if Shift = Rotation then + -- * If I1 = LENGTH then + -- * I1 := 0 + Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I1), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + Init_Var (Var_I1); + Finish_If_Stmt (If_Blk); + + -- * for I = 0 to LENGTH - 1 loop + -- * RES[I] := L[I1]; + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + New_Assign_Stmt + (New_Indexed_Acc_Value (New_Obj (Var_Res_Base), + New_Obj_Value (Var_I)), + New_Value + (New_Indexed_Acc_Value (New_Obj (Var_L_Base), + New_Obj_Value (Var_I1)))); + Inc_Var (Var_I); + -- * I1 := I1 + 1 + Inc_Var (Var_I1); + -- * If I1 = LENGTH then + -- * I1 := 0 + Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, + New_Obj_Value (Var_I1), + New_Obj_Value (Var_Length), + Ghdl_Bool_Type)); + Init_Var (Var_I1); + Finish_If_Stmt (If_Blk); + Finish_Loop_Stmt (Label); + end if; + Finish_Subprogram_Body; + end Translate_Predefined_Array_Shift; + + procedure Translate_File_Subprogram (Subprg : Iir; File_Type : Iir) + is + Etype : Iir; + Tinfo : Type_Info_Acc; + Kind : Iir_Predefined_Functions; + F_Info : Subprg_Info_Acc; + Name : O_Ident; + Inter_List : O_Inter_List; + Id : Name_Id; + Var_File : O_Dnode; + Var_Val : O_Dnode; + + procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode); + + procedure Translate_Rw_Array + (Val : Mnode; Val_Type : Iir; Var_Max : O_Dnode; Proc : O_Dnode) + is + Var_It : O_Dnode; + Label : O_Snode; + begin + Var_It := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_It); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_It), + New_Obj_Value (Var_Max), + Ghdl_Bool_Type)); + Translate_Rw + (Chap3.Index_Base (Val, Val_Type, New_Obj_Value (Var_It)), + Get_Element_Subtype (Val_Type), Proc); + Inc_Var (Var_It); + Finish_Loop_Stmt (Label); + end Translate_Rw_Array; + + procedure Translate_Rw (Val : Mnode; Val_Type : Iir; Proc : O_Dnode) + is + Val_Info : Type_Info_Acc; + Assocs : O_Assoc_List; + begin + Val_Info := Get_Type_Info (Val); + case Val_Info.Type_Mode is + when Type_Mode_Scalar => + Start_Association (Assocs, Proc); + -- compute file parameter (get an index) + New_Association (Assocs, New_Obj_Value (Var_File)); + -- compute the value. + New_Association + (Assocs, New_Convert_Ov (M2Addr (Val), Ghdl_Ptr_Type)); + -- length. + New_Association + (Assocs, + New_Lit (New_Sizeof (Val_Info.Ortho_Type (Mode_Value), + Ghdl_Index_Type))); + -- call a predefined procedure + New_Procedure_Call (Assocs); + when Type_Mode_Record => + declare + El_List : Iir_List; + El : Iir; + Val1 : Mnode; + begin + Open_Temp; + Val1 := Stabilize (Val); + El_List := Get_Elements_Declaration_List + (Get_Base_Type (Val_Type)); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + Translate_Rw + (Chap6.Translate_Selected_Element (Val1, El), + Get_Type (El), Proc); + end loop; + Close_Temp; + end; + when Type_Mode_Array => + declare + Var_Max : O_Dnode; + begin + Open_Temp; + Var_Max := Create_Temp (Ghdl_Index_Type); + New_Assign_Stmt + (New_Obj (Var_Max), + Chap3.Get_Array_Type_Length (Val_Type)); + Translate_Rw_Array (Val, Val_Type, Var_Max, Proc); + Close_Temp; + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Fat_Array + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Rw; + + procedure Translate_Rw_Length (Var_Length : O_Dnode; Proc : O_Dnode) + is + Assocs : O_Assoc_List; + begin + Start_Association (Assocs, Proc); + New_Association (Assocs, New_Obj_Value (Var_File)); + New_Association + (Assocs, New_Unchecked_Address (New_Obj (Var_Length), + Ghdl_Ptr_Type)); + New_Association + (Assocs, + New_Lit (New_Sizeof (Ghdl_Index_Type, Ghdl_Index_Type))); + New_Procedure_Call (Assocs); + end Translate_Rw_Length; + + Var : Mnode; + begin + Etype := Get_Type (Get_File_Type_Mark (File_Type)); + Tinfo := Get_Info (Etype); + if Tinfo.Type_Mode in Type_Mode_Scalar then + -- Intrinsic. + return; + end if; + + F_Info := Add_Info (Subprg, Kind_Subprg); + --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); + F_Info.Use_Stack2 := False; + + Id := Get_Identifier (Get_Type_Declarator (File_Type)); + Kind := Get_Implicit_Definition (Subprg); + case Kind is + when Iir_Predefined_Write => + Name := Create_Identifier (Id, "_WRITE"); + when Iir_Predefined_Read + | Iir_Predefined_Read_Length => + Name := Create_Identifier (Id, "_READ"); + when others => + raise Internal_Error; + end case; + + -- Create function. + if Kind = Iir_Predefined_Read_Length then + Start_Function_Decl + (Inter_List, Name, Global_Storage, Std_Integer_Otype); + else + Start_Procedure_Decl (Inter_List, Name, Global_Storage); + end if; + Chap2.Create_Subprg_Instance (Inter_List, Subprg); + + New_Interface_Decl + (Inter_List, Var_File, Get_Identifier ("FILE"), + Ghdl_File_Index_Type); + New_Interface_Decl + (Inter_List, Var_Val, Wki_Val, + Tinfo.Ortho_Ptr_Type (Mode_Value)); + Finish_Subprogram_Decl (Inter_List, F_Info.Ortho_Func); + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Subprogram_Body (F_Info.Ortho_Func); + Chap2.Start_Subprg_Instance_Use (Subprg); + Push_Local_Factory; + + Var := Dp2M (Var_Val, Tinfo, Mode_Value); + + case Kind is + when Iir_Predefined_Write => + if Tinfo.Type_Mode = Type_Mode_Fat_Array then + declare + Var_Max : O_Dnode; + begin + Open_Temp; + Var_Max := Create_Temp_Init + (Ghdl_Index_Type, + Chap3.Get_Array_Length (Var, Etype)); + Translate_Rw_Length (Var_Max, Ghdl_Write_Scalar); + Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype, + Var_Max, Ghdl_Write_Scalar); + Close_Temp; + end; + else + Translate_Rw (Var, Etype, Ghdl_Write_Scalar); + end if; + when Iir_Predefined_Read => + Translate_Rw (Var, Etype, Ghdl_Read_Scalar); + + when Iir_Predefined_Read_Length => + declare + Var_Len : O_Dnode; + begin + Open_Temp; + Var_Len := Create_Temp (Ghdl_Index_Type); + Translate_Rw_Length (Var_Len, Ghdl_Read_Scalar); + + Chap6.Check_Bound_Error + (New_Compare_Op (ON_Gt, + New_Obj_Value (Var_Len), + Chap3.Get_Array_Length (Var, Etype), + Ghdl_Bool_Type), + Subprg, 1); + Translate_Rw_Array (Chap3.Get_Array_Base (Var), Etype, + Var_Len, Ghdl_Read_Scalar); + New_Return_Stmt (New_Convert_Ov (New_Obj_Value (Var_Len), + Std_Integer_Otype)); + Close_Temp; + end; + when others => + raise Internal_Error; + end case; + Chap2.Finish_Subprg_Instance_Use (Subprg); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_File_Subprogram; + + procedure Init_Implicit_Subprogram_Infos + (Infos : out Implicit_Subprogram_Infos) is + begin + -- Be independant of declaration order since the same subprogram + -- may be used for several implicit operators (eg. array comparaison) + Infos.Arr_Eq_Info := null; + Infos.Arr_Cmp_Info := null; + Infos.Arr_Concat_Info := null; + Infos.Rec_Eq_Info := null; + Infos.Arr_Shl_Info := null; + Infos.Arr_Sha_Info := null; + Infos.Arr_Rot_Info := null; + end Init_Implicit_Subprogram_Infos; + + procedure Translate_Implicit_Subprogram + (Subprg : Iir; Infos : in out Implicit_Subprogram_Infos) + is + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Subprg); + begin + if Predefined_To_Onop (Kind) /= ON_Nil then + -- Intrinsic. + return; + end if; + + case Kind is + when Iir_Predefined_Error => + raise Internal_Error; + when Iir_Predefined_Boolean_And + | Iir_Predefined_Boolean_Or + | Iir_Predefined_Boolean_Xor + | Iir_Predefined_Boolean_Not + | Iir_Predefined_Enum_Equality + | Iir_Predefined_Enum_Inequality + | Iir_Predefined_Enum_Less + | Iir_Predefined_Enum_Less_Equal + | Iir_Predefined_Enum_Greater + | Iir_Predefined_Enum_Greater_Equal + | Iir_Predefined_Bit_And + | Iir_Predefined_Bit_Or + | Iir_Predefined_Bit_Xor + | Iir_Predefined_Bit_Not + | Iir_Predefined_Integer_Equality + | Iir_Predefined_Integer_Inequality + | Iir_Predefined_Integer_Less + | Iir_Predefined_Integer_Less_Equal + | Iir_Predefined_Integer_Greater + | Iir_Predefined_Integer_Greater_Equal + | Iir_Predefined_Integer_Negation + | Iir_Predefined_Integer_Absolute + | Iir_Predefined_Integer_Plus + | Iir_Predefined_Integer_Minus + | Iir_Predefined_Integer_Mul + | Iir_Predefined_Integer_Div + | Iir_Predefined_Integer_Mod + | Iir_Predefined_Integer_Rem + | Iir_Predefined_Floating_Equality + | Iir_Predefined_Floating_Inequality + | Iir_Predefined_Floating_Less + | Iir_Predefined_Floating_Less_Equal + | Iir_Predefined_Floating_Greater + | Iir_Predefined_Floating_Greater_Equal + | Iir_Predefined_Floating_Negation + | Iir_Predefined_Floating_Absolute + | Iir_Predefined_Floating_Plus + | Iir_Predefined_Floating_Minus + | Iir_Predefined_Floating_Mul + | Iir_Predefined_Floating_Div + | Iir_Predefined_Physical_Equality + | Iir_Predefined_Physical_Inequality + | Iir_Predefined_Physical_Less + | Iir_Predefined_Physical_Less_Equal + | Iir_Predefined_Physical_Greater + | Iir_Predefined_Physical_Greater_Equal + | Iir_Predefined_Physical_Negation + | Iir_Predefined_Physical_Absolute + | Iir_Predefined_Physical_Plus + | Iir_Predefined_Physical_Minus => + pragma Assert (Predefined_To_Onop (Kind) /= ON_Nil); + return; + + when Iir_Predefined_Boolean_Nand + | Iir_Predefined_Boolean_Nor + | Iir_Predefined_Boolean_Xnor + | Iir_Predefined_Bit_Nand + | Iir_Predefined_Bit_Nor + | Iir_Predefined_Bit_Xnor + | Iir_Predefined_Bit_Match_Equality + | Iir_Predefined_Bit_Match_Inequality + | Iir_Predefined_Bit_Match_Less + | Iir_Predefined_Bit_Match_Less_Equal + | Iir_Predefined_Bit_Match_Greater + | Iir_Predefined_Bit_Match_Greater_Equal + | Iir_Predefined_Bit_Condition + | Iir_Predefined_Boolean_Rising_Edge + | Iir_Predefined_Boolean_Falling_Edge + | Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Bit_Falling_Edge => + -- Intrinsic. + null; + + when Iir_Predefined_Enum_Minimum + | Iir_Predefined_Enum_Maximum + | Iir_Predefined_Enum_To_String => + -- Intrinsic. + null; + + when Iir_Predefined_Integer_Identity + | Iir_Predefined_Integer_Exp + | Iir_Predefined_Integer_Minimum + | Iir_Predefined_Integer_Maximum + | Iir_Predefined_Integer_To_String => + -- Intrinsic. + null; + when Iir_Predefined_Universal_R_I_Mul + | Iir_Predefined_Universal_I_R_Mul + | Iir_Predefined_Universal_R_I_Div => + -- Intrinsic + null; + + when Iir_Predefined_Physical_Identity + | Iir_Predefined_Physical_Minimum + | Iir_Predefined_Physical_Maximum + | Iir_Predefined_Physical_To_String + | Iir_Predefined_Time_To_String_Unit => + null; + + when Iir_Predefined_Physical_Integer_Mul + | Iir_Predefined_Physical_Integer_Div + | Iir_Predefined_Integer_Physical_Mul + | Iir_Predefined_Physical_Real_Mul + | Iir_Predefined_Physical_Real_Div + | Iir_Predefined_Real_Physical_Mul + | Iir_Predefined_Physical_Physical_Div => + null; + + when Iir_Predefined_Floating_Exp + | Iir_Predefined_Floating_Identity + | Iir_Predefined_Floating_Minimum + | Iir_Predefined_Floating_Maximum + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Real_To_String_Digits + | Iir_Predefined_Real_To_String_Format => + null; + + when Iir_Predefined_Record_Equality + | Iir_Predefined_Record_Inequality => + if Infos.Rec_Eq_Info = null then + Translate_Predefined_Record_Equality (Subprg); + Infos.Rec_Eq_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Rec_Eq_Info); + end if; + + when Iir_Predefined_Array_Equality + | Iir_Predefined_Array_Inequality + | Iir_Predefined_Bit_Array_Match_Equality + | Iir_Predefined_Bit_Array_Match_Inequality => + if Infos.Arr_Eq_Info = null then + Translate_Predefined_Array_Equality (Subprg); + Infos.Arr_Eq_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Eq_Info); + end if; + + when Iir_Predefined_Array_Greater + | Iir_Predefined_Array_Greater_Equal + | Iir_Predefined_Array_Less + | Iir_Predefined_Array_Less_Equal + | Iir_Predefined_Array_Minimum + | Iir_Predefined_Array_Maximum => + if Infos.Arr_Cmp_Info = null then + Translate_Predefined_Array_Compare (Subprg); + Infos.Arr_Cmp_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Cmp_Info); + end if; + + when Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + if Infos.Arr_Concat_Info = null then + Translate_Predefined_Array_Array_Concat (Subprg); + Infos.Arr_Concat_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Concat_Info); + end if; + + when Iir_Predefined_Vector_Minimum + | Iir_Predefined_Vector_Maximum => + null; + + when Iir_Predefined_TF_Array_And + | Iir_Predefined_TF_Array_Or + | Iir_Predefined_TF_Array_Nand + | Iir_Predefined_TF_Array_Nor + | Iir_Predefined_TF_Array_Xor + | Iir_Predefined_TF_Array_Xnor + | Iir_Predefined_TF_Array_Not => + Translate_Predefined_Array_Logical (Subprg); + + when Iir_Predefined_TF_Reduction_And + | Iir_Predefined_TF_Reduction_Or + | Iir_Predefined_TF_Reduction_Nand + | Iir_Predefined_TF_Reduction_Nor + | Iir_Predefined_TF_Reduction_Xor + | Iir_Predefined_TF_Reduction_Xnor + | Iir_Predefined_TF_Reduction_Not + | Iir_Predefined_TF_Array_Element_And + | Iir_Predefined_TF_Element_Array_And + | Iir_Predefined_TF_Array_Element_Or + | Iir_Predefined_TF_Element_Array_Or + | Iir_Predefined_TF_Array_Element_Nand + | Iir_Predefined_TF_Element_Array_Nand + | Iir_Predefined_TF_Array_Element_Nor + | Iir_Predefined_TF_Element_Array_Nor + | Iir_Predefined_TF_Array_Element_Xor + | Iir_Predefined_TF_Element_Array_Xor + | Iir_Predefined_TF_Array_Element_Xnor + | Iir_Predefined_TF_Element_Array_Xnor => + null; + + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl => + if Infos.Arr_Shl_Info = null then + Translate_Predefined_Array_Shift (Subprg); + Infos.Arr_Shl_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Shl_Info); + end if; + + when Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Infos.Arr_Sha_Info = null then + Translate_Predefined_Array_Shift (Subprg); + Infos.Arr_Sha_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Sha_Info); + end if; + + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + if Infos.Arr_Rot_Info = null then + Translate_Predefined_Array_Shift (Subprg); + Infos.Arr_Rot_Info := Get_Info (Subprg); + else + Set_Info (Subprg, Infos.Arr_Rot_Info); + end if; + + when Iir_Predefined_Access_Equality + | Iir_Predefined_Access_Inequality => + -- Intrinsic. + null; + when Iir_Predefined_Deallocate => + -- Intrinsic. + null; + + when Iir_Predefined_File_Open + | Iir_Predefined_File_Open_Status + | Iir_Predefined_File_Close + | Iir_Predefined_Flush + | Iir_Predefined_Endfile => + -- All of them have predefined definitions. + null; + + when Iir_Predefined_Write + | Iir_Predefined_Read_Length + | Iir_Predefined_Read => + declare + Param : Iir; + File_Type : Iir; + begin + Param := Get_Interface_Declaration_Chain (Subprg); + File_Type := Get_Type (Param); + if not Get_Text_File_Flag (File_Type) then + Translate_File_Subprogram (Subprg, File_Type); + end if; + end; + + when Iir_Predefined_Attribute_Image + | Iir_Predefined_Attribute_Value + | Iir_Predefined_Attribute_Pos + | Iir_Predefined_Attribute_Val + | Iir_Predefined_Attribute_Succ + | Iir_Predefined_Attribute_Pred + | Iir_Predefined_Attribute_Leftof + | Iir_Predefined_Attribute_Rightof + | Iir_Predefined_Attribute_Left + | Iir_Predefined_Attribute_Right + | Iir_Predefined_Attribute_Event + | Iir_Predefined_Attribute_Active + | Iir_Predefined_Attribute_Last_Event + | Iir_Predefined_Attribute_Last_Active + | Iir_Predefined_Attribute_Last_Value + | Iir_Predefined_Attribute_Driving + | Iir_Predefined_Attribute_Driving_Value => + raise Internal_Error; + + when Iir_Predefined_Array_Char_To_String + | Iir_Predefined_Bit_Vector_To_Ostring + | Iir_Predefined_Bit_Vector_To_Hstring + | Iir_Predefined_Std_Ulogic_Match_Equality + | Iir_Predefined_Std_Ulogic_Match_Inequality + | Iir_Predefined_Std_Ulogic_Match_Less + | Iir_Predefined_Std_Ulogic_Match_Less_Equal + | Iir_Predefined_Std_Ulogic_Match_Greater + | Iir_Predefined_Std_Ulogic_Match_Greater_Equal + | Iir_Predefined_Std_Ulogic_Array_Match_Equality + | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + null; + + when Iir_Predefined_Now_Function => + null; + + -- when others => + -- Error_Kind ("translate_implicit_subprogram (" + -- & Iir_Predefined_Functions'Image (Kind) & ")", + -- Subprg); + end case; + end Translate_Implicit_Subprogram; + end Chap7; + + package body Chap8 is + procedure Translate_Return_Statement (Stmt : Iir_Return_Statement) + is + Subprg_Info : constant Ortho_Info_Acc := + Get_Info (Chap2.Current_Subprogram); + Expr : constant Iir := Get_Expression (Stmt); + Ret_Type : Iir; + Ret_Info : Type_Info_Acc; + + procedure Gen_Return is + begin + if Subprg_Info.Subprg_Exit /= O_Snode_Null then + New_Exit_Stmt (Subprg_Info.Subprg_Exit); + else + New_Return_Stmt; + end if; + end Gen_Return; + + procedure Gen_Return_Value (Val : O_Enode) is + begin + if Subprg_Info.Subprg_Exit /= O_Snode_Null then + New_Assign_Stmt (New_Obj (Subprg_Info.Subprg_Result), Val); + New_Exit_Stmt (Subprg_Info.Subprg_Exit); + else + New_Return_Stmt (Val); + end if; + end Gen_Return_Value; + begin + if Expr = Null_Iir then + -- Return in a procedure. + Gen_Return; + return; + end if; + + -- Return in a function. + Ret_Type := Get_Return_Type (Chap2.Current_Subprogram); + Ret_Info := Get_Info (Ret_Type); + case Ret_Info.Type_Mode is + when Type_Mode_Scalar => + -- * if the return type is scalar, simply returns. + declare + V : O_Dnode; + R : O_Enode; + begin + -- Always uses a temporary in case of the return expression + -- uses secondary stack. + -- FIXME: don't use the temp if not required. + R := Chap7.Translate_Expression (Expr, Ret_Type); + if Has_Stack2_Mark + or else Chap3.Need_Range_Check (Expr, Ret_Type) + then + V := Create_Temp (Ret_Info.Ortho_Type (Mode_Value)); + New_Assign_Stmt (New_Obj (V), R); + Stack2_Release; + Chap3.Check_Range (V, Expr, Ret_Type, Expr); + Gen_Return_Value (New_Obj_Value (V)); + else + Gen_Return_Value (R); + end if; + end; + when Type_Mode_Acc => + -- * access: thin and no range. + declare + Res : O_Enode; + begin + Res := Chap7.Translate_Expression (Expr, Ret_Type); + Gen_Return_Value (Res); + end; + when Type_Mode_Fat_Array => + -- * if the return type is unconstrained: allocate an area from + -- the secondary stack, copy it to the area, and fill the fat + -- pointer. + -- Evaluate the result. + declare + Val : Mnode; + Area : Mnode; + begin + Area := Dp2M (Subprg_Info.Res_Interface, + Ret_Info, Mode_Value); + Val := Stabilize + (E2M (Chap7.Translate_Expression (Expr, Ret_Type), + Ret_Info, Mode_Value)); + Chap3.Translate_Object_Allocation + (Area, Alloc_Return, Ret_Type, + Chap3.Get_Array_Bounds (Val)); + Chap3.Translate_Object_Copy (Area, M2Addr (Val), Ret_Type); + Gen_Return; + end; + when Type_Mode_Record + | Type_Mode_Array + | Type_Mode_Fat_Acc => + -- * if the return type is a constrained composite type, copy + -- it to the result area. + -- Create a temporary area so that if the expression use + -- stack2, it will be freed before the return (otherwise, + -- the stack area will be lost). + declare + V : Mnode; + begin + Open_Temp; + V := Dp2M (Subprg_Info.Res_Interface, Ret_Info, Mode_Value); + Chap3.Translate_Object_Copy + (V, Chap7.Translate_Expression (Expr, Ret_Type), Ret_Type); + Close_Temp; + Gen_Return; + end; + when Type_Mode_File => + -- FIXME: Is it possible ? + Error_Kind ("translate_return_statement", Ret_Type); + when Type_Mode_Unknown + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Return_Statement; + + procedure Translate_If_Statement (Stmt : Iir) + is + Blk : O_If_Block; + Else_Clause : Iir; + begin + Start_If_Stmt + (Blk, Chap7.Translate_Expression (Get_Condition (Stmt))); + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + Else_Clause := Get_Else_Clause (Stmt); + if Else_Clause /= Null_Iir then + New_Else_Stmt (Blk); + if Get_Condition (Else_Clause) = Null_Iir then + Translate_Statements_Chain + (Get_Sequential_Statement_Chain (Else_Clause)); + else + Open_Temp; + Translate_If_Statement (Else_Clause); + Close_Temp; + end if; + end if; + Finish_If_Stmt (Blk); + end Translate_If_Statement; + + function Get_Range_Ptr_Field_Value (O_Range : O_Lnode; Field : O_Fnode) + return O_Enode + is + begin + return New_Value (New_Selected_Element + (New_Access_Element (New_Value (O_Range)), Field)); + end Get_Range_Ptr_Field_Value; + + -- Inc or dec ITERATOR according to DIR. + procedure Gen_Update_Iterator (Iterator : O_Dnode; + Dir : Iir_Direction; + Val : Unsigned_64; + Itype : Iir) + is + Op : ON_Op_Kind; + Base_Type : Iir; + V : O_Enode; + begin + case Dir is + when Iir_To => + Op := ON_Add_Ov; + when Iir_Downto => + Op := ON_Sub_Ov; + end case; + Base_Type := Get_Base_Type (Itype); + case Get_Kind (Base_Type) is + when Iir_Kind_Integer_Type_Definition => + V := New_Lit + (New_Signed_Literal + (Get_Ortho_Type (Base_Type, Mode_Value), Integer_64 (Val))); + when Iir_Kind_Enumeration_Type_Definition => + declare + List : Iir_List; + begin + List := Get_Enumeration_Literal_List (Base_Type); + -- FIXME: what about type E is ('T') ?? + if Natural (Val) > Get_Nbr_Elements (List) then + raise Internal_Error; + end if; + V := New_Lit + (Get_Ortho_Expr (Get_Nth_Element (List, Natural (Val)))); + end; + + when others => + Error_Kind ("gen_update_iterator", Base_Type); + end case; + New_Assign_Stmt (New_Obj (Iterator), + New_Dyadic_Op (Op, New_Obj_Value (Iterator), V)); + end Gen_Update_Iterator; + + type For_Loop_Data is record + Iterator : Iir_Iterator_Declaration; + Stmt : Iir_For_Loop_Statement; + -- If around the loop, to check if the loop must be executed. + If_Blk : O_If_Block; + Label_Next, Label_Exit : O_Snode; + -- Right bound of the iterator, used only if the iterator is a + -- range expression. + O_Right : O_Dnode; + -- Range variable of the iterator, used only if the iterator is not + -- a range expression. + O_Range : O_Dnode; + end record; + + procedure Start_For_Loop (Iterator : Iir_Iterator_Declaration; + Stmt : Iir_For_Loop_Statement; + Data : out For_Loop_Data) + is + Iter_Type : Iir; + Iter_Base_Type : Iir; + Var_Iter : Var_Type; + Constraint : Iir; + Cond : O_Enode; + Dir : Iir_Direction; + Iter_Type_Info : Ortho_Info_Acc; + Op : ON_Op_Kind; + begin + -- Initialize DATA. + Data.Iterator := Iterator; + Data.Stmt := Stmt; + + Iter_Type := Get_Type (Iterator); + Iter_Base_Type := Get_Base_Type (Iter_Type); + Iter_Type_Info := Get_Info (Iter_Base_Type); + Var_Iter := Get_Info (Iterator).Iterator_Var; + + Open_Temp; + + Constraint := Get_Range_Constraint (Iter_Type); + if Get_Kind (Constraint) = Iir_Kind_Range_Expression then + New_Assign_Stmt + (Get_Var (Var_Iter), Chap7.Translate_Range_Expression_Left + (Constraint, Iter_Base_Type)); + Dir := Get_Direction (Constraint); + Data.O_Right := Create_Temp + (Iter_Type_Info.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Obj (Data.O_Right), Chap7.Translate_Range_Expression_Right + (Constraint, Iter_Base_Type)); + case Dir is + when Iir_To => + Op := ON_Le; + when Iir_Downto => + Op := ON_Ge; + end case; + -- Check for at least one iteration. + Cond := New_Compare_Op + (Op, New_Value (Get_Var (Var_Iter)), + New_Obj_Value (Data.O_Right), + Ghdl_Bool_Type); + else + Data.O_Range := Create_Temp (Iter_Type_Info.T.Range_Ptr_Type); + New_Assign_Stmt (New_Obj (Data.O_Range), + New_Address (Chap7.Translate_Range + (Constraint, Iter_Base_Type), + Iter_Type_Info.T.Range_Ptr_Type)); + New_Assign_Stmt + (Get_Var (Var_Iter), Get_Range_Ptr_Field_Value + (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Left)); + -- Before starting the loop, check wether there will be at least + -- one iteration. + Cond := New_Compare_Op + (ON_Gt, + Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), + Iter_Type_Info.T.Range_Length), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type); + end if; + + Start_If_Stmt (Data.If_Blk, Cond); + + -- Start loop. + -- There are two blocks: one for the exit, one for the next. + Start_Loop_Stmt (Data.Label_Exit); + Start_Loop_Stmt (Data.Label_Next); + + if Stmt /= Null_Iir then + declare + Loop_Info : Loop_Info_Acc; + begin + Loop_Info := Add_Info (Stmt, Kind_Loop); + Loop_Info.Label_Exit := Data.Label_Exit; + Loop_Info.Label_Next := Data.Label_Next; + end; + end if; + end Start_For_Loop; + + procedure Finish_For_Loop (Data : in out For_Loop_Data) + is + Cond : O_Enode; + If_Blk1 : O_If_Block; + Iter_Type : Iir; + Iter_Base_Type : Iir; + Iter_Type_Info : Type_Info_Acc; + Var_Iter : Var_Type; + Constraint : Iir; + Deep_Rng : Iir; + Deep_Reverse : Boolean; + begin + New_Exit_Stmt (Data.Label_Next); + Finish_Loop_Stmt (Data.Label_Next); + + -- Check end of loop. + -- Equality is necessary and enough. + Iter_Type := Get_Type (Data.Iterator); + Iter_Base_Type := Get_Base_Type (Iter_Type); + Iter_Type_Info := Get_Info (Iter_Base_Type); + Var_Iter := Get_Info (Data.Iterator).Iterator_Var; + + Constraint := Get_Range_Constraint (Iter_Type); + + if Get_Kind (Constraint) = Iir_Kind_Range_Expression then + Cond := New_Obj_Value (Data.O_Right); + else + Cond := Get_Range_Ptr_Field_Value + (New_Obj (Data.O_Range), Iter_Type_Info.T.Range_Right); + end if; + Gen_Exit_When (Data.Label_Exit, + New_Compare_Op (ON_Eq, New_Value (Get_Var (Var_Iter)), + Cond, Ghdl_Bool_Type)); + + -- Update the iterator. + Chap6.Get_Deep_Range_Expression (Iter_Type, Deep_Rng, Deep_Reverse); + if Deep_Rng /= Null_Iir then + if Get_Direction (Deep_Rng) = Iir_To xor Deep_Reverse then + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); + else + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); + end if; + else + Start_If_Stmt + (If_Blk1, New_Compare_Op + (ON_Eq, + Get_Range_Ptr_Field_Value (New_Obj (Data.O_Range), + Iter_Type_Info.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_To, 1, Iter_Base_Type); + New_Else_Stmt (If_Blk1); + Gen_Update_Iterator + (Get_Var_Label (Var_Iter), Iir_Downto, 1, Iter_Base_Type); + Finish_If_Stmt (If_Blk1); + end if; + + Finish_Loop_Stmt (Data.Label_Exit); + Finish_If_Stmt (Data.If_Blk); + Close_Temp; + + if Data.Stmt /= Null_Iir then + Free_Info (Data.Stmt); + end if; + end Finish_For_Loop; + + Current_Loop : Iir := Null_Iir; + + procedure Translate_For_Loop_Statement (Stmt : Iir_For_Loop_Statement) + is + Iterator : constant Iir := Get_Parameter_Specification (Stmt); + Iter_Type : constant Iir := Get_Type (Iterator); + Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); + Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); + Data : For_Loop_Data; + It_Info : Ortho_Info_Acc; + Var_Iter : Var_Type; + Prev_Loop : Iir; + begin + Prev_Loop := Current_Loop; + Current_Loop := Stmt; + Start_Declare_Stmt; + + Chap3.Translate_Object_Subtype (Iterator, False); + + -- Create info for the iterator. + It_Info := Add_Info (Iterator, Kind_Iterator); + Var_Iter := Create_Var + (Create_Var_Identifier (Iterator), + Iter_Type_Info.Ortho_Type (Mode_Value), + O_Storage_Local); + It_Info.Iterator_Var := Var_Iter; + + Start_For_Loop (Iterator, Stmt, Data); + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + Finish_For_Loop (Data); + + Finish_Declare_Stmt; + + Free_Info (Iterator); + Current_Loop := Prev_Loop; + end Translate_For_Loop_Statement; + + procedure Translate_While_Loop_Statement + (Stmt : Iir_While_Loop_Statement) + is + Info : Loop_Info_Acc; + Cond : Iir; + Prev_Loop : Iir; + begin + Prev_Loop := Current_Loop; + Current_Loop := Stmt; + + Info := Add_Info (Stmt, Kind_Loop); + + Start_Loop_Stmt (Info.Label_Exit); + Info.Label_Next := O_Snode_Null; + + Open_Temp; + Cond := Get_Condition (Stmt); + if Cond /= Null_Iir then + Gen_Exit_When + (Info.Label_Exit, + New_Monadic_Op (ON_Not, Chap7.Translate_Expression (Cond))); + end if; + Close_Temp; + + Translate_Statements_Chain (Get_Sequential_Statement_Chain (Stmt)); + + Finish_Loop_Stmt (Info.Label_Exit); + Free_Info (Stmt); + Current_Loop := Prev_Loop; + end Translate_While_Loop_Statement; + + procedure Translate_Exit_Next_Statement (Stmt : Iir) + is + Cond : constant Iir := Get_Condition (Stmt); + If_Blk : O_If_Block; + Info : Loop_Info_Acc; + Loop_Label : Iir; + Loop_Stmt : Iir; + begin + if Cond /= Null_Iir then + Start_If_Stmt (If_Blk, Chap7.Translate_Expression (Cond)); + end if; + + Loop_Label := Get_Loop_Label (Stmt); + if Loop_Label = Null_Iir then + Loop_Stmt := Current_Loop; + else + Loop_Stmt := Get_Named_Entity (Loop_Label); + end if; + + Info := Get_Info (Loop_Stmt); + case Get_Kind (Stmt) is + when Iir_Kind_Exit_Statement => + New_Exit_Stmt (Info.Label_Exit); + when Iir_Kind_Next_Statement => + if Info.Label_Next /= O_Snode_Null then + -- For-loop. + New_Exit_Stmt (Info.Label_Next); + else + -- While-loop. + New_Next_Stmt (Info.Label_Exit); + end if; + when others => + raise Internal_Error; + end case; + if Cond /= Null_Iir then + Finish_If_Stmt (If_Blk); + end if; + end Translate_Exit_Next_Statement; + + procedure Translate_Variable_Aggregate_Assignment + (Targ : Iir; Targ_Type : Iir; Val : Mnode); + + procedure Translate_Variable_Array_Aggr + (Targ : Iir_Aggregate; + Targ_Type : Iir; + Val : Mnode; + Index : in out Unsigned_64; + Dim : Natural) + is + El : Iir; + Final : Boolean; + El_Type : Iir; + begin + Final := Dim = Get_Nbr_Elements (Get_Index_Subtype_List (Targ_Type)); + if Final then + El_Type := Get_Element_Subtype (Targ_Type); + end if; + El := Get_Association_Choices_Chain (Targ); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + if Final then + Translate_Variable_Aggregate_Assignment + (Get_Associated_Expr (El), El_Type, + Chap3.Index_Base + (Val, Targ_Type, + New_Lit (New_Unsigned_Literal + (Ghdl_Index_Type, Index)))); + Index := Index + 1; + else + Translate_Variable_Array_Aggr + (Get_Associated_Expr (El), + Targ_Type, Val, Index, Dim + 1); + end if; + when others => + Error_Kind ("translate_variable_array_aggr", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Variable_Array_Aggr; + + procedure Translate_Variable_Rec_Aggr + (Targ : Iir_Aggregate; Targ_Type : Iir; Val : Mnode) + is + Aggr_El : Iir; + El_List : Iir_List; + El_Index : Natural; + Elem : Iir; + begin + El_List := Get_Elements_Declaration_List (Get_Base_Type (Targ_Type)); + El_Index := 0; + Aggr_El := Get_Association_Choices_Chain (Targ); + while Aggr_El /= Null_Iir loop + case Get_Kind (Aggr_El) is + when Iir_Kind_Choice_By_None => + Elem := Get_Nth_Element (El_List, El_Index); + El_Index := El_Index + 1; + when Iir_Kind_Choice_By_Name => + Elem := Get_Choice_Name (Aggr_El); + when others => + Error_Kind ("translate_variable_rec_aggr", Aggr_El); + end case; + Translate_Variable_Aggregate_Assignment + (Get_Associated_Expr (Aggr_El), Get_Type (Elem), + Chap6.Translate_Selected_Element (Val, Elem)); + Aggr_El := Get_Chain (Aggr_El); + end loop; + end Translate_Variable_Rec_Aggr; + + procedure Translate_Variable_Aggregate_Assignment + (Targ : Iir; Targ_Type : Iir; Val : Mnode) + is + Index : Unsigned_64; + begin + if Get_Kind (Targ) = Iir_Kind_Aggregate then + case Get_Kind (Targ_Type) is + when Iir_Kinds_Array_Type_Definition => + Index := 0; + Translate_Variable_Array_Aggr + (Targ, Targ_Type, Val, Index, 1); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Translate_Variable_Rec_Aggr (Targ, Targ_Type, Val); + when others => + Error_Kind + ("translate_variable_aggregate_assignment", Targ_Type); + end case; + else + declare + Targ_Node : Mnode; + begin + Targ_Node := Chap6.Translate_Name (Targ); + Chap3.Translate_Object_Copy (Targ_Node, M2E (Val), Targ_Type); + end; + end if; + end Translate_Variable_Aggregate_Assignment; + + procedure Translate_Variable_Assignment_Statement + (Stmt : Iir_Variable_Assignment_Statement) + is + Target : constant Iir := Get_Target (Stmt); + Targ_Type : constant Iir := Get_Type (Target); + Expr : constant Iir := Get_Expression (Stmt); + Targ_Node : Mnode; + begin + if Get_Kind (Target) = Iir_Kind_Aggregate then + declare + E : O_Enode; + Temp : Mnode; + begin + Chap3.Translate_Anonymous_Type_Definition (Targ_Type, True); + + -- Use a temporary variable, to avoid overlap. + Temp := Create_Temp (Get_Info (Targ_Type)); + Chap4.Allocate_Complex_Object (Targ_Type, Alloc_Stack, Temp); + + E := Chap7.Translate_Expression (Expr, Targ_Type); + Chap3.Translate_Object_Copy (Temp, E, Targ_Type); + Translate_Variable_Aggregate_Assignment + (Target, Targ_Type, Temp); + return; + end; + else + Targ_Node := Chap6.Translate_Name (Target); + if Get_Kind (Expr) = Iir_Kind_Aggregate then + declare + E : O_Enode; + begin + E := Chap7.Translate_Expression (Expr, Targ_Type); + Chap3.Translate_Object_Copy (Targ_Node, E, Targ_Type); + end; + else + Chap7.Translate_Assign (Targ_Node, Expr, Targ_Type); + end if; + end if; + end Translate_Variable_Assignment_Statement; + + procedure Translate_Report (Stmt : Iir; Subprg : O_Dnode; Level : Iir) + is + Expr : Iir; + Msg : O_Enode; + Severity : O_Enode; + Assocs : O_Assoc_List; + Loc : O_Dnode; + begin + Loc := Chap4.Get_Location (Stmt); + Expr := Get_Report_Expression (Stmt); + if Expr = Null_Iir then + Msg := New_Lit (New_Null_Access (Std_String_Ptr_Node)); + else + Msg := Chap7.Translate_Expression (Expr, String_Type_Definition); + end if; + Expr := Get_Severity_Expression (Stmt); + if Expr = Null_Iir then + Severity := New_Lit (Get_Ortho_Expr (Level)); + else + Severity := Chap7.Translate_Expression (Expr); + end if; + -- Do call. + Start_Association (Assocs, Subprg); + New_Association (Assocs, Msg); + New_Association (Assocs, Severity); + New_Association (Assocs, New_Address (New_Obj (Loc), + Ghdl_Location_Ptr_Node)); + New_Procedure_Call (Assocs); + end Translate_Report; + + -- Return True if the current library unit is part of library IEEE. + function Is_Within_Ieee_Library return Boolean + is + Design_File : Iir; + Library : Iir; + begin + -- Guard. + if Current_Library_Unit = Null_Iir then + return False; + end if; + Design_File := + Get_Design_File (Get_Design_Unit (Current_Library_Unit)); + Library := Get_Library (Design_File); + return Get_Identifier (Library) = Std_Names.Name_Ieee; + end Is_Within_Ieee_Library; + + procedure Translate_Assertion_Statement (Stmt : Iir_Assertion_Statement) + is + Expr : Iir; + If_Blk : O_If_Block; + Subprg : O_Dnode; + begin + -- Select the procedure to call in case of assertion (so that + -- assertions within the IEEE library could be ignored). + if Is_Within_Ieee_Library then + Subprg := Ghdl_Ieee_Assert_Failed; + else + Subprg := Ghdl_Assert_Failed; + end if; + + Expr := Get_Assertion_Condition (Stmt); + if Get_Expr_Staticness (Expr) = Locally then + if Eval_Pos (Expr) = 1 then + -- Assert TRUE is a noop. + -- FIXME: generate a noop ? + return; + end if; + Translate_Report (Stmt, Subprg, Severity_Level_Error); + else + -- An assertion is reported if the condition is false! + Start_If_Stmt (If_Blk, + New_Monadic_Op (ON_Not, + Chap7.Translate_Expression (Expr))); + -- Note: it is necessary to create a declare block, to avoid bad + -- order with the if block. + Open_Temp; + Translate_Report (Stmt, Subprg, Severity_Level_Error); + Close_Temp; + Finish_If_Stmt (If_Blk); + end if; + end Translate_Assertion_Statement; + + procedure Translate_Report_Statement (Stmt : Iir_Report_Statement) is + begin + 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 : O_Enode; + Val_Node : O_Dnode; + Tinfo : Type_Info_Acc; + Func : Iir) + return O_Enode + is + Assoc : O_Assoc_List; + Func_Info : Subprg_Info_Acc; + begin + New_Assign_Stmt + (New_Selected_Element (New_Obj (Val_Node), + Tinfo.T.Base_Field (Mode_Value)), + Val); + Func_Info := Get_Info (Func); + Start_Association (Assoc, Func_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc (Assoc, Func_Info.Subprg_Instance); + New_Association (Assoc, New_Obj_Value (Expr)); + New_Association + (Assoc, New_Address (New_Obj (Val_Node), + Tinfo.Ortho_Ptr_Type (Mode_Value))); + return New_Function_Call (Assoc); + end Translate_Simple_String_Choice; + + -- 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; + + -- 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 + Choices_Chain := Get_Case_Statement_Alternative_Chain (Stmt); + + -- 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 => + Has_Others := True; + exit; + when Iir_Kind_Choice_By_Expression => + null; + when others => + raise Internal_Error; + end case; + if not Get_Same_Alternative_Flag (Choice) then + Nbr_Assocs := Nbr_Assocs + 1; + end if; + 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_Choice_Expression (Choice); + + Nbr_Choices := Nbr_Choices + 1; + Choice := Get_Chain (Choice); + end loop; + + -- 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_Chain (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_Chain (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. + -- Translate into if/elsif statements (linear search). + procedure Translate_String_Case_Statement_Linear + (Stmt : Iir_Case_Statement) + is + Expr_Type : Iir; + -- Node containing the address of the selector. + Expr_Node : O_Dnode; + -- Node containing the current choice. + Val_Node : O_Dnode; + Tinfo : Type_Info_Acc; + + Cond_Var : O_Dnode; + + Func : Iir; + + 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_Chain (Choice); + Ch := Choice; + loop + case Get_Kind (Ch) is + when Iir_Kind_Choice_By_Expression => + Ch_Expr := Get_Choice_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_Chain (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 + (Get_Base_Type (Expr_Type), Iir_Predefined_Array_Equality); + + 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) + is + Expr : Iir; + begin + case Get_Kind (Choice) is + when Iir_Kind_Choice_By_Others => + New_Default_Choice (Blk); + when Iir_Kind_Choice_By_Expression => + Expr := Get_Choice_Expression (Choice); + New_Expr_Choice + (Blk, Chap7.Translate_Static_Expression (Expr, Choice_Type)); + when Iir_Kind_Choice_By_Range => + declare + H, L : Iir; + begin + Expr := Get_Choice_Range (Choice); + Get_Low_High_Limit (Expr, L, H); + New_Range_Choice + (Blk, + Chap7.Translate_Static_Expression (L, Choice_Type), + Chap7.Translate_Static_Expression (H, Choice_Type)); + end; + when others => + Error_Kind ("translate_case_choice", Choice); + end case; + end Translate_Case_Choice; + + procedure Translate_Case_Statement (Stmt : Iir_Case_Statement) + is + Expr : Iir; + Expr_Type : Iir; + Case_Blk : O_Case_Block; + Choice : Iir; + Stmt_Chain : Iir; + begin + Expr := Get_Expression (Stmt); + Expr_Type := Get_Type (Expr); + if Get_Kind (Expr_Type) = Iir_Kind_Array_Subtype_Definition then + 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)); + Choice := Get_Case_Statement_Alternative_Chain (Stmt); + while Choice /= Null_Iir loop + Start_Choice (Case_Blk); + Stmt_Chain := Get_Associated_Chain (Choice); + loop + Translate_Case_Choice (Choice, Expr_Type, Case_Blk); + Choice := Get_Chain (Choice); + exit when Choice = Null_Iir; + exit when not Get_Same_Alternative_Flag (Choice); + pragma Assert (Get_Associated_Chain (Choice) = Null_Iir); + end loop; + Finish_Choice (Case_Blk); + Translate_Statements_Chain (Stmt_Chain); + end loop; + Finish_Case_Stmt (Case_Blk); + end Translate_Case_Statement; + + procedure Translate_Write_Procedure_Call (Imp : Iir; Param_Chain : Iir) + is + F_Assoc : Iir; + Value_Assoc : Iir; + Value : O_Dnode; + Formal_Type : Iir; + Tinfo : Type_Info_Acc; + Assocs : O_Assoc_List; + Subprg_Info : Subprg_Info_Acc; + begin + F_Assoc := Param_Chain; + Value_Assoc := Get_Chain (Param_Chain); + Formal_Type := Get_Type (Get_Formal (Value_Assoc)); + Tinfo := Get_Info (Formal_Type); + case Tinfo.Type_Mode is + when Type_Mode_Scalar => + Open_Temp; + Start_Association (Assocs, Ghdl_Write_Scalar); + -- compute file parameter (get an index) + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + -- compute the value. + Value := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); + New_Assign_Stmt + (New_Obj (Value), + Chap7.Translate_Expression (Get_Actual (Value_Assoc), + Formal_Type)); + New_Association + (Assocs, + New_Unchecked_Address (New_Obj (Value), Ghdl_Ptr_Type)); + -- length. + New_Association + (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), + Ghdl_Index_Type))); + -- call a predefined procedure + New_Procedure_Call (Assocs); + Close_Temp; + when Type_Mode_Array + | Type_Mode_Record + | Type_Mode_Fat_Array => + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc), + Formal_Type)); + New_Procedure_Call (Assocs); + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Write_Procedure_Call; + + procedure Translate_Read_Procedure_Call (Imp : Iir; Param_Chain : Iir) + is + F_Assoc : Iir; + Value_Assoc : Iir; + Value : Mnode; + Formal_Type : Iir; + Tinfo : Type_Info_Acc; + Assocs : O_Assoc_List; + Subprg_Info : Subprg_Info_Acc; + begin + F_Assoc := Param_Chain; + Value_Assoc := Get_Chain (Param_Chain); + Formal_Type := Get_Type (Get_Formal (Value_Assoc)); + Tinfo := Get_Info (Formal_Type); + case Tinfo.Type_Mode is + when Type_Mode_Scalar => + Open_Temp; + Start_Association (Assocs, Ghdl_Read_Scalar); + -- compute file parameter (get an index) + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + -- value + Value := Chap6.Translate_Name (Get_Actual (Value_Assoc)); + New_Association + (Assocs, New_Convert_Ov (M2Addr (Value), Ghdl_Ptr_Type)); + -- length. + New_Association + (Assocs, New_Lit (New_Sizeof (Tinfo.Ortho_Type (Mode_Value), + Ghdl_Index_Type))); + -- call a predefined procedure + New_Procedure_Call (Assocs); + Close_Temp; + when Type_Mode_Array + | Type_Mode_Record => + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc))); + New_Procedure_Call (Assocs); + when Type_Mode_Fat_Array => + declare + Length_Assoc : Iir; + Length : Mnode; + begin + Length_Assoc := Get_Chain (Value_Assoc); + Subprg_Info := Get_Info (Imp); + Start_Association (Assocs, Subprg_Info.Ortho_Func); + Chap2.Add_Subprg_Instance_Assoc + (Assocs, Subprg_Info.Subprg_Instance); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (F_Assoc))); + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (Value_Assoc), + Formal_Type)); + Length := Chap6.Translate_Name (Get_Actual (Length_Assoc)); + New_Assign_Stmt (M2Lv (Length), New_Function_Call (Assocs)); + end; + when Type_Mode_Unknown + | Type_Mode_File + | Type_Mode_Acc + | Type_Mode_Fat_Acc + | Type_Mode_Protected => + raise Internal_Error; + end case; + end Translate_Read_Procedure_Call; + + procedure Translate_Implicit_Procedure_Call (Call : Iir_Procedure_Call) + is + Imp : constant Iir := Get_Implementation (Call); + Kind : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + Param_Chain : constant Iir := Get_Parameter_Association_Chain (Call); + begin + case Kind is + when Iir_Predefined_Write => + -- Check wether text or not. + declare + File_Param : Iir; + Assocs : O_Assoc_List; + begin + File_Param := Param_Chain; + -- FIXME: do the test. + if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) + then + -- If text: + Start_Association (Assocs, Ghdl_Text_Write); + -- compute file parameter (get an index) + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (File_Param))); + -- compute string parameter (get a fat array pointer) + New_Association + (Assocs, Chap7.Translate_Expression + (Get_Actual (Get_Chain (Param_Chain)), + String_Type_Definition)); + -- call a predefined procedure + New_Procedure_Call (Assocs); + else + Translate_Write_Procedure_Call (Imp, Param_Chain); + end if; + end; + + when Iir_Predefined_Read_Length => + -- FIXME: works only for text read length. + declare + File_Param : Iir; + N_Param : Iir; + Assocs : O_Assoc_List; + Str : O_Enode; + Res : Mnode; + begin + File_Param := Param_Chain; + if Get_Text_File_Flag (Get_Type (Get_Formal (File_Param))) + then + N_Param := Get_Chain (File_Param); + Str := Chap7.Translate_Expression + (Get_Actual (N_Param), String_Type_Definition); + N_Param := Get_Chain (N_Param); + Res := Chap6.Translate_Name (Get_Actual (N_Param)); + Start_Association (Assocs, Ghdl_Text_Read_Length); + -- compute file parameter (get an index) + New_Association + (Assocs, + Chap7.Translate_Expression (Get_Actual (File_Param))); + -- compute string parameter (get a fat array pointer) + New_Association (Assocs, Str); + -- call a predefined procedure + New_Assign_Stmt + (M2Lv (Res), New_Function_Call (Assocs)); + else + Translate_Read_Procedure_Call (Imp, Param_Chain); + end if; + end; + + when Iir_Predefined_Read => + Translate_Read_Procedure_Call (Imp, Param_Chain); + + when Iir_Predefined_Deallocate => + Chap3.Translate_Object_Deallocation (Get_Actual (Param_Chain)); + + when Iir_Predefined_File_Open => + declare + N_Param : Iir; + File_Param : Iir; + Name_Param : Iir; + Kind_Param : Iir; + Constr : O_Assoc_List; + begin + File_Param := Get_Actual (Param_Chain); + N_Param := Get_Chain (Param_Chain); + Name_Param := Get_Actual (N_Param); + N_Param := Get_Chain (N_Param); + Kind_Param := Get_Actual (N_Param); + if Get_Text_File_Flag (Get_Type (File_Param)) then + Start_Association (Constr, Ghdl_Text_File_Open); + else + Start_Association (Constr, Ghdl_File_Open); + end if; + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Association + (Constr, New_Convert_Ov + (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); + New_Association + (Constr, + Chap7.Translate_Expression (Name_Param, + String_Type_Definition)); + New_Procedure_Call (Constr); + end; + + when Iir_Predefined_File_Open_Status => + declare + Std_File_Open_Status_Otype : constant O_Tnode := + Get_Ortho_Type (File_Open_Status_Type_Definition, + Mode_Value); + N_Param : Iir; + Status_Param : constant Iir := Get_Actual (Param_Chain); + File_Param : Iir; + Name_Param : Iir; + Kind_Param : Iir; + Constr : O_Assoc_List; + Status : Mnode; + begin + Status := Chap6.Translate_Name (Status_Param); + N_Param := Get_Chain (Param_Chain); + File_Param := Get_Actual (N_Param); + N_Param := Get_Chain (N_Param); + Name_Param := Get_Actual (N_Param); + N_Param := Get_Chain (N_Param); + Kind_Param := Get_Actual (N_Param); + if Get_Text_File_Flag (Get_Type (File_Param)) then + Start_Association (Constr, Ghdl_Text_File_Open_Status); + else + Start_Association (Constr, Ghdl_File_Open_Status); + end if; + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Association + (Constr, New_Convert_Ov + (Chap7.Translate_Expression (Kind_Param), Ghdl_I32_Type)); + New_Association + (Constr, + Chap7.Translate_Expression (Name_Param, + String_Type_Definition)); + New_Assign_Stmt + (M2Lv (Status), + New_Convert_Ov (New_Function_Call (Constr), + Std_File_Open_Status_Otype)); + end; + + when Iir_Predefined_File_Close => + declare + File_Param : constant Iir := Get_Actual (Param_Chain); + Constr : O_Assoc_List; + begin + if Get_Text_File_Flag (Get_Type (File_Param)) then + Start_Association (Constr, Ghdl_Text_File_Close); + else + Start_Association (Constr, Ghdl_File_Close); + end if; + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Procedure_Call (Constr); + end; + + when Iir_Predefined_Flush => + declare + File_Param : constant Iir := Get_Actual (Param_Chain); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_File_Flush); + New_Association + (Constr, Chap7.Translate_Expression (File_Param)); + New_Procedure_Call (Constr); + end; + + when others => + Ada.Text_IO.Put_Line + ("translate_implicit_procedure_call: cannot handle " + & Iir_Predefined_Functions'Image (Kind)); + raise Internal_Error; + end case; + end Translate_Implicit_Procedure_Call; + + function Do_Conversion (Conv : Iir; Expr : Iir; Src : Mnode) + return O_Enode + is + Constr : O_Assoc_List; + Conv_Info : Subprg_Info_Acc; + Res : O_Dnode; + Imp : Iir; + begin + if Conv = Null_Iir then + return M2E (Src); +-- case Get_Type_Info (Dest).Type_Mode is +-- when Type_Mode_Thin => +-- New_Assign_Stmt (M2Lv (Dest), M2E (Src)); +-- when Type_Mode_Fat_Acc => +-- Copy_Fat_Pointer (Stabilize (Dest), Stabilize (Src)); +-- when others => +-- raise Internal_Error; +-- end case; + else + case Get_Kind (Conv) is + when Iir_Kind_Function_Call => + -- Call conversion function. + Imp := Get_Implementation (Conv); + Conv_Info := Get_Info (Imp); + Start_Association (Constr, Conv_Info.Ortho_Func); + + if Conv_Info.Res_Interface /= O_Dnode_Null then + Res := Create_Temp (Conv_Info.Res_Record_Type); + -- Composite result. + New_Association + (Constr, + New_Address (New_Obj (Res), Conv_Info.Res_Record_Ptr)); + end if; + + Chap2.Add_Subprg_Instance_Assoc + (Constr, Conv_Info.Subprg_Instance); + + New_Association (Constr, M2E (Src)); + + if Conv_Info.Res_Interface /= O_Dnode_Null then + -- Composite result. + New_Procedure_Call (Constr); + return New_Address (New_Obj (Res), + Conv_Info.Res_Record_Ptr); + else + return New_Function_Call (Constr); + end if; + when Iir_Kind_Type_Conversion => + return Chap7.Translate_Type_Conversion + (M2E (Src), Get_Type (Expr), + Get_Type (Conv), Null_Iir); + when others => + Error_Kind ("do_conversion", Conv); + end case; + end if; + end Do_Conversion; + + procedure Translate_Procedure_Call (Stmt : Iir_Procedure_Call) + is + type Mnode_Array is array (Natural range <>) of Mnode; + type O_Enode_Array is array (Natural range <>) of O_Enode; + Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); + Nbr_Assoc : constant Natural := + Iir_Chains.Get_Chain_Length (Assoc_Chain); + Params : Mnode_Array (0 .. Nbr_Assoc - 1); + E_Params : O_Enode_Array (0 .. Nbr_Assoc - 1); + Imp : constant Iir := Get_Implementation (Stmt); + Info : constant Subprg_Info_Acc := Get_Info (Imp); + Res : O_Dnode; + El : Iir; + Pos : Natural; + Constr : O_Assoc_List; + Act : Iir; + Actual_Type : Iir; + Formal : Iir; + Base_Formal : Iir; + Formal_Type : Iir; + Ftype_Info : Type_Info_Acc; + Formal_Info : Ortho_Info_Acc; + Val : O_Enode; + Param : Mnode; + Last_Individual : Natural; + Ptr : O_Lnode; + In_Conv : Iir; + In_Expr : Iir; + Out_Conv : Iir; + Out_Expr : Iir; + Formal_Object_Kind : Object_Kind_Type; + Bounds : Mnode; + Obj : Iir; + begin + -- Create an in-out result record for in-out arguments passed by + -- value. + if Info.Res_Record_Type /= O_Tnode_Null then + Res := Create_Temp (Info.Res_Record_Type); + else + Res := O_Dnode_Null; + end if; + + -- Evaluate in-out parameters and parameters passed by ref, since + -- they can add declarations. + -- Non-composite in-out parameters address are saved in order to + -- be able to assignate the result. + El := Assoc_Chain; + Pos := 0; + while El /= Null_Iir loop + Params (Pos) := Mnode_Null; + E_Params (Pos) := O_Enode_Null; + + Formal := Get_Formal (El); + if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then + Formal := Get_Named_Entity (Formal); + end if; + Base_Formal := Get_Association_Interface (El); + Formal_Type := Get_Type (Formal); + Formal_Info := Get_Info (Base_Formal); + if Get_Kind (Base_Formal) = Iir_Kind_Interface_Signal_Declaration + then + Formal_Object_Kind := Mode_Signal; + else + Formal_Object_Kind := Mode_Value; + end if; + Ftype_Info := Get_Info (Formal_Type); + + case Get_Kind (El) is + when Iir_Kind_Association_Element_Open => + Act := Get_Default_Value (Formal); + In_Conv := Null_Iir; + Out_Conv := Null_Iir; + when Iir_Kind_Association_Element_By_Expression => + Act := Get_Actual (El); + In_Conv := Get_In_Conversion (El); + Out_Conv := Get_Out_Conversion (El); + when Iir_Kind_Association_Element_By_Individual => + Actual_Type := Get_Actual_Type (El); + if Formal_Info.Interface_Field /= O_Fnode_Null then + -- A non-composite type cannot be associated by element. + raise Internal_Error; + end if; + if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then + Chap3.Create_Array_Subtype (Actual_Type, True); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); + Param := Create_Temp (Ftype_Info, Formal_Object_Kind); + Chap3.Translate_Object_Allocation + (Param, Alloc_Stack, Formal_Type, Bounds); + else + Param := Create_Temp (Ftype_Info, Formal_Object_Kind); + Chap4.Allocate_Complex_Object + (Formal_Type, Alloc_Stack, Param); + end if; + Last_Individual := Pos; + Params (Pos) := Param; + goto Continue; + when others => + Error_Kind ("translate_procedure_call", El); + end case; + Actual_Type := Get_Type (Act); + + if Formal_Info.Interface_Field /= O_Fnode_Null then + -- Copy-out argument. + -- This is not a composite type. + Param := Chap6.Translate_Name (Act); + if Get_Object_Kind (Param) /= Mode_Value then + raise Internal_Error; + end if; + Params (Pos) := Stabilize (Param); + if In_Conv /= Null_Iir + or else Get_Mode (Formal) = Iir_Inout_Mode + then + -- Arguments may be assigned if there is an in conversion. + Ptr := New_Selected_Element + (New_Obj (Res), Formal_Info.Interface_Field); + Param := Lv2M (Ptr, Ftype_Info, Mode_Value); + if In_Conv /= Null_Iir then + In_Expr := In_Conv; + else + In_Expr := Act; + end if; + Chap7.Translate_Assign + (Param, + Do_Conversion (In_Conv, Act, Params (Pos)), + In_Expr, + Formal_Type, El); + end if; + elsif Ftype_Info.Type_Mode not in Type_Mode_By_Value then + -- Passed by reference. + case Get_Kind (Base_Formal) is + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_File_Declaration => + -- No conversion here. + E_Params (Pos) := Chap7.Translate_Expression + (Act, Formal_Type); + when Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Param := Chap6.Translate_Name (Act); + -- Atype may not have been set (eg: slice). + if Base_Formal /= Formal then + Stabilize (Param); + Params (Pos) := Param; + end if; + E_Params (Pos) := M2E (Param); + if Formal_Type /= Actual_Type then + -- Implicit array conversion or subtype check. + E_Params (Pos) := Chap7.Translate_Implicit_Conv + (E_Params (Pos), Actual_Type, Formal_Type, + Get_Object_Kind (Param), Stmt); + end if; + when others => + Error_Kind ("translate_procedure_call(2)", Formal); + end case; + end if; + if Base_Formal /= Formal then + -- Individual association. + if Ftype_Info.Type_Mode not in Type_Mode_By_Value then + -- Not by-value actual already translated. + Val := E_Params (Pos); + else + -- By value association. + Act := Get_Actual (El); + if Get_Kind (Base_Formal) + = Iir_Kind_Interface_Constant_Declaration + then + Val := Chap7.Translate_Expression (Act, Formal_Type); + else + Params (Pos) := Chap6.Translate_Name (Act); + -- Since signals are passed by reference, they are not + -- copied back, so do not stabilize them (furthermore, + -- it is not possible to stabilize them). + if Formal_Object_Kind = Mode_Value then + Params (Pos) := Stabilize (Params (Pos)); + end if; + Val := M2E (Params (Pos)); + end if; + end if; + -- Assign formal. + -- Change the formal variable so that it is the local variable + -- that will be passed to the subprogram. + declare + Prev_Node : O_Dnode; + begin + Prev_Node := Formal_Info.Interface_Node; + -- We need a pointer since the interface is by reference. + Formal_Info.Interface_Node := + M2Dp (Params (Last_Individual)); + Param := Chap6.Translate_Name (Formal); + Formal_Info.Interface_Node := Prev_Node; + end; + Chap7.Translate_Assign (Param, Val, Act, Formal_Type, El); + end if; + << Continue >> null; + El := Get_Chain (El); + Pos := Pos + 1; + end loop; + + -- Second stage: really perform the call. + Start_Association (Constr, Info.Ortho_Func); + if Res /= O_Dnode_Null then + New_Association (Constr, + New_Address (New_Obj (Res), Info.Res_Record_Ptr)); + end if; + + Obj := Get_Method_Object (Stmt); + if Obj /= Null_Iir then + New_Association (Constr, M2E (Chap6.Translate_Name (Obj))); + else + Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); + end if; + + -- Parameters. + El := Assoc_Chain; + Pos := 0; + while El /= Null_Iir loop + Formal := Get_Formal (El); + if Get_Kind (Formal) in Iir_Kinds_Denoting_Name then + Formal := Get_Named_Entity (Formal); + end if; + Base_Formal := Get_Association_Interface (El); + Formal_Info := Get_Info (Base_Formal); + Formal_Type := Get_Type (Formal); + Ftype_Info := Get_Info (Formal_Type); + + if Get_Kind (El) = Iir_Kind_Association_Element_By_Individual then + Last_Individual := Pos; + New_Association (Constr, M2E (Params (Pos))); + elsif Base_Formal /= Formal then + -- Individual association. + null; + elsif Formal_Info.Interface_Field = O_Fnode_Null then + if Ftype_Info.Type_Mode in Type_Mode_By_Value then + -- Parameter passed by value. + if E_Params (Pos) /= O_Enode_Null then + Val := E_Params (Pos); + raise Internal_Error; + else + case Get_Kind (El) is + when Iir_Kind_Association_Element_Open => + Act := Get_Default_Value (Formal); + In_Conv := Null_Iir; + when Iir_Kind_Association_Element_By_Expression => + Act := Get_Actual (El); + In_Conv := Get_In_Conversion (El); + when others => + Error_Kind ("translate_procedure_call(2)", El); + end case; + case Get_Kind (Formal) is + when Iir_Kind_Interface_Signal_Declaration => + Param := Chap6.Translate_Name (Act); + -- This is a scalar. + Val := M2E (Param); + when others => + if In_Conv = Null_Iir then + Val := Chap7.Translate_Expression + (Act, Formal_Type); + else + Actual_Type := Get_Type (Act); + Val := Do_Conversion + (In_Conv, + Act, + E2M (Chap7.Translate_Expression (Act, + Actual_Type), + Get_Info (Actual_Type), + Mode_Value)); + end if; + end case; + end if; + New_Association (Constr, Val); + else + -- Parameter passed by ref, which was already computed. + New_Association (Constr, E_Params (Pos)); + end if; + end if; + El := Get_Chain (El); + Pos := Pos + 1; + end loop; + + New_Procedure_Call (Constr); + + -- Copy-out non-composite parameters. + El := Assoc_Chain; + Pos := 0; + while El /= Null_Iir loop + Formal := Get_Formal (El); + Base_Formal := Get_Association_Interface (El); + Formal_Type := Get_Type (Formal); + Ftype_Info := Get_Info (Formal_Type); + Formal_Info := Get_Info (Base_Formal); + if Get_Kind (Base_Formal) = Iir_Kind_Interface_Variable_Declaration + and then Get_Mode (Base_Formal) in Iir_Out_Modes + and then Params (Pos) /= Mnode_Null + then + if Formal_Info.Interface_Field /= O_Fnode_Null then + -- OUT parameters. + Out_Conv := Get_Out_Conversion (El); + if Out_Conv = Null_Iir then + Out_Expr := Formal; + else + Out_Expr := Out_Conv; + end if; + Ptr := New_Selected_Element + (New_Obj (Res), Formal_Info.Interface_Field); + Param := Lv2M (Ptr, Ftype_Info, Mode_Value); + Chap7.Translate_Assign (Params (Pos), + Do_Conversion (Out_Conv, Formal, + Param), + Out_Expr, + Get_Type (Get_Actual (El)), El); + elsif Base_Formal /= Formal then + -- By individual. + -- Copy back. + Act := Get_Actual (El); + declare + Prev_Node : O_Dnode; + begin + Prev_Node := Formal_Info.Interface_Node; + -- We need a pointer since the interface is by reference. + Formal_Info.Interface_Node := + M2Dp (Params (Last_Individual)); + Val := Chap7.Translate_Expression + (Formal, Get_Type (Act)); + Formal_Info.Interface_Node := Prev_Node; + end; + Chap7.Translate_Assign + (Params (Pos), Val, Formal, Get_Type (Act), El); + end if; + end if; + El := Get_Chain (El); + Pos := Pos + 1; + end loop; + end Translate_Procedure_Call; + + procedure Translate_Wait_Statement (Stmt : Iir) + is + Sensitivity : Iir_List; + Cond : Iir; + Timeout : Iir; + Constr : O_Assoc_List; + begin + Sensitivity := Get_Sensitivity_List (Stmt); + Cond := Get_Condition_Clause (Stmt); + Timeout := Get_Timeout_Clause (Stmt); + + if Sensitivity = Null_Iir_List and Cond /= Null_Iir then + Sensitivity := Create_Iir_List; + Canon.Canon_Extract_Sensitivity (Cond, Sensitivity); + Set_Sensitivity_List (Stmt, Sensitivity); + end if; + + -- Check for simple cases. + if Sensitivity = Null_Iir_List + and then Cond = Null_Iir + then + if Timeout = Null_Iir then + -- Process exit. + Start_Association (Constr, Ghdl_Process_Wait_Exit); + New_Procedure_Call (Constr); + else + -- Wait for a timeout. + Start_Association (Constr, Ghdl_Process_Wait_Timeout); + New_Association (Constr, Chap7.Translate_Expression + (Timeout, Time_Type_Definition)); + New_Procedure_Call (Constr); + end if; + return; + end if; + + -- Evaluate the timeout (if any) and register it, + if Timeout /= Null_Iir then + Start_Association (Constr, Ghdl_Process_Wait_Set_Timeout); + New_Association (Constr, Chap7.Translate_Expression + (Timeout, Time_Type_Definition)); + New_Procedure_Call (Constr); + end if; + + -- Evaluate the sensitivity list and register it. + if Sensitivity /= Null_Iir_List then + Register_Signal_List + (Sensitivity, Ghdl_Process_Wait_Add_Sensitivity); + end if; + + if Cond = Null_Iir then + declare + V : O_Dnode; + begin + -- declare + -- v : __ghdl_bool_type_node; + -- begin + -- v := suspend (); + -- end; + Open_Temp; + V := Create_Temp (Ghdl_Bool_Type); + Start_Association (Constr, Ghdl_Process_Wait_Suspend); + New_Assign_Stmt (New_Obj (V), New_Function_Call (Constr)); + Close_Temp; + end; + else + declare + Label : O_Snode; + begin + -- start loop + Start_Loop_Stmt (Label); + + -- if suspend() then -- return true if timeout. + -- exit; + -- end if; + Start_Association (Constr, Ghdl_Process_Wait_Suspend); + Gen_Exit_When (Label, New_Function_Call (Constr)); + + -- if condition then + -- exit; + -- end if; + Open_Temp; + Gen_Exit_When + (Label, + Chap7.Translate_Expression (Cond, Boolean_Type_Definition)); + Close_Temp; + + -- end loop; + Finish_Loop_Stmt (Label); + end; + end if; + + -- wait_close; + Start_Association (Constr, Ghdl_Process_Wait_Close); + New_Procedure_Call (Constr); + end Translate_Wait_Statement; + + -- Signal assignment. + Signal_Assign_Line : Natural; + procedure Gen_Simple_Signal_Assign_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Val : O_Enode) + is + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + begin + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Simple_Assign_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Simple_Assign_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Simple_Assign_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Simple_Assign_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Simple_Assign_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Simple_Assign_F64; + Conv := Ghdl_Real_Type; + when Type_Mode_Array => + raise Internal_Error; + when others => + Error_Kind ("gen_signal_assign_non_composite", Targ_Type); + end case; + if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then + declare + If_Blk : O_If_Block; + Val2 : O_Dnode; + Targ2 : O_Dnode; + begin + Open_Temp; + Val2 := Create_Temp_Init + (Type_Info.Ortho_Type (Mode_Value), Val); + Targ2 := Create_Temp_Init + (Ghdl_Signal_Ptr, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + Start_If_Stmt (If_Blk, Chap3.Not_In_Range (Val2, Targ_Type)); + Start_Association (Assoc, Ghdl_Signal_Simple_Assign_Error); + New_Association (Assoc, New_Obj_Value (Targ2)); + Assoc_Filename_Line (Assoc, Signal_Assign_Line); + New_Procedure_Call (Assoc); + New_Else_Stmt (If_Blk); + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Obj_Value (Targ2)); + New_Association + (Assoc, New_Convert_Ov (New_Obj_Value (Val2), Conv)); + New_Procedure_Call (Assoc); + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + else + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Convert_Ov (Val, Conv)); + New_Procedure_Call (Assoc); + end if; + end Gen_Simple_Signal_Assign_Non_Composite; + + procedure Gen_Simple_Signal_Assign is new Foreach_Non_Composite + (Data_Type => O_Enode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Gen_Simple_Signal_Assign_Non_Composite, + Prepare_Data_Array => Gen_Oenode_Prepare_Data_Composite, + Update_Data_Array => Gen_Oenode_Update_Data_Array, + Finish_Data_Array => Gen_Oenode_Finish_Data_Composite, + Prepare_Data_Record => Gen_Oenode_Prepare_Data_Composite, + Update_Data_Record => Gen_Oenode_Update_Data_Record, + Finish_Data_Record => Gen_Oenode_Finish_Data_Composite); + + type Signal_Assign_Data is record + Expr : Mnode; + Reject : O_Dnode; + After : O_Dnode; + end record; + + procedure Gen_Start_Signal_Assign_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) + is + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + begin + if Data.Expr = Mnode_Null then + -- Null transaction. + Start_Association (Assoc, Ghdl_Signal_Start_Assign_Null); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + return; + end if; + + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Start_Assign_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Start_Assign_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Start_Assign_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Start_Assign_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Start_Assign_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Start_Assign_F64; + Conv := Ghdl_Real_Type; + when Type_Mode_Array => + raise Internal_Error; + when others => + Error_Kind ("gen_signal_assign_non_composite", Targ_Type); + end case; + -- Check range. + if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then + declare + If_Blk : O_If_Block; + V : Mnode; + Starg : O_Dnode; + begin + Open_Temp; + V := Stabilize_Value (Data.Expr); + Starg := Create_Temp_Init + (Ghdl_Signal_Ptr, + New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + Start_If_Stmt + (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); + Start_Association (Assoc, Ghdl_Signal_Start_Assign_Error); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Obj_Value (Data.After)); + Assoc_Filename_Line (Assoc, Signal_Assign_Line); + New_Procedure_Call (Assoc); + New_Else_Stmt (If_Blk); + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + else + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.Reject)); + New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + end if; + end Gen_Start_Signal_Assign_Non_Composite; + + function Gen_Signal_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) + return Signal_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Val; + end Gen_Signal_Prepare_Data_Composite; + + function Gen_Signal_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Assign_Data) + return Signal_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + if Val.Expr = Mnode_Null then + return Val; + else + return Signal_Assign_Data' + (Expr => Stabilize (Val.Expr), + Reject => Val.Reject, + After => Val.After); + end if; + end Gen_Signal_Prepare_Data_Record; + + function Gen_Signal_Update_Data_Array + (Val : Signal_Assign_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Signal_Assign_Data + is + Res : Signal_Assign_Data; + begin + if Val.Expr = Mnode_Null then + -- Handle null transaction. + return Val; + end if; + Res := Signal_Assign_Data' + (Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), + Targ_Type, New_Obj_Value (Index)), + Reject => Val.Reject, + After => Val.After); + return Res; + end Gen_Signal_Update_Data_Array; + + function Gen_Signal_Update_Data_Record + (Val : Signal_Assign_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Signal_Assign_Data + is + pragma Unreferenced (Targ_Type); + Res : Signal_Assign_Data; + begin + if Val.Expr = Mnode_Null then + -- Handle null transaction. + return Val; + end if; + Res := Signal_Assign_Data' + (Expr => Chap6.Translate_Selected_Element (Val.Expr, El), + Reject => Val.Reject, + After => Val.After); + return Res; + end Gen_Signal_Update_Data_Record; + + procedure Gen_Signal_Finish_Data_Composite + (Data : in out Signal_Assign_Data) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Signal_Finish_Data_Composite; + + procedure Gen_Start_Signal_Assign is new Foreach_Non_Composite + (Data_Type => Signal_Assign_Data, + Composite_Data_Type => Signal_Assign_Data, + Do_Non_Composite => Gen_Start_Signal_Assign_Non_Composite, + Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, + Update_Data_Array => Gen_Signal_Update_Data_Array, + Finish_Data_Array => Gen_Signal_Finish_Data_Composite, + Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, + Update_Data_Record => Gen_Signal_Update_Data_Record, + Finish_Data_Record => Gen_Signal_Finish_Data_Composite); + + procedure Gen_Next_Signal_Assign_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Signal_Assign_Data) + is + Type_Info : Type_Info_Acc; + Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + begin + if Data.Expr = Mnode_Null then + -- Null transaction. + Start_Association (Assoc, Ghdl_Signal_Next_Assign_Null); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + return; + end if; + + Type_Info := Get_Info (Targ_Type); + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Next_Assign_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Next_Assign_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Next_Assign_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Next_Assign_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Next_Assign_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Next_Assign_F64; + Conv := Ghdl_Real_Type; + when Type_Mode_Array => + raise Internal_Error; + when others => + Error_Kind ("gen_signal_next_assign_non_composite", Targ_Type); + end case; + if Chap3.Need_Range_Check (Null_Iir, Targ_Type) then + declare + If_Blk : O_If_Block; + V : Mnode; + Starg : O_Dnode; + begin + Open_Temp; + V := Stabilize_Value (Data.Expr); + Starg := Create_Temp_Init + (Ghdl_Signal_Ptr, + New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + Start_If_Stmt + (If_Blk, Chap3.Not_In_Range (M2Dv (V), Targ_Type)); + + Start_Association (Assoc, Ghdl_Signal_Next_Assign_Error); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Obj_Value (Data.After)); + Assoc_Filename_Line (Assoc, Signal_Assign_Line); + New_Procedure_Call (Assoc); + + New_Else_Stmt (If_Blk); + + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Obj_Value (Starg)); + New_Association (Assoc, New_Convert_Ov (M2E (V), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + + Finish_If_Stmt (If_Blk); + Close_Temp; + end; + else + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), + Ghdl_Signal_Ptr)); + New_Association (Assoc, New_Convert_Ov (M2E (Data.Expr), Conv)); + New_Association (Assoc, New_Obj_Value (Data.After)); + New_Procedure_Call (Assoc); + end if; + end Gen_Next_Signal_Assign_Non_Composite; + + procedure Gen_Next_Signal_Assign is new Foreach_Non_Composite + (Data_Type => Signal_Assign_Data, + Composite_Data_Type => Signal_Assign_Data, + Do_Non_Composite => Gen_Next_Signal_Assign_Non_Composite, + Prepare_Data_Array => Gen_Signal_Prepare_Data_Composite, + Update_Data_Array => Gen_Signal_Update_Data_Array, + Finish_Data_Array => Gen_Signal_Finish_Data_Composite, + Prepare_Data_Record => Gen_Signal_Prepare_Data_Record, + Update_Data_Record => Gen_Signal_Update_Data_Record, + Finish_Data_Record => Gen_Signal_Finish_Data_Composite); + + procedure Translate_Signal_Target_Aggr + (Aggr : Mnode; Target : Iir; Target_Type : Iir); + + procedure Translate_Signal_Target_Array_Aggr + (Aggr : Mnode; + Target : Iir; + Target_Type : Iir; + Idx : O_Dnode; + Dim : Natural) + is + Index_List : constant Iir_List := + Get_Index_Subtype_List (Target_Type); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); + Sub_Aggr : Mnode; + El : Iir; + Expr : Iir; + begin + El := Get_Association_Choices_Chain (Target); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Choice_By_None => + Sub_Aggr := Chap3.Index_Base + (Aggr, Target_Type, New_Obj_Value (Idx)); + when others => + Error_Kind ("translate_signal_target_array_aggr", El); + end case; + Expr := Get_Associated_Expr (El); + if Dim = Nbr_Dim then + Translate_Signal_Target_Aggr + (Sub_Aggr, Expr, Get_Element_Subtype (Target_Type)); + if Get_Kind (El) = Iir_Kind_Choice_By_None then + Inc_Var (Idx); + else + raise Internal_Error; + end if; + else + Translate_Signal_Target_Array_Aggr + (Sub_Aggr, Expr, Target_Type, Idx, Dim + 1); + end if; + El := Get_Chain (El); + end loop; + end Translate_Signal_Target_Array_Aggr; + + procedure Translate_Signal_Target_Record_Aggr + (Aggr : Mnode; Target : Iir; Target_Type : Iir) + is + Aggr_El : Iir; + El_List : Iir_List; + El_Index : Natural; + Element : Iir_Element_Declaration; + begin + El_List := Get_Elements_Declaration_List + (Get_Base_Type (Target_Type)); + El_Index := 0; + Aggr_El := Get_Association_Choices_Chain (Target); + while Aggr_El /= Null_Iir loop + case Get_Kind (Aggr_El) is + when Iir_Kind_Choice_By_None => + Element := Get_Nth_Element (El_List, El_Index); + El_Index := El_Index + 1; + when Iir_Kind_Choice_By_Name => + Element := Get_Choice_Name (Aggr_El); + El_Index := Natural'Last; + when others => + Error_Kind ("translate_signal_target_record_aggr", Aggr_El); + end case; + Translate_Signal_Target_Aggr + (Chap6.Translate_Selected_Element (Aggr, Element), + Get_Associated_Expr (Aggr_El), Get_Type (Element)); + Aggr_El := Get_Chain (Aggr_El); + end loop; + end Translate_Signal_Target_Record_Aggr; + + procedure Translate_Signal_Target_Aggr + (Aggr : Mnode; Target : Iir; Target_Type : Iir) + is + Src : Mnode; + begin + if Get_Kind (Target) = Iir_Kind_Aggregate then + declare + Idx : O_Dnode; + St_Aggr : Mnode; + begin + Open_Temp; + St_Aggr := Stabilize (Aggr); + case Get_Kind (Target_Type) is + when Iir_Kinds_Array_Type_Definition => + Idx := Create_Temp (Ghdl_Index_Type); + Init_Var (Idx); + Translate_Signal_Target_Array_Aggr + (St_Aggr, Target, Target_Type, Idx, 1); + when Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + Translate_Signal_Target_Record_Aggr + (St_Aggr, Target, Target_Type); + when others => + Error_Kind ("translate_signal_target_aggr", Target_Type); + end case; + Close_Temp; + end; + else + Src := Chap6.Translate_Name (Target); + Chap3.Translate_Object_Copy (Aggr, M2E (Src), Target_Type); + end if; + end Translate_Signal_Target_Aggr; + + type Signal_Direct_Assign_Data is record + -- The driver + Drv : Mnode; + + -- The value + Expr : Mnode; + + -- The node for the expression (used to locate errors). + Expr_Node : Iir; + end record; + + procedure Gen_Signal_Direct_Assign_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Signal_Direct_Assign_Data) + is + Targ_Sig : Mnode; + If_Blk : O_If_Block; + Constr : O_Assoc_List; + Cond : O_Dnode; + Drv : Mnode; + begin + Open_Temp; + Targ_Sig := Stabilize (Targ, True); + Cond := Create_Temp (Ghdl_Bool_Type); + Drv := Stabilize (Data.Drv, False); + + -- Set driver. + Chap7.Translate_Assign + (Drv, M2E (Data.Expr), Data.Expr_Node, Targ_Type, Data.Expr_Node); + + -- Test if the signal is active. + Start_If_Stmt + (If_Blk, + New_Value (Chap14.Get_Signal_Field + (Targ_Sig, Ghdl_Signal_Has_Active_Field))); + -- Either because has_active is true. + New_Assign_Stmt (New_Obj (Cond), + New_Lit (Ghdl_Bool_True_Node)); + New_Else_Stmt (If_Blk); + -- Or because the value is different from the current driving value. + -- FIXME: ideally, we should compare the value with the current + -- value of the driver. This is an approximation that might break + -- with weird resolution functions. + New_Assign_Stmt + (New_Obj (Cond), + New_Compare_Op (ON_Neq, + Chap7.Translate_Signal_Driving_Value + (M2E (Targ_Sig), Targ_Type), + M2E (Drv), + Ghdl_Bool_Type)); + Finish_If_Stmt (If_Blk); + + -- Put signal into active list (if not already in the list). + -- FIXME: this is not thread-safe! + Start_If_Stmt (If_Blk, New_Obj_Value (Cond)); + Start_Association (Constr, Ghdl_Signal_Direct_Assign); + New_Association (Constr, + New_Convert_Ov (New_Value (M2Lv (Targ_Sig)), + Ghdl_Signal_Ptr)); + New_Procedure_Call (Constr); + Finish_If_Stmt (If_Blk); + + Close_Temp; + end Gen_Signal_Direct_Assign_Non_Composite; + + function Gen_Signal_Direct_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) + return Signal_Direct_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Val; + end Gen_Signal_Direct_Prepare_Data_Composite; + + function Gen_Signal_Direct_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Val : Signal_Direct_Assign_Data) + return Signal_Direct_Assign_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Signal_Direct_Assign_Data' + (Drv => Stabilize (Val.Drv), + Expr => Stabilize (Val.Expr), + Expr_Node => Val.Expr_Node); + end Gen_Signal_Direct_Prepare_Data_Record; + + function Gen_Signal_Direct_Update_Data_Array + (Val : Signal_Direct_Assign_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Signal_Direct_Assign_Data + is + begin + return Signal_Direct_Assign_Data' + (Drv => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Drv), + Targ_Type, New_Obj_Value (Index)), + Expr => Chap3.Index_Base (Chap3.Get_Array_Base (Val.Expr), + Targ_Type, New_Obj_Value (Index)), + Expr_Node => Val.Expr_Node); + end Gen_Signal_Direct_Update_Data_Array; + + function Gen_Signal_Direct_Update_Data_Record + (Val : Signal_Direct_Assign_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Signal_Direct_Assign_Data + is + pragma Unreferenced (Targ_Type); + begin + return Signal_Direct_Assign_Data' + (Drv => Chap6.Translate_Selected_Element (Val.Drv, El), + Expr => Chap6.Translate_Selected_Element (Val.Expr, El), + Expr_Node => Val.Expr_Node); + end Gen_Signal_Direct_Update_Data_Record; + + procedure Gen_Signal_Direct_Finish_Data_Composite + (Data : in out Signal_Direct_Assign_Data) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Signal_Direct_Finish_Data_Composite; + + procedure Gen_Signal_Direct_Assign is new Foreach_Non_Composite + (Data_Type => Signal_Direct_Assign_Data, + Composite_Data_Type => Signal_Direct_Assign_Data, + Do_Non_Composite => Gen_Signal_Direct_Assign_Non_Composite, + Prepare_Data_Array => Gen_Signal_Direct_Prepare_Data_Composite, + Update_Data_Array => Gen_Signal_Direct_Update_Data_Array, + Finish_Data_Array => Gen_Signal_Direct_Finish_Data_Composite, + Prepare_Data_Record => Gen_Signal_Direct_Prepare_Data_Record, + Update_Data_Record => Gen_Signal_Direct_Update_Data_Record, + Finish_Data_Record => Gen_Signal_Direct_Finish_Data_Composite); + + procedure Translate_Direct_Signal_Assignment (Stmt : Iir; We : Iir) + is + Target : constant Iir := Get_Target (Stmt); + Target_Type : constant Iir := Get_Type (Target); + Arg : Signal_Direct_Assign_Data; + Targ_Sig : Mnode; + begin + Chap6.Translate_Direct_Driver (Target, Targ_Sig, Arg.Drv); + + Arg.Expr := E2M (Chap7.Translate_Expression (We, Target_Type), + Get_Info (Target_Type), Mode_Value); + Arg.Expr_Node := We; + Gen_Signal_Direct_Assign (Targ_Sig, Target_Type, Arg); + end Translate_Direct_Signal_Assignment; + + procedure Translate_Signal_Assignment_Statement (Stmt : Iir) + is + Target : Iir; + Target_Type : Iir; + We : Iir_Waveform_Element; + Targ : Mnode; + Val : O_Enode; + Value : Iir; + Is_Simple : Boolean; + begin + Target := Get_Target (Stmt); + Target_Type := Get_Type (Target); + We := Get_Waveform_Chain (Stmt); + + if We /= Null_Iir + and then Get_Chain (We) = Null_Iir + and then Get_Time (We) = Null_Iir + and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay + and then Get_Reject_Time_Expression (Stmt) = Null_Iir + then + -- Simple signal assignment ? + Value := Get_We_Value (We); + Is_Simple := Get_Kind (Value) /= Iir_Kind_Null_Literal; + else + Is_Simple := False; + end if; + + if Get_Kind (Target) = Iir_Kind_Aggregate then + Chap3.Translate_Anonymous_Type_Definition (Target_Type, True); + Targ := Create_Temp (Get_Info (Target_Type), Mode_Signal); + Chap4.Allocate_Complex_Object (Target_Type, Alloc_Stack, Targ); + Translate_Signal_Target_Aggr (Targ, Target, Target_Type); + else + if Is_Simple + and then Flag_Direct_Drivers + and then Chap4.Has_Direct_Driver (Target) + then + Translate_Direct_Signal_Assignment (Stmt, Value); + return; + end if; + Targ := Chap6.Translate_Name (Target); + if Get_Object_Kind (Targ) /= Mode_Signal then + raise Internal_Error; + end if; + end if; + + if We = Null_Iir then + -- Implicit disconnect statment. + Register_Signal (Targ, Target_Type, Ghdl_Signal_Disconnect); + return; + end if; + + -- Handle a simple and common case: only one waveform, inertial, + -- and no time (eg: sig <= expr). + Value := Get_We_Value (We); + Signal_Assign_Line := Get_Line_Number (Value); + if Get_Chain (We) = Null_Iir + and then Get_Time (We) = Null_Iir + and then Get_Delay_Mechanism (Stmt) = Iir_Inertial_Delay + and then Get_Reject_Time_Expression (Stmt) = Null_Iir + and then Get_Kind (Value) /= Iir_Kind_Null_Literal + then + Val := Chap7.Translate_Expression (Value, Target_Type); + Gen_Simple_Signal_Assign (Targ, Target_Type, Val); + return; + end if; + + -- General case. + declare + Var_Targ : Mnode; + Targ_Tinfo : Type_Info_Acc; + begin + Open_Temp; + Targ_Tinfo := Get_Info (Target_Type); + Var_Targ := Stabilize (Targ, True); + + -- Translate the first waveform element. + declare + Reject_Time : O_Dnode; + After_Time : O_Dnode; + Del : Iir; + Rej : Iir; + Val : Mnode; + Data : Signal_Assign_Data; + begin + Open_Temp; + Reject_Time := Create_Temp (Std_Time_Otype); + After_Time := Create_Temp (Std_Time_Otype); + Del := Get_Time (We); + if Del = Null_Iir then + New_Assign_Stmt + (New_Obj (After_Time), + New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); + else + New_Assign_Stmt + (New_Obj (After_Time), + Chap7.Translate_Expression (Del, Time_Type_Definition)); + end if; + case Get_Delay_Mechanism (Stmt) is + when Iir_Transport_Delay => + New_Assign_Stmt + (New_Obj (Reject_Time), + New_Lit (New_Signed_Literal (Std_Time_Otype, 0))); + when Iir_Inertial_Delay => + Rej := Get_Reject_Time_Expression (Stmt); + if Rej = Null_Iir then + New_Assign_Stmt (New_Obj (Reject_Time), + New_Obj_Value (After_Time)); + else + New_Assign_Stmt + (New_Obj (Reject_Time), Chap7.Translate_Expression + (Rej, Time_Type_Definition)); + end if; + end case; + if Get_Kind (Value) = Iir_Kind_Null_Literal then + Val := Mnode_Null; + else + Val := E2M (Chap7.Translate_Expression (Value, Target_Type), + Targ_Tinfo, Mode_Value); + Val := Stabilize (Val); + end if; + Data := Signal_Assign_Data'(Expr => Val, + Reject => Reject_Time, + After => After_Time); + Gen_Start_Signal_Assign (Var_Targ, Target_Type, Data); + Close_Temp; + end; + + -- Translate other waveform elements. + We := Get_Chain (We); + while We /= Null_Iir loop + declare + After_Time : O_Dnode; + Val : Mnode; + Data : Signal_Assign_Data; + begin + Open_Temp; + After_Time := Create_Temp (Std_Time_Otype); + New_Assign_Stmt + (New_Obj (After_Time), + Chap7.Translate_Expression (Get_Time (We), + Time_Type_Definition)); + Value := Get_We_Value (We); + Signal_Assign_Line := Get_Line_Number (Value); + if Get_Kind (Value) = Iir_Kind_Null_Literal then + Val := Mnode_Null; + else + Val := + E2M (Chap7.Translate_Expression (Value, Target_Type), + Targ_Tinfo, Mode_Value); + end if; + Data := Signal_Assign_Data'(Expr => Val, + Reject => O_Dnode_Null, + After => After_Time); + Gen_Next_Signal_Assign (Var_Targ, Target_Type, Data); + Close_Temp; + end; + We := Get_Chain (We); + end loop; + + Close_Temp; + end; + end Translate_Signal_Assignment_Statement; + + procedure Translate_Statement (Stmt : Iir) + is + begin + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + Open_Temp; + case Get_Kind (Stmt) is + when Iir_Kind_Return_Statement => + Translate_Return_Statement (Stmt); + + when Iir_Kind_If_Statement => + Translate_If_Statement (Stmt); + when Iir_Kind_Assertion_Statement => + Translate_Assertion_Statement (Stmt); + when Iir_Kind_Report_Statement => + Translate_Report_Statement (Stmt); + when Iir_Kind_Case_Statement => + Translate_Case_Statement (Stmt); + + when Iir_Kind_For_Loop_Statement => + Translate_For_Loop_Statement (Stmt); + when Iir_Kind_While_Loop_Statement => + Translate_While_Loop_Statement (Stmt); + when Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement => + Translate_Exit_Next_Statement (Stmt); + + when Iir_Kind_Signal_Assignment_Statement => + Translate_Signal_Assignment_Statement (Stmt); + when Iir_Kind_Variable_Assignment_Statement => + Translate_Variable_Assignment_Statement (Stmt); + + when Iir_Kind_Null_Statement => + -- A null statement is translated to a NOP, so that the + -- statement generates code (and a breakpoint can be set on + -- it). + -- Emit_Nop; + null; + + when Iir_Kind_Procedure_Call_Statement => + declare + Call : constant Iir := Get_Procedure_Call (Stmt); + Imp : constant Iir := Get_Implementation (Call); + begin + Canon.Canon_Subprogram_Call (Call); + if Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration + then + Translate_Implicit_Procedure_Call (Call); + else + Translate_Procedure_Call (Call); + end if; + end; + + when Iir_Kind_Wait_Statement => + Translate_Wait_Statement (Stmt); + + when others => + Error_Kind ("translate_statement", Stmt); + end case; + Close_Temp; + end Translate_Statement; + + procedure Translate_Statements_Chain (First : Iir) + is + Stmt : Iir; + begin + Stmt := First; + while Stmt /= Null_Iir loop + Translate_Statement (Stmt); + Stmt := Get_Chain (Stmt); + end loop; + end Translate_Statements_Chain; + + function Translate_Statements_Chain_Has_Return (First : Iir) + return Boolean + is + Stmt : Iir; + Has_Return : Boolean := False; + begin + Stmt := First; + while Stmt /= Null_Iir loop + Translate_Statement (Stmt); + if Get_Kind (Stmt) = Iir_Kind_Return_Statement then + Has_Return := True; + end if; + Stmt := Get_Chain (Stmt); + end loop; + return Has_Return; + end Translate_Statements_Chain_Has_Return; + end Chap8; + + package body Chap9 is + procedure Set_Direct_Drivers (Proc : Iir) + is + Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); + Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; + Info : Ortho_Info_Acc; + Var : Var_Type; + Sig : Iir; + begin + for I in Drivers.all'Range loop + Var := Drivers (I).Var; + if Var /= Null_Var then + Sig := Get_Object_Prefix (Drivers (I).Sig); + Info := Get_Info (Sig); + case Info.Kind is + when Kind_Object => + Info.Object_Driver := Var; + when Kind_Alias => + null; + when others => + raise Internal_Error; + end case; + end if; + end loop; + end Set_Direct_Drivers; + + procedure Reset_Direct_Drivers (Proc : Iir) + is + Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); + Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; + Info : Ortho_Info_Acc; + Var : Var_Type; + Sig : Iir; + begin + for I in Drivers.all'Range loop + Var := Drivers (I).Var; + if Var /= Null_Var then + Sig := Get_Object_Prefix (Drivers (I).Sig); + Info := Get_Info (Sig); + case Info.Kind is + when Kind_Object => + Info.Object_Driver := Null_Var; + when Kind_Alias => + null; + when others => + raise Internal_Error; + end case; + end if; + end loop; + end Reset_Direct_Drivers; + + procedure Translate_Process_Statement (Proc : Iir; Base : Block_Info_Acc) + is + Info : constant Proc_Info_Acc := Get_Info (Proc); + Inter_List : O_Inter_List; + Instance : O_Dnode; + begin + 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.Process_Subprg); + + Start_Subprogram_Body (Info.Process_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + Chap8.Translate_Statements_Chain + (Get_Sequential_Statement_Chain (Proc)); + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Process_Statement; + + procedure Translate_Implicit_Guard_Signal + (Guard : Iir; Base : Block_Info_Acc) + is + Info : Object_Info_Acc; + Inter_List : O_Inter_List; + Instance : O_Dnode; + Guard_Expr : Iir; + begin + Guard_Expr := Get_Guard_Expression (Guard); + -- Create the subprogram to compute the value of GUARD. + Info := Get_Info (Guard); + Start_Function_Decl (Inter_List, Create_Identifier ("_GUARD_PROC"), + O_Storage_Private, Std_Boolean_Type_Node); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Object_Function); + + Start_Subprogram_Body (Info.Object_Function); + Push_Local_Factory; + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + Open_Temp; + New_Return_Stmt (Chap7.Translate_Expression (Guard_Expr)); + Close_Temp; + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Implicit_Guard_Signal; + + procedure Translate_Component_Instantiation_Statement (Inst : Iir) + is + Comp : constant Iir := Get_Instantiated_Unit (Inst); + Info : Block_Info_Acc; + Comp_Info : Comp_Info_Acc; + + Mark2 : Id_Mark_Type; + Assoc, Conv, In_Type : Iir; + Has_Conv_Record : Boolean := False; + begin + Info := Add_Info (Inst, Kind_Block); + + if Is_Component_Instantiation (Inst) then + -- Via a component declaration. + Comp_Info := Get_Info (Get_Named_Entity (Comp)); + Info.Block_Link_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inst), + Get_Scope_Type (Comp_Info.Comp_Scope)); + else + -- Direct instantiation. + Info.Block_Link_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Inst), + Rtis.Ghdl_Component_Link_Type); + end if; + + -- When conversions are used, the subtype of the actual (or of the + -- formal for out conversions) may not be yet translated. This + -- can happen if the name is a slice. + -- We need to translate it and create variables in the instance + -- because it will be referenced by the conversion subprogram. + Assoc := Get_Port_Map_Aspect_Chain (Inst); + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) = Iir_Kind_Association_Element_By_Expression + then + Conv := Get_In_Conversion (Assoc); + In_Type := Get_Type (Get_Actual (Assoc)); + if Conv /= Null_Iir + and then Is_Anonymous_Type_Definition (In_Type) + then + -- Lazy creation of the record. + if not Has_Conv_Record then + Has_Conv_Record := True; + Push_Instance_Factory (Info.Block_Scope'Access); + end if; + + -- FIXME: handle with overload multiple case on the same + -- formal. + Push_Identifier_Prefix + (Mark2, + Get_Identifier (Get_Association_Interface (Assoc))); + Chap3.Translate_Type_Definition (In_Type, True); + Pop_Identifier_Prefix (Mark2); + end if; + end if; + Assoc := Get_Chain (Assoc); + end loop; + if Has_Conv_Record then + Pop_Instance_Factory (Info.Block_Scope'Access); + New_Type_Decl + (Create_Identifier (Get_Identifier (Inst), "__CONVS"), + Get_Scope_Type (Info.Block_Scope)); + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (Get_Identifier (Inst), + "__CONVS"), + Get_Scope_Type (Info.Block_Scope)); + end if; + end Translate_Component_Instantiation_Statement; + + procedure Translate_Process_Declarations (Proc : Iir) + is + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + + Drivers : Iir_List; + Nbr_Drivers : Natural; + Sig : Iir; + begin + Info := Add_Info (Proc, Kind_Process); + + -- Create process record. + Push_Identifier_Prefix (Mark, Get_Identifier (Proc)); + Push_Instance_Factory (Info.Process_Scope'Access); + Chap4.Translate_Declaration_Chain (Proc); + + if Flag_Direct_Drivers then + -- Create direct drivers. + Drivers := Trans_Analyzes.Extract_Drivers (Proc); + if Flag_Dump_Drivers then + Trans_Analyzes.Dump_Drivers (Proc, Drivers); + end if; + + Nbr_Drivers := Get_Nbr_Elements (Drivers); + Info.Process_Drivers := new Direct_Driver_Arr (1 .. Nbr_Drivers); + for I in 1 .. Nbr_Drivers loop + Sig := Get_Nth_Element (Drivers, I - 1); + Info.Process_Drivers (I) := (Sig => Sig, Var => Null_Var); + Sig := Get_Object_Prefix (Sig); + if Get_Kind (Sig) /= Iir_Kind_Object_Alias_Declaration + and then not Get_After_Drivers_Flag (Sig) + then + Info.Process_Drivers (I).Var := + Create_Var (Create_Var_Identifier (Sig, "_DDRV", I), + Chap4.Get_Object_Type + (Get_Info (Get_Type (Sig)), Mode_Value)); + + -- Do not create driver severals times. + Set_After_Drivers_Flag (Sig, True); + end if; + end loop; + Trans_Analyzes.Free_Drivers_List (Drivers); + end if; + Pop_Instance_Factory (Info.Process_Scope'Access); + New_Type_Decl (Create_Identifier ("INSTTYPE"), + Get_Scope_Type (Info.Process_Scope)); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Add_Scope_Field (Create_Identifier_Without_Prefix (Proc), + Info.Process_Scope); + end Translate_Process_Declarations; + + procedure Translate_Psl_Directive_Declarations (Stmt : Iir) + is + use PSL.Nodes; + use PSL.NFAs; + + N : constant NFA := Get_PSL_NFA (Stmt); + + Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + begin + Info := Add_Info (Stmt, Kind_Psl_Directive); + + -- Create process record. + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Push_Instance_Factory (Info.Psl_Scope'Access); + + 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); + + if Get_Kind (Stmt) = Iir_Kind_Psl_Cover_Statement then + Info.Psl_Bool_Var := Create_Var + (Create_Var_Identifier ("BOOL"), Ghdl_Bool_Type); + end if; + + Pop_Instance_Factory (Info.Psl_Scope'Access); + New_Type_Decl (Create_Identifier ("INSTTYPE"), + Get_Scope_Type (Info.Psl_Scope)); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Add_Scope_Field + (Create_Identifier_Without_Prefix (Stmt), Info.Psl_Scope); + end Translate_Psl_Directive_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 Create_Psl_Final_Proc + (Stmt : Iir; Base : Block_Info_Acc; Instance : out O_Dnode) + is + Inter_List : O_Inter_List; + Info : constant Psl_Info_Acc := Get_Info (Stmt); + begin + 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); + end Create_Psl_Final_Proc; + + procedure Translate_Psl_Directive_Statement + (Stmt : Iir; Base : Block_Info_Acc) + is + use PSL.NFAs; + Inter_List : O_Inter_List; + Instance : O_Dnode; + Info : constant Psl_Info_Acc := Get_Info (Stmt); + 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 + 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. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + -- New state vector. + New_Var_Decl (Var_Nvec, Wki_Res, O_Storage_Local, Info.Psl_Vect_Type); + + -- For cover directive, return now if already covered. + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Assert_Statement => + null; + when Iir_Kind_Psl_Cover_Statement => + Start_If_Stmt (S_Blk, New_Value (Get_Var (Info.Psl_Bool_Var))); + New_Return_Stmt; + Finish_If_Stmt (S_Blk); + when others => + Error_Kind ("Translate_Psl_Directive_Statement(1)", Stmt); + end case; + + -- 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)))))); + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Assert_Statement => + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Assert_Failed, Severity_Level_Error); + when Iir_Kind_Psl_Cover_Statement => + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Cover, Severity_Level_Note); + New_Assign_Stmt (Get_Var (Info.Psl_Bool_Var), + New_Lit (Ghdl_Bool_True_Node)); + when others => + Error_Kind ("Translate_Psl_Directive_Statement", Stmt); + end case; + 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); + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + + -- The finalizer. + case Get_Kind (Stmt) is + when Iir_Kind_Psl_Assert_Statement => + if Psl_Need_Finalizer (NFA) then + Create_Psl_Final_Proc (Stmt, Base, Instance); + + Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, 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; + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + else + Info.Psl_Proc_Final_Subprg := O_Dnode_Null; + end if; + + when Iir_Kind_Psl_Cover_Statement => + Create_Psl_Final_Proc (Stmt, Base, Instance); + + Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); + Push_Local_Factory; + -- Push scope for architecture declarations. + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + Start_If_Stmt + (S_Blk, + New_Monadic_Op (ON_Not, + New_Value (Get_Var (Info.Psl_Bool_Var)))); + Chap8.Translate_Report + (Stmt, Ghdl_Psl_Cover_Failed, Severity_Level_Error); + Finish_If_Stmt (S_Blk); + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + + when others => + Error_Kind ("Translate_Psl_Directive_Statement(3)", Stmt); + end case; + end Translate_Psl_Directive_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) + is + El : Iir; + begin + Chap4.Translate_Declaration_Chain (Block); + + El := Get_Concurrent_Statement_Chain (Block); + while El /= Null_Iir loop + case Get_Kind (El) 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 + | Iir_Kind_Psl_Cover_Statement => + Translate_Psl_Directive_Declarations (El); + when Iir_Kind_Component_Instantiation_Statement => + Translate_Component_Instantiation_Statement (El); + when Iir_Kind_Block_Statement => + declare + Info : Block_Info_Acc; + Hdr : Iir_Block_Header; + Guard : Iir; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + + Info := Add_Info (El, Kind_Block); + Chap1.Start_Block_Decl (El); + Push_Instance_Factory (Info.Block_Scope'Access); + + Guard := Get_Guard_Decl (El); + if Guard /= Null_Iir then + Chap4.Translate_Declaration (Guard); + end if; + + -- generics, ports. + Hdr := Get_Block_Header (El); + if Hdr /= Null_Iir then + Chap4.Translate_Generic_Chain (Hdr); + Chap4.Translate_Port_Chain (Hdr); + end if; + + Chap9.Translate_Block_Declarations (El, Origin); + + Pop_Instance_Factory (Info.Block_Scope'Access); + Pop_Identifier_Prefix (Mark); + + -- Create a field in the parent record. + Add_Scope_Field + (Create_Identifier_Without_Prefix (El), + Info.Block_Scope); + end; + when Iir_Kind_Generate_Statement => + declare + Scheme : constant Iir := Get_Generation_Scheme (El); + Info : Block_Info_Acc; + Mark : Id_Mark_Type; + Iter_Type : Iir; + It_Info : Ortho_Info_Acc; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Iter_Type := Get_Type (Scheme); + Chap3.Translate_Object_Subtype (Scheme, True); + end if; + + Info := Add_Info (El, Kind_Block); + Chap1.Start_Block_Decl (El); + Push_Instance_Factory (Info.Block_Scope'Access); + + -- Add a parent field in the current instance. + Info.Block_Origin_Field := Add_Instance_Factory_Field + (Get_Identifier ("ORIGIN"), + Get_Info (Origin).Block_Decls_Ptr_Type); + + -- Iterator. + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Info.Block_Configured_Field := + Add_Instance_Factory_Field + (Get_Identifier ("CONFIGURED"), Ghdl_Bool_Type); + It_Info := Add_Info (Scheme, Kind_Iterator); + It_Info.Iterator_Var := Create_Var + (Create_Var_Identifier (Scheme), + Get_Info (Get_Base_Type (Iter_Type)).Ortho_Type + (Mode_Value)); + end if; + + Chap9.Translate_Block_Declarations (El, El); + + Pop_Instance_Factory (Info.Block_Scope'Access); + + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + -- Create array type of block_decls_type + Info.Block_Decls_Array_Type := New_Array_Type + (Get_Scope_Type (Info.Block_Scope), Ghdl_Index_Type); + New_Type_Decl (Create_Identifier ("INSTARRTYPE"), + Info.Block_Decls_Array_Type); + -- Create access to the array type. + Info.Block_Decls_Array_Ptr_Type := New_Access_Type + (Info.Block_Decls_Array_Type); + New_Type_Decl (Create_Identifier ("INSTARRPTR"), + Info.Block_Decls_Array_Ptr_Type); + -- Add a field in parent record + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (El), + Info.Block_Decls_Array_Ptr_Type); + else + -- Create an access field in the parent record. + Info.Block_Parent_Field := Add_Instance_Factory_Field + (Create_Identifier_Without_Prefix (El), + Info.Block_Decls_Ptr_Type); + end if; + + Pop_Identifier_Prefix (Mark); + end; + when others => + Error_Kind ("translate_block_declarations", El); + end case; + El := Get_Chain (El); + end loop; + end Translate_Block_Declarations; + + procedure Translate_Component_Instantiation_Subprogram + (Stmt : Iir; Base : Block_Info_Acc) + is + procedure Set_Component_Link (Ref_Scope : Var_Scope_Type; + Comp_Field : O_Fnode) + is + begin + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Comp_Field), + Rtis.Ghdl_Component_Link_Stmt), + New_Lit (Rtis.Get_Context_Rti (Stmt))); + end Set_Component_Link; + + Info : constant Block_Info_Acc := Get_Info (Stmt); + + Parent : constant Iir := Get_Parent (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); + + Comp : Iir; + Comp_Info : Comp_Info_Acc; + Inter_List : O_Inter_List; + Instance : O_Dnode; + begin + -- Create the elaborator for the instantiation. + Start_Procedure_Decl (Inter_List, Create_Identifier ("ELAB"), + O_Storage_Private); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Base.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Info.Block_Elab_Subprg); + + Start_Subprogram_Body (Info.Block_Elab_Subprg); + Push_Local_Factory; + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); + + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + + -- Add access to the instantiation-specific data. + -- This is used only for anonymous subtype variables. + if Has_Scope_Type (Info.Block_Scope) then + Set_Scope_Via_Field (Info.Block_Scope, + Info.Block_Parent_Field, + Parent_Info.Block_Scope'Access); + end if; + + Comp := Get_Instantiated_Unit (Stmt); + if Is_Entity_Instantiation (Stmt) then + -- This is a direct instantiation. + Set_Component_Link (Parent_Info.Block_Scope, + Info.Block_Link_Field); + Translate_Entity_Instantiation (Comp, Stmt, Stmt, Null_Iir); + else + Comp := Get_Named_Entity (Comp); + Comp_Info := Get_Info (Comp); + Set_Scope_Via_Field (Comp_Info.Comp_Scope, + Info.Block_Link_Field, + Parent_Info.Block_Scope'Access); + + -- Set the link from component declaration to component + -- instantiation statement. + Set_Component_Link (Comp_Info.Comp_Scope, Comp_Info.Comp_Link); + + Chap5.Elab_Map_Aspect (Stmt, Comp); + + Clear_Scope (Comp_Info.Comp_Scope); + end if; + + if Has_Scope_Type (Info.Block_Scope) then + Clear_Scope (Info.Block_Scope); + end if; + + Clear_Scope (Base.Block_Scope); + Pop_Local_Factory; + Finish_Subprogram_Body; + end Translate_Component_Instantiation_Subprogram; + + -- Translate concurrent statements into subprograms. + procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir) + is + Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Stmt : Iir; + Mark : Id_Mark_Type; + begin + Chap4.Translate_Declaration_Chain_Subprograms (Block); + + Stmt := Get_Concurrent_Statement_Chain (Block); + while Stmt /= Null_Iir loop + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + case Get_Kind (Stmt) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + if Flag_Direct_Drivers then + Chap9.Set_Direct_Drivers (Stmt); + end if; + + Chap4.Translate_Declaration_Chain_Subprograms (Stmt); + Translate_Process_Statement (Stmt, Base_Info); + + if Flag_Direct_Drivers then + Chap9.Reset_Direct_Drivers (Stmt); + end if; + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Translate_Psl_Directive_Statement (Stmt, Base_Info); + when Iir_Kind_Component_Instantiation_Statement => + Chap4.Translate_Association_Subprograms + (Stmt, Block, Base_Block, + Get_Entity_From_Entity_Aspect + (Get_Instantiated_Unit (Stmt))); + Translate_Component_Instantiation_Subprogram + (Stmt, Base_Info); + when Iir_Kind_Block_Statement => + declare + Guard : constant Iir := Get_Guard_Decl (Stmt); + Hdr : constant Iir := Get_Block_Header (Stmt); + begin + if Guard /= Null_Iir then + Translate_Implicit_Guard_Signal (Guard, Base_Info); + end if; + if Hdr /= Null_Iir then + Chap4.Translate_Association_Subprograms + (Hdr, Block, Base_Block, Null_Iir); + end if; + Translate_Block_Subprograms (Stmt, Base_Block); + end; + when Iir_Kind_Generate_Statement => + declare + Info : constant Block_Info_Acc := Get_Info (Stmt); + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, + Info.Block_Decls_Ptr_Type, + Wki_Instance, + Prev_Subprg_Instance); + Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, + Info.Block_Origin_Field, + Info.Block_Scope'Access); + Translate_Block_Subprograms (Stmt, Stmt); + Clear_Scope (Base_Info.Block_Scope); + Chap2.Pop_Subprg_Instance + (Wki_Instance, Prev_Subprg_Instance); + end; + when others => + Error_Kind ("translate_block_subprograms", Stmt); + end case; + Pop_Identifier_Prefix (Mark); + Stmt := Get_Chain (Stmt); + end loop; + end Translate_Block_Subprograms; + + -- Remove anonymous and implicit type definitions in a list of names. + -- Such type definitions are created during slice translations, however + -- variables created are defined in the translation scope. + -- If the type is referenced again, the variables must be reachable. + -- This is not the case for elaborator subprogram (which may references + -- slices in the sensitivity or driver list) and the process subprg. + procedure Destroy_Types_In_Name (Name : Iir) + is + El : Iir; + Atype : Iir; + Info : Type_Info_Acc; + begin + El := Name; + loop + Atype := Null_Iir; + case Get_Kind (El) is + when Iir_Kind_Selected_Element + | Iir_Kind_Indexed_Name => + El := Get_Prefix (El); + when Iir_Kind_Slice_Name => + Atype := Get_Type (El); + El := Get_Prefix (El); + when Iir_Kind_Object_Alias_Declaration => + El := Get_Name (El); + when Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute + | Iir_Kind_Transaction_Attribute => + El := Get_Prefix (El); + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration => + exit; + when Iir_Kinds_Denoting_Name => + El := Get_Named_Entity (El); + when others => + Error_Kind ("destroy_types_in_name", El); + end case; + if Atype /= Null_Iir + and then Is_Anonymous_Type_Definition (Atype) + then + Info := Get_Info (Atype); + if Info /= null then + Free_Type_Info (Info); + Clear_Info (Atype); + end if; + end if; + end loop; + end Destroy_Types_In_Name; + + procedure Destroy_Types_In_List (List : Iir_List) + is + El : Iir; + begin + if List = Null_Iir_List then + return; + end if; + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + Destroy_Types_In_Name (El); + end loop; + end Destroy_Types_In_List; + + procedure Gen_Register_Direct_Driver_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Drv : Mnode) + is + pragma Unreferenced (Targ_Type); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver); + New_Association + (Constr, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr)); + New_Association + (Constr, New_Unchecked_Address (M2Lv (Drv), Ghdl_Ptr_Type)); + New_Procedure_Call (Constr); + end Gen_Register_Direct_Driver_Non_Composite; + + function Gen_Register_Direct_Driver_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Val : Mnode) + return Mnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Val; + end Gen_Register_Direct_Driver_Prepare_Data_Composite; + + function Gen_Register_Direct_Driver_Prepare_Data_Record + (Targ : Mnode; Targ_Type : Iir; Val : Mnode) + return Mnode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Stabilize (Val); + end Gen_Register_Direct_Driver_Prepare_Data_Record; + + function Gen_Register_Direct_Driver_Update_Data_Array + (Val : Mnode; Targ_Type : Iir; Index : O_Dnode) + return Mnode + is + begin + return Chap3.Index_Base (Chap3.Get_Array_Base (Val), + Targ_Type, New_Obj_Value (Index)); + end Gen_Register_Direct_Driver_Update_Data_Array; + + function Gen_Register_Direct_Driver_Update_Data_Record + (Val : Mnode; Targ_Type : Iir; El : Iir_Element_Declaration) + return Mnode + is + pragma Unreferenced (Targ_Type); + begin + return Chap6.Translate_Selected_Element (Val, El); + end Gen_Register_Direct_Driver_Update_Data_Record; + + procedure Gen_Register_Direct_Driver_Finish_Data_Composite + (Data : in out Mnode) + is + pragma Unreferenced (Data); + begin + null; + end Gen_Register_Direct_Driver_Finish_Data_Composite; + + procedure Gen_Register_Direct_Driver is new Foreach_Non_Composite + (Data_Type => Mnode, + Composite_Data_Type => Mnode, + Do_Non_Composite => Gen_Register_Direct_Driver_Non_Composite, + Prepare_Data_Array => + Gen_Register_Direct_Driver_Prepare_Data_Composite, + Update_Data_Array => Gen_Register_Direct_Driver_Update_Data_Array, + Finish_Data_Array => Gen_Register_Direct_Driver_Finish_Data_Composite, + Prepare_Data_Record => Gen_Register_Direct_Driver_Prepare_Data_Record, + Update_Data_Record => Gen_Register_Direct_Driver_Update_Data_Record, + Finish_Data_Record => + Gen_Register_Direct_Driver_Finish_Data_Composite); + +-- procedure Register_Scalar_Direct_Driver (Sig : Mnode; +-- Sig_Type : Iir; +-- Drv : Mnode) +-- is +-- pragma Unreferenced (Sig_Type); +-- Constr : O_Assoc_List; +-- begin +-- Start_Association (Constr, Ghdl_Signal_Add_Direct_Driver); +-- New_Association +-- (Constr, New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); +-- New_Association +-- (Constr, New_Unchecked_Address (M2Lv (Drv), Ghdl_Ptr_Type)); +-- New_Procedure_Call (Constr); +-- end Register_Scalar_Direct_Driver; + + -- PROC: the process to be elaborated + -- BASE_INFO: info for the global block + procedure Elab_Process (Proc : Iir; Base_Info : Block_Info_Acc) + is + Info : constant Proc_Info_Acc := Get_Info (Proc); + Is_Sensitized : constant Boolean := + Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement; + Subprg : O_Dnode; + Constr : O_Assoc_List; + List : Iir_List; + List_Orig : Iir_List; + Final : Boolean; + begin + New_Debug_Line_Stmt (Get_Line_Number (Proc)); + + -- Register process. + if Is_Sensitized then + if Get_Postponed_Flag (Proc) then + Subprg := Ghdl_Postponed_Sensitized_Process_Register; + else + Subprg := Ghdl_Sensitized_Process_Register; + end if; + else + if Get_Postponed_Flag (Proc) then + Subprg := Ghdl_Postponed_Process_Register; + else + Subprg := Ghdl_Process_Register; + end if; + end if; + + Start_Association (Constr, Subprg); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Process_Subprg, + Ghdl_Ptr_Type))); + Rtis.Associate_Rti_Context (Constr, Proc); + New_Procedure_Call (Constr); + + -- First elaborate declarations since a driver may depend on + -- an alias declaration. + -- Also, with vhdl 08 a sensitivity element may depend on an alias. + Open_Temp; + Chap4.Elab_Declaration_Chain (Proc, Final); + Close_Temp; + + -- Register drivers. + if Flag_Direct_Drivers then + Chap9.Set_Direct_Drivers (Proc); + + declare + Sig : Iir; + Base : Iir; + Sig_Node, Drv_Node : Mnode; + begin + for I in Info.Process_Drivers.all'Range loop + Sig := Info.Process_Drivers (I).Sig; + Open_Temp; + Base := Get_Object_Prefix (Sig); + if Info.Process_Drivers (I).Var /= Null_Var then + -- Elaborate direct driver. Done only once. + Chap4.Elab_Direct_Driver_Declaration_Storage (Base); + end if; + if Chap4.Has_Direct_Driver (Base) then + -- Signal has a direct driver. + Chap6.Translate_Direct_Driver (Sig, Sig_Node, Drv_Node); + Gen_Register_Direct_Driver + (Sig_Node, Get_Type (Sig), Drv_Node); + else + Register_Signal (Chap6.Translate_Name (Sig), + Get_Type (Sig), + Ghdl_Process_Add_Driver); + end if; + Close_Temp; + end loop; + end; + + Chap9.Reset_Direct_Drivers (Proc); + else + List := Trans_Analyzes.Extract_Drivers (Proc); + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Driver); + if Flag_Dump_Drivers then + Trans_Analyzes.Dump_Drivers (Proc, List); + end if; + Trans_Analyzes.Free_Drivers_List (List); + end if; + + if Is_Sensitized then + List_Orig := Get_Sensitivity_List (Proc); + if List_Orig = Iir_List_All then + List := Canon.Canon_Extract_Process_Sensitivity (Proc); + else + List := List_Orig; + end if; + Destroy_Types_In_List (List); + Register_Signal_List (List, Ghdl_Process_Add_Sensitivity); + if List_Orig = Iir_List_All then + Destroy_Iir_List (List); + end if; + end if; + end Elab_Process; + + -- PROC: the process to be elaborated + -- BLOCK: the block containing the process (its parent) + -- BASE_INFO: info for the global block + procedure Elab_Psl_Directive (Stmt : Iir; + Base_Info : Block_Info_Acc) + is + Info : constant Psl_Info_Acc := Get_Info (Stmt); + Constr : O_Assoc_List; + List : Iir_List; + Clk : PSL_Node; + Var_I : O_Dnode; + Label : O_Snode; + begin + New_Debug_Line_Stmt (Get_Line_Number (Stmt)); + + -- Register process. + Start_Association (Constr, Ghdl_Sensitized_Process_Register); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Base_Info.Block_Scope), 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_Scope), + 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; + + if Info.Psl_Bool_Var /= Null_Var then + New_Assign_Stmt (Get_Var (Info.Psl_Bool_Var), + New_Lit (Ghdl_Bool_False_Node)); + end if; + end Elab_Psl_Directive; + + procedure Elab_Implicit_Guard_Signal + (Block : Iir_Block_Statement; Block_Info : Block_Info_Acc) + is + Guard : Iir; + Type_Info : Type_Info_Acc; + Info : Object_Info_Acc; + Constr : O_Assoc_List; + begin + -- Create the guard signal. + Guard := Get_Guard_Decl (Block); + Info := Get_Info (Guard); + Type_Info := Get_Info (Get_Type (Guard)); + Start_Association (Constr, Ghdl_Signal_Create_Guard); + New_Association + (Constr, New_Unchecked_Address + (Get_Instance_Ref (Block_Info.Block_Scope), Ghdl_Ptr_Type)); + New_Association + (Constr, + New_Lit (New_Subprogram_Address (Info.Object_Function, + Ghdl_Ptr_Type))); +-- New_Association (Constr, Chap6.Get_Instance_Name_Ref (Block)); + New_Assign_Stmt (Get_Var (Info.Object_Var), + New_Convert_Ov (New_Function_Call (Constr), + Type_Info.Ortho_Type (Mode_Signal))); + + -- Register sensitivity list of the guard signal. + Register_Signal_List (Get_Guard_Sensitivity_List (Guard), + Ghdl_Signal_Guard_Dependence); + end Elab_Implicit_Guard_Signal; + + procedure Translate_Entity_Instantiation + (Aspect : Iir; Mapping : Iir; Parent : Iir; Config_Override : Iir) + is + Entity_Unit : Iir_Design_Unit; + Config : Iir; + Arch : Iir; + Entity : Iir_Entity_Declaration; + Entity_Info : Block_Info_Acc; + Arch_Info : Block_Info_Acc; + + Instance_Size : O_Dnode; + Arch_Elab : O_Dnode; + Arch_Config : O_Dnode; + Arch_Config_Type : O_Tnode; + + Var_Sub : O_Dnode; + begin + -- Extract entity, architecture and configuration from + -- binding aspect. + case Get_Kind (Aspect) is + when Iir_Kind_Entity_Aspect_Entity => + Entity := Get_Entity (Aspect); + Arch := Get_Architecture (Aspect); + if Flags.Flag_Elaborate and then Arch = Null_Iir then + -- This is valid only during elaboration. + Arch := Libraries.Get_Latest_Architecture (Entity); + end if; + Config := Null_Iir; + when Iir_Kind_Entity_Aspect_Configuration => + Config := Get_Configuration (Aspect); + Entity := Get_Entity (Config); + Arch := Get_Block_Specification + (Get_Block_Configuration (Config)); + when Iir_Kind_Entity_Aspect_Open => + return; + when others => + Error_Kind ("translate_entity_instantiation", Aspect); + end case; + Entity_Unit := Get_Design_Unit (Entity); + Entity_Info := Get_Info (Entity); + if Config_Override /= Null_Iir then + Config := Config_Override; + if Get_Kind (Arch) = Iir_Kind_Simple_Name then + Arch := Get_Block_Specification + (Get_Block_Configuration (Config)); + end if; + end if; + + -- 1) Create instance for the arch + if Arch /= Null_Iir then + Arch_Info := Get_Info (Arch); + if Config = Null_Iir + and then Get_Kind (Arch) = Iir_Kind_Architecture_Body + then + Config := Get_Default_Configuration_Declaration (Arch); + if Config /= Null_Iir then + Config := Get_Library_Unit (Config); + end if; + end if; + else + Arch_Info := null; + end if; + if Arch_Info = null or Config = Null_Iir then + declare + function Get_Arch_Name return String is + begin + if Arch /= Null_Iir then + return "ARCH__" & Image_Identifier (Arch); + else + return "LASTARCH"; + end if; + end Get_Arch_Name; + + Str : constant String := + Image_Identifier (Get_Library (Get_Design_File (Entity_Unit))) + & "__" & Image_Identifier (Entity) & "__" + & Get_Arch_Name & "__"; + Sub_Inter : O_Inter_List; + Arg : O_Dnode; + begin + if Arch_Info = null then + New_Const_Decl + (Instance_Size, Get_Identifier (Str & "INSTSIZE"), + O_Storage_External, Ghdl_Index_Type); + + Start_Procedure_Decl + (Sub_Inter, Get_Identifier (Str & "ELAB"), + O_Storage_External); + New_Interface_Decl (Sub_Inter, Arg, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Sub_Inter, Arch_Elab); + end if; + + if Config = Null_Iir then + Start_Procedure_Decl + (Sub_Inter, Get_Identifier (Str & "DEFAULT_CONFIG"), + O_Storage_External); + New_Interface_Decl (Sub_Inter, Arg, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Sub_Inter, Arch_Config); + + Arch_Config_Type := Entity_Info.Block_Decls_Ptr_Type; + end if; + end; + end if; + + if Arch_Info = null then + if Config /= Null_Iir then + -- Architecture is unknown, but we know how to configure + -- the block inside it. + raise Internal_Error; + end if; + else + Instance_Size := Arch_Info.Block_Instance_Size; + Arch_Elab := Arch_Info.Block_Elab_Subprg; + if Config /= Null_Iir then + Arch_Config := Get_Info (Config).Config_Subprg; + Arch_Config_Type := Arch_Info.Block_Decls_Ptr_Type; + end if; + end if; + + -- Create the instance variable and allocate storage. + New_Var_Decl (Var_Sub, Get_Identifier ("SUB_INSTANCE"), + O_Storage_Local, Entity_Info.Block_Decls_Ptr_Type); + + New_Assign_Stmt + (New_Obj (Var_Sub), + Gen_Alloc (Alloc_System, New_Obj_Value (Instance_Size), + Entity_Info.Block_Decls_Ptr_Type)); + + -- 1.5) link instance. + declare + procedure Set_Links (Ref_Scope : Var_Scope_Type; + Link_Field : O_Fnode) + is + begin + -- Set the ghdl_component_link_instance field. + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Link_Field), + Rtis.Ghdl_Component_Link_Instance), + New_Address (New_Selected_Acc_Value + (New_Obj (Var_Sub), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Acc)); + -- Set the ghdl_entity_link_parent field. + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Acc_Value (New_Obj (Var_Sub), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Parent), + New_Address + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Link_Field), + Rtis.Ghdl_Component_Link_Acc)); + end Set_Links; + begin + case Get_Kind (Parent) is + when Iir_Kind_Component_Declaration => + -- Instantiation via a component declaration. + declare + Comp_Info : constant Comp_Info_Acc := Get_Info (Parent); + begin + Set_Links (Comp_Info.Comp_Scope, Comp_Info.Comp_Link); + end; + when Iir_Kind_Component_Instantiation_Statement => + -- Direct instantiation. + declare + Parent_Info : constant Block_Info_Acc := + Get_Info (Get_Parent (Parent)); + begin + Set_Links (Parent_Info.Block_Scope, + Get_Info (Parent).Block_Link_Field); + end; + when others => + Error_Kind ("translate_entity_instantiation(1)", Parent); + end case; + end; + + -- Elab entity packages. + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Entity_Info.Block_Elab_Pkg_Subprg); + New_Procedure_Call (Assoc); + end; + + -- Elab map aspects. + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Var_Sub); + Chap5.Elab_Map_Aspect (Mapping, Entity); + Clear_Scope (Entity_Info.Block_Scope); + + -- 3) Elab instance. + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Arch_Elab); + New_Association (Assoc, New_Obj_Value (Var_Sub)); + New_Procedure_Call (Assoc); + end; + + -- 5) Configure + declare + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Arch_Config); + New_Association (Assoc, New_Convert_Ov (New_Obj_Value (Var_Sub), + Arch_Config_Type)); + New_Procedure_Call (Assoc); + end; + end Translate_Entity_Instantiation; + + procedure Elab_Conditionnal_Generate_Statement + (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) + is + Scheme : constant Iir := Get_Generation_Scheme (Stmt); + Info : constant Block_Info_Acc := Get_Info (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); + Var : O_Dnode; + Blk : O_If_Block; + V : O_Lnode; + begin + Open_Temp; + + Var := Create_Temp (Info.Block_Decls_Ptr_Type); + Start_If_Stmt (Blk, Chap7.Translate_Expression (Scheme)); + New_Assign_Stmt + (New_Obj (Var), + Gen_Alloc (Alloc_System, + New_Lit (Get_Scope_Size (Info.Block_Scope)), + Info.Block_Decls_Ptr_Type)); + New_Else_Stmt (Blk); + New_Assign_Stmt + (New_Obj (Var), + New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type))); + Finish_If_Stmt (Blk); + + -- Add a link to child in parent. + V := Get_Instance_Ref (Parent_Info.Block_Scope); + V := New_Selected_Element (V, Info.Block_Parent_Field); + New_Assign_Stmt (V, New_Obj_Value (Var)); + + Start_If_Stmt + (Blk, + New_Compare_Op + (ON_Neq, + New_Obj_Value (Var), + New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)), + Ghdl_Bool_Type)); + -- Add a link to parent in child. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), + Get_Instance_Access (Base_Block)); + -- Elaborate block + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + Elab_Block_Declarations (Stmt, Stmt); + Clear_Scope (Info.Block_Scope); + Finish_If_Stmt (Blk); + Close_Temp; + end Elab_Conditionnal_Generate_Statement; + + procedure Elab_Iterative_Generate_Statement + (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) + is + Scheme : constant Iir := Get_Generation_Scheme (Stmt); + Iter_Type : constant Iir := Get_Type (Scheme); + Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); + Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); + Info : constant Block_Info_Acc := Get_Info (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); +-- Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Var_Inst : O_Dnode; + Var_I : O_Dnode; + Label : O_Snode; + V : O_Lnode; + Var : O_Dnode; + Range_Ptr : O_Dnode; + begin + Open_Temp; + + -- Evaluate iterator range. + Chap3.Elab_Object_Subtype (Iter_Type); + + Range_Ptr := Create_Temp_Ptr + (Iter_Type_Info.T.Range_Ptr_Type, + Get_Var (Get_Info (Iter_Type).T.Range_Var)); + + -- Allocate instances. + Var_Inst := Create_Temp (Info.Block_Decls_Array_Ptr_Type); + New_Assign_Stmt + (New_Obj (Var_Inst), + Gen_Alloc + (Alloc_System, + New_Dyadic_Op (ON_Mul_Ov, + New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Length), + New_Lit (Get_Scope_Size (Info.Block_Scope))), + Info.Block_Decls_Array_Ptr_Type)); + + -- Add a link to child in parent. + V := Get_Instance_Ref (Parent_Info.Block_Scope); + V := New_Selected_Element (V, Info.Block_Parent_Field); + New_Assign_Stmt (V, New_Obj_Value (Var_Inst)); + + -- Start loop. + Var_I := Create_Temp (Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op (ON_Eq, + New_Obj_Value (Var_I), + New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Length), + Ghdl_Bool_Type)); + + Var := Create_Temp_Ptr + (Info.Block_Decls_Ptr_Type, + New_Indexed_Element (New_Acc_Value (New_Obj (Var_Inst)), + New_Obj_Value (Var_I))); + -- Add a link to parent in child. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), + Get_Instance_Access (Base_Block)); + -- Mark the block as not (yet) configured. + New_Assign_Stmt + (New_Selected_Acc_Value (New_Obj (Var), + Info.Block_Configured_Field), + New_Lit (Ghdl_Bool_False_Node)); + + -- Elaborate block + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + -- Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, + -- Info.Block_Origin_Field, + -- Info.Block_Scope'Access); + + -- Set iterator value. + -- FIXME: this could be slighly optimized... + declare + Val : O_Dnode; + If_Blk : O_If_Block; + begin + Val := Create_Temp (Iter_Type_Info.Ortho_Type (Mode_Value)); + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Eq, + New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Dir), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Val), New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Left)); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Val), New_Value_Selected_Acc_Value + (New_Obj (Range_Ptr), + Iter_Type_Info.T.Range_Right)); + Finish_If_Stmt (If_Blk); + + New_Assign_Stmt + (Get_Var (Get_Info (Scheme).Iterator_Var), + New_Dyadic_Op + (ON_Add_Ov, + New_Obj_Value (Val), + New_Convert_Ov (New_Obj_Value (Var_I), + Iter_Type_Info.Ortho_Type (Mode_Value)))); + end; + + -- Elaboration. + Elab_Block_Declarations (Stmt, Stmt); + +-- Clear_Scope (Base_Info.Block_Scope); + Clear_Scope (Info.Block_Scope); + + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Close_Temp; + end Elab_Iterative_Generate_Statement; + + type Merge_Signals_Data is record + Sig : Iir; + Set_Init : Boolean; + Has_Val : Boolean; + Val : Mnode; + end record; + + procedure Merge_Signals_Rti_Non_Composite (Targ : Mnode; + Targ_Type : Iir; + Data : Merge_Signals_Data) + is + Type_Info : Type_Info_Acc; + Sig : Mnode; + + Init_Subprg : O_Dnode; + Conv : O_Tnode; + Assoc : O_Assoc_List; + Init_Val : O_Enode; + begin + Type_Info := Get_Info (Targ_Type); + + Open_Temp; + + if Data.Set_Init then + case Type_Info.Type_Mode is + when Type_Mode_B1 => + Init_Subprg := Ghdl_Signal_Init_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Init_Subprg := Ghdl_Signal_Init_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Init_Subprg := Ghdl_Signal_Init_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 + | Type_Mode_P32 => + Init_Subprg := Ghdl_Signal_Init_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 + | Type_Mode_I64 => + Init_Subprg := Ghdl_Signal_Init_I64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Init_Subprg := Ghdl_Signal_Init_F64; + Conv := Ghdl_Real_Type; + when others => + Error_Kind ("merge_signals_rti_non_composite", Targ_Type); + end case; + + Sig := Stabilize (Targ, True); + + -- Init the signal. + Start_Association (Assoc, Init_Subprg); + New_Association + (Assoc, + New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); + if Data.Has_Val then + Init_Val := M2E (Data.Val); + else + Init_Val := Chap14.Translate_Left_Type_Attribute (Targ_Type); + end if; + New_Association (Assoc, New_Convert_Ov (Init_Val, Conv)); + New_Procedure_Call (Assoc); + else + Sig := Targ; + end if; + + Start_Association (Assoc, Ghdl_Signal_Merge_Rti); + + New_Association + (Assoc, New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr)); + New_Association + (Assoc, + New_Lit (New_Global_Unchecked_Address + (Get_Info (Data.Sig).Object_Rti, + Rtis.Ghdl_Rti_Access))); + New_Procedure_Call (Assoc); + Close_Temp; + end Merge_Signals_Rti_Non_Composite; + + function Merge_Signals_Rti_Prepare (Targ : Mnode; + Targ_Type : Iir; + Data : Merge_Signals_Data) + return Merge_Signals_Data + is + pragma Unreferenced (Targ); + pragma Unreferenced (Targ_Type); + Res : Merge_Signals_Data; + begin + Res := Data; + if Data.Has_Val then + if Get_Type_Info (Data.Val).Type_Mode = Type_Mode_Record then + Res.Val := Stabilize (Data.Val); + else + Res.Val := Chap3.Get_Array_Base (Data.Val); + end if; + end if; + + return Res; + end Merge_Signals_Rti_Prepare; + + function Merge_Signals_Rti_Update_Data_Array + (Data : Merge_Signals_Data; Targ_Type : Iir; Index : O_Dnode) + return Merge_Signals_Data + is + begin + if not Data.Has_Val then + return Data; + else + return Merge_Signals_Data' + (Sig => Data.Sig, + Val => Chap3.Index_Base (Data.Val, Targ_Type, + New_Obj_Value (Index)), + Has_Val => True, + Set_Init => Data.Set_Init); + end if; + end Merge_Signals_Rti_Update_Data_Array; + + procedure Merge_Signals_Rti_Finish_Data_Composite + (Data : in out Merge_Signals_Data) + is + pragma Unreferenced (Data); + begin + null; + end Merge_Signals_Rti_Finish_Data_Composite; + + function Merge_Signals_Rti_Update_Data_Record + (Data : Merge_Signals_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) return Merge_Signals_Data + is + pragma Unreferenced (Targ_Type); + begin + if not Data.Has_Val then + return Data; + else + return Merge_Signals_Data' + (Sig => Data.Sig, + Val => Chap6.Translate_Selected_Element (Data.Val, El), + Has_Val => True, + Set_Init => Data.Set_Init); + end if; + end Merge_Signals_Rti_Update_Data_Record; + + pragma Inline (Merge_Signals_Rti_Finish_Data_Composite); + + procedure Merge_Signals_Rti is new Foreach_Non_Composite + (Data_Type => Merge_Signals_Data, + Composite_Data_Type => Merge_Signals_Data, + Do_Non_Composite => Merge_Signals_Rti_Non_Composite, + Prepare_Data_Array => Merge_Signals_Rti_Prepare, + Update_Data_Array => Merge_Signals_Rti_Update_Data_Array, + Finish_Data_Array => Merge_Signals_Rti_Finish_Data_Composite, + Prepare_Data_Record => Merge_Signals_Rti_Prepare, + Update_Data_Record => Merge_Signals_Rti_Update_Data_Record, + Finish_Data_Record => Merge_Signals_Rti_Finish_Data_Composite); + + procedure Merge_Signals_Rti_Of_Port_Chain (Chain : Iir) + is + Port : Iir; + Port_Type : Iir; + Data : Merge_Signals_Data; + Val : Iir; + begin + Port := Chain; + while Port /= Null_Iir loop + Port_Type := Get_Type (Port); + Data.Sig := Port; + case Get_Mode (Port) is + when Iir_Buffer_Mode + | Iir_Out_Mode + | Iir_Inout_Mode => + Data.Set_Init := True; + when others => + Data.Set_Init := False; + end case; + + Open_Temp; + Val := Get_Default_Value (Port); + if Val = Null_Iir then + Data.Has_Val := False; + else + Data.Has_Val := True; + Data.Val := E2M (Chap7.Translate_Expression (Val, Port_Type), + Get_Info (Port_Type), + Mode_Value); + end if; + + Merge_Signals_Rti (Chap6.Translate_Name (Port), Port_Type, Data); + Close_Temp; + + Port := Get_Chain (Port); + end loop; + end Merge_Signals_Rti_Of_Port_Chain; + + procedure Elab_Block_Declarations (Block : Iir; Base_Block : Iir) + is + Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); + Stmt : Iir; + Final : Boolean; + begin + New_Debug_Line_Stmt (Get_Line_Number (Block)); + + case Get_Kind (Block) is + when Iir_Kind_Entity_Declaration => + Merge_Signals_Rti_Of_Port_Chain (Get_Port_Chain (Block)); + when Iir_Kind_Architecture_Body => + null; + when Iir_Kind_Block_Statement => + declare + Header : constant Iir_Block_Header := + Get_Block_Header (Block); + Guard : constant Iir := Get_Guard_Decl (Block); + begin + if Guard /= Null_Iir then + New_Debug_Line_Stmt (Get_Line_Number (Guard)); + Elab_Implicit_Guard_Signal (Block, Base_Info); + end if; + if Header /= Null_Iir then + New_Debug_Line_Stmt (Get_Line_Number (Header)); + Chap5.Elab_Map_Aspect (Header, Block); + Merge_Signals_Rti_Of_Port_Chain (Get_Port_Chain (Header)); + end if; + end; + when Iir_Kind_Generate_Statement => + null; + when others => + Error_Kind ("elab_block_declarations", Block); + end case; + + Open_Temp; + Chap4.Elab_Declaration_Chain (Block, Final); + Close_Temp; + + Stmt := Get_Concurrent_Statement_Chain (Block); + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Elab_Process (Stmt, Base_Info); + when Iir_Kind_Psl_Default_Clock => + null; + when Iir_Kind_Psl_Declaration => + null; + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Elab_Psl_Directive (Stmt, Base_Info); + when Iir_Kind_Component_Instantiation_Statement => + declare + Info : constant Block_Info_Acc := Get_Info (Stmt); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Info.Block_Elab_Subprg); + New_Association + (Constr, Get_Instance_Access (Base_Block)); + New_Procedure_Call (Constr); + end; + when Iir_Kind_Block_Statement => + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Elab_Block_Declarations (Stmt, Base_Block); + Pop_Identifier_Prefix (Mark); + end; + when Iir_Kind_Generate_Statement => + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + + if Get_Kind (Get_Generation_Scheme (Stmt)) + = Iir_Kind_Iterator_Declaration + then + Elab_Iterative_Generate_Statement + (Stmt, Block, Base_Block); + else + Elab_Conditionnal_Generate_Statement + (Stmt, Block, Base_Block); + end if; + Pop_Identifier_Prefix (Mark); + end; + when others => + Error_Kind ("elab_block_declarations", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Elab_Block_Declarations; + end Chap9; + + package body Chap10 is + -- Identifiers. + -- The following functions are helpers to create ortho identifiers. + Identifier_Buffer : String (1 .. 512); + Identifier_Len : Natural := 0; + Identifier_Start : Natural := 1; + Identifier_Local : Local_Identifier_Type := 0; + + + Inst_Build : Inst_Build_Acc := null; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Object => Inst_Build_Type, Name => Inst_Build_Acc); + + procedure Set_Global_Storage (Storage : O_Storage) is + begin + Global_Storage := Storage; + end Set_Global_Storage; + + procedure Pop_Build_Instance + is + Old : Inst_Build_Acc; + begin + Old := Inst_Build; + Identifier_Start := Old.Prev_Id_Start; + Inst_Build := Old.Prev; + Unchecked_Deallocation (Old); + end Pop_Build_Instance; + + function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode is + begin + pragma Assert (Scope.Scope_Type /= O_Tnode_Null); + return Scope.Scope_Type; + end Get_Scope_Type; + + function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode is + begin + pragma Assert (Scope.Scope_Type /= O_Tnode_Null); + return New_Sizeof (Scope.Scope_Type, Ghdl_Index_Type); + end Get_Scope_Size; + + function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean is + begin + return Scope.Scope_Type /= O_Tnode_Null; + end Has_Scope_Type; + + procedure Predeclare_Scope_Type (Scope : Var_Scope_Acc; Name : O_Ident) + is + begin + pragma Assert (Scope.Scope_Type = O_Tnode_Null); + New_Uncomplete_Record_Type (Scope.Scope_Type); + New_Type_Decl (Name, Scope.Scope_Type); + end Predeclare_Scope_Type; + + procedure Declare_Scope_Acc + (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode) is + begin + Ptr_Type := New_Access_Type (Get_Scope_Type (Scope)); + New_Type_Decl (Name, Ptr_Type); + end Declare_Scope_Acc; + + procedure Push_Instance_Factory (Scope : Var_Scope_Acc) + is + Inst : Inst_Build_Acc; + begin + if Inst_Build /= null and then Inst_Build.Kind /= Instance then + raise Internal_Error; + end if; + Inst := new Inst_Build_Type (Instance); + Inst.Prev := Inst_Build; + Inst.Prev_Id_Start := Identifier_Start; + Inst.Scope := Scope; + + Identifier_Start := Identifier_Len + 1; + + if Scope.Scope_Type /= O_Tnode_Null then + Start_Uncomplete_Record_Type (Scope.Scope_Type, Inst.Elements); + else + Start_Record_Type (Inst.Elements); + end if; + Inst_Build := Inst; + end Push_Instance_Factory; + + function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) + return O_Fnode + is + Res : O_Fnode; + begin + New_Record_Field (Inst_Build.Elements, Res, Name, Ftype); + return Res; + end Add_Instance_Factory_Field; + + procedure Add_Scope_Field + (Name : O_Ident; Child : in out Var_Scope_Type) + is + Field : O_Fnode; + begin + Field := Add_Instance_Factory_Field (Name, Get_Scope_Type (Child)); + Set_Scope_Via_Field (Child, Field, Inst_Build.Scope); + end Add_Scope_Field; + + function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode) + return O_Cnode is + begin + return New_Offsetof (Get_Scope_Type (Child.Up_Link.all), + Child.Field, Otype); + end Get_Scope_Offset; + + procedure Pop_Instance_Factory (Scope : in Var_Scope_Acc) + is + Res : O_Tnode; + begin + if Inst_Build.Kind /= Instance then + -- Not matching. + raise Internal_Error; + end if; + Finish_Record_Type (Inst_Build.Elements, Res); + Pop_Build_Instance; + Scope.Scope_Type := Res; + end Pop_Instance_Factory; + + procedure Push_Local_Factory + is + Inst : Inst_Build_Acc; + begin + if Inst_Build /= null + and then (Inst_Build.Kind /= Global and Inst_Build.Kind /= Local) + then + -- Cannot create a local factory on an instance. + raise Internal_Error; + end if; + Inst := new Inst_Build_Type (Kind => Local); + Inst.Prev := Inst_Build; + Inst.Prev_Global_Storage := Global_Storage; + + Inst.Prev_Id_Start := Identifier_Start; + Identifier_Start := Identifier_Len + 1; + + Inst_Build := Inst; + case Global_Storage is + when O_Storage_Public => + Global_Storage := O_Storage_Private; + when O_Storage_Private + | O_Storage_External => + null; + when O_Storage_Local => + raise Internal_Error; + end case; + end Push_Local_Factory; + + -- Return TRUE is the current scope is local. + function Is_Local_Scope return Boolean is + begin + if Inst_Build = null then + return False; + end if; + case Inst_Build.Kind is + when Local + | Instance => + return True; + when Global => + return False; + end case; + end Is_Local_Scope; + + procedure Pop_Local_Factory is + begin + if Inst_Build.Kind /= Local then + -- Not matching. + raise Internal_Error; + end if; + Global_Storage := Inst_Build.Prev_Global_Storage; + Pop_Build_Instance; + end Pop_Local_Factory; + + procedure Set_Scope_Via_Field + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Field, + Field => Scope_Field, Up_Link => Scope_Parent); + end Set_Scope_Via_Field; + + procedure Set_Scope_Via_Field_Ptr + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Field_Ptr, + Field => Scope_Field, Up_Link => Scope_Parent); + end Set_Scope_Via_Field_Ptr; + + procedure Set_Scope_Via_Var_Ptr + (Scope : in out Var_Scope_Type; Var : Var_Type) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + pragma Assert (Var.Kind = Var_Scope); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Field_Ptr, + Field => Var.I_Field, Up_Link => Var.I_Scope); + end Set_Scope_Via_Var_Ptr; + + procedure Set_Scope_Via_Param_Ptr + (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Ptr, D => Scope_Param); + end Set_Scope_Via_Param_Ptr; + + procedure Set_Scope_Via_Decl + (Scope : in out Var_Scope_Type; Decl : O_Dnode) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Decl, D => Decl); + end Set_Scope_Via_Decl; + + procedure Clear_Scope (Scope : in out Var_Scope_Type) is + begin + pragma Assert (Scope.Kind /= Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_None); + end Clear_Scope; + + function Create_Global_Var + (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) + return Var_Type + is + Var : O_Dnode; + begin + New_Var_Decl (Var, Name, Storage, Vtype); + return Var_Type'(Kind => Var_Global, E => Var); + end Create_Global_Var; + + function Create_Global_Const + (Name : O_Ident; + Vtype : O_Tnode; + Storage : O_Storage; + Initial_Value : O_Cnode) + return Var_Type + is + Res : O_Dnode; + begin + New_Const_Decl (Res, Name, Storage, Vtype); + if Storage /= O_Storage_External + and then Initial_Value /= O_Cnode_Null + then + Start_Const_Value (Res); + Finish_Const_Value (Res, Initial_Value); + end if; + return Var_Type'(Kind => Var_Global, E => Res); + end Create_Global_Const; + + procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode) is + begin + Start_Const_Value (Const.E); + Finish_Const_Value (Const.E, Val); + end Define_Global_Const; + + function Create_Var + (Name : Var_Ident_Type; + Vtype : O_Tnode; + Storage : O_Storage := Global_Storage) + return Var_Type + is + Res : O_Dnode; + Field : O_Fnode; + K : Inst_Build_Kind_Type; + begin + if Inst_Build = null then + K := Global; + else + K := Inst_Build.Kind; + end if; + case K is + when Global => + -- The global scope is in use... + return Create_Global_Var (Name.Id, Vtype, Storage); + when Local => + -- It is always possible to create a variable in a local scope. + -- Create a var. + New_Var_Decl (Res, Name.Id, O_Storage_Local, Vtype); + return Var_Type'(Kind => Var_Local, E => Res); + when Instance => + -- Create a field. + New_Record_Field (Inst_Build.Elements, Field, Name.Id, Vtype); + return Var_Type'(Kind => Var_Scope, I_Field => Field, + I_Scope => Inst_Build.Scope); + end case; + end Create_Var; + + -- Get a reference to scope STYPE. If IS_PTR is set, RES is an access + -- to the scope, otherwise RES directly designates the scope. + procedure Find_Scope (Scope : Var_Scope_Type; + Res : out O_Lnode; + Is_Ptr : out Boolean) is + begin + case Scope.Kind is + when Var_Scope_None => + raise Internal_Error; + when Var_Scope_Ptr + | Var_Scope_Decl => + Res := New_Obj (Scope.D); + Is_Ptr := Scope.Kind = Var_Scope_Ptr; + when Var_Scope_Field + | Var_Scope_Field_Ptr => + declare + Parent : O_Lnode; + Parent_Ptr : Boolean; + begin + Find_Scope (Scope.Up_Link.all, Parent, Parent_Ptr); + if Parent_Ptr then + Parent := New_Acc_Value (Parent); + end if; + Res := New_Selected_Element (Parent, Scope.Field); + Is_Ptr := Scope.Kind = Var_Scope_Field_Ptr; + end; + end case; + end Find_Scope; + + procedure Check_Not_Building is + begin + -- Variables cannot be referenced if there is an instance being + -- built. + if Inst_Build /= null and then Inst_Build.Kind = Instance then + raise Internal_Error; + end if; + end Check_Not_Building; + + function Get_Instance_Access (Block : Iir) return O_Enode + is + Info : constant Block_Info_Acc := Get_Info (Block); + Res : O_Lnode; + Is_Ptr : Boolean; + begin + Check_Not_Building; + Find_Scope (Info.Block_Scope, Res, Is_Ptr); + if Is_Ptr then + return New_Value (Res); + else + return New_Address (Res, Info.Block_Decls_Ptr_Type); + end if; + end Get_Instance_Access; + + function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode + is + Res : O_Lnode; + Is_Ptr : Boolean; + begin + Check_Not_Building; + Find_Scope (Scope, Res, Is_Ptr); + if Is_Ptr then + return New_Acc_Value (Res); + else + return Res; + end if; + end Get_Instance_Ref; + + function Get_Var (Var : Var_Type) return O_Lnode + is + begin + case Var.Kind is + when Var_None => + raise Internal_Error; + when Var_Local + | Var_Global => + return New_Obj (Var.E); + when Var_Scope => + return New_Selected_Element + (Get_Instance_Ref (Var.I_Scope.all), Var.I_Field); + end case; + end Get_Var; + + function Get_Alloc_Kind_For_Var (Var : Var_Type) + return Allocation_Kind is + begin + case Var.Kind is + when Var_Local => + return Alloc_Stack; + when Var_Global + | Var_Scope => + return Alloc_System; + when Var_None => + raise Internal_Error; + end case; + end Get_Alloc_Kind_For_Var; + + function Is_Var_Stable (Var : Var_Type) return Boolean is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return True; + when Var_Scope => + return False; + when Var_None => + raise Internal_Error; + end case; + end Is_Var_Stable; + + function Is_Var_Field (Var : Var_Type) return Boolean is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return False; + when Var_Scope => + return True; + when Var_None => + raise Internal_Error; + end case; + end Is_Var_Field; + + function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode + is + begin + return New_Offsetof (Get_Scope_Type (Var.I_Scope.all), + Var.I_Field, Otype); + end Get_Var_Offset; + + function Get_Var_Label (Var : Var_Type) return O_Dnode is + begin + case Var.Kind is + when Var_Local + | Var_Global => + return Var.E; + when Var_Scope + | Var_None => + raise Internal_Error; + end case; + end Get_Var_Label; + + procedure Save_Local_Identifier (Id : out Local_Identifier_Type) is + begin + Id := Identifier_Local; + end Save_Local_Identifier; + + procedure Restore_Local_Identifier (Id : Local_Identifier_Type) is + begin + if Identifier_Local > Id then + -- If the value is restored with a smaller value, some identifiers + -- will be reused. This is certainly an internal error. + raise Internal_Error; + end if; + Identifier_Local := Id; + end Restore_Local_Identifier; + + -- Reset the identifier. + procedure Reset_Identifier_Prefix is + begin + if Identifier_Len /= 0 or else Identifier_Local /= 0 then + raise Internal_Error; + end if; + end Reset_Identifier_Prefix; + + procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type) is + begin + Identifier_Len := Mark.Len; + Identifier_Local := Mark.Local_Id; + end Pop_Identifier_Prefix; + + procedure Add_String (Len : in out Natural; Str : String) is + begin + Identifier_Buffer (Len + 1 .. Len + Str'Length) := Str; + Len := Len + Str'Length; + end Add_String; + + procedure Add_Nat (Len : in out Natural; Val : Natural) + is + Num : String (1 .. 10); + V : Natural; + P : Natural; + begin + P := Num'Last; + V := Val; + loop + Num (P) := Character'Val (Character'Pos ('0') + V mod 10); + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + Add_String (Len, Num (P .. Num'Last)); + end Add_Nat; + + -- Convert name_id NAME to a string stored to + -- NAME_BUFFER (1 .. NAME_LENGTH). + -- + -- This encodes extended identifiers. + -- + -- Extended identifier encoding: + -- They start with 'X'. + -- Non extended character [0-9a-zA-Z] are left as is, + -- others are encoded to _XX, where XX is the character position in hex. + -- They finish with "__". + procedure Name_Id_To_String (Name : Name_Id) + is + use Name_Table; + + type Bool_Array_Type is array (Character) of Boolean; + pragma Pack (Bool_Array_Type); + Is_Extended_Char : constant Bool_Array_Type := + ('0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' => False, + others => True); + + N_Len : Natural; + P : Natural; + C : Character; + begin + if Is_Character (Name) then + P := Character'Pos (Name_Table.Get_Character (Name)); + Name_Buffer (1) := 'C'; + Name_Buffer (2) := N2hex (P / 16); + Name_Buffer (3) := N2hex (P mod 16); + Name_Length := 3; + return; + else + Image (Name); + end if; + if Name_Buffer (1) /= '\' then + return; + end if; + -- Extended identifier. + -- Supress trailing backslash. + Name_Length := Name_Length - 1; + + -- Count number of characters in the extended string. + N_Len := Name_Length; + for I in 2 .. Name_Length loop + if Is_Extended_Char (Name_Buffer (I)) then + N_Len := N_Len + 2; + end if; + end loop; + + -- Convert. + Name_Buffer (1) := 'X'; + P := N_Len; + for J in reverse 2 .. Name_Length loop + C := Name_Buffer (J); + if Is_Extended_Char (C) then + Name_Buffer (P - 0) := N2hex (Character'Pos (C) mod 16); + Name_Buffer (P - 1) := N2hex (Character'Pos (C) / 16); + Name_Buffer (P - 2) := '_'; + P := P - 3; + else + Name_Buffer (P) := C; + P := P - 1; + end if; + end loop; + Name_Buffer (N_Len + 1) := '_'; + Name_Buffer (N_Len + 2) := '_'; + Name_Length := N_Len + 2; + end Name_Id_To_String; + + procedure Add_Name (Len : in out Natural; Name : Name_Id) + is + use Name_Table; + begin + Name_Id_To_String (Name); + Add_String (Len, Name_Buffer (1 .. Name_Length)); + end Add_Name; + + procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; + Name : String; + Val : Iir_Int32 := 0) + is + P : Natural; + begin + Mark.Len := Identifier_Len; + Mark.Local_Id := Identifier_Local; + Identifier_Local := 0; + P := Identifier_Len; + Add_String (P, Name); + if Val > 0 then + Add_String (P, "O"); + Add_Nat (P, Natural (Val)); + end if; + Add_String (P, "__"); + Identifier_Len := P; + end Push_Identifier_Prefix; + + -- Add a suffix to the prefix (!!!). + procedure Push_Identifier_Prefix + (Mark : out Id_Mark_Type; Name : Name_Id; Val : Iir_Int32 := 0) + is + use Name_Table; + begin + Name_Id_To_String (Name); + Push_Identifier_Prefix (Mark, Name_Buffer (1 .. Name_Length), Val); + end Push_Identifier_Prefix; + + procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type) + is + Str : String := Local_Identifier_Type'Image (Identifier_Local); + begin + Identifier_Local := Identifier_Local + 1; + Str (1) := 'U'; + Push_Identifier_Prefix (Mark, Str, 0); + end Push_Identifier_Prefix_Uniq; + + procedure Add_Identifier (Len : in out Natural; Id : Name_Id) is + begin + if Id /= Null_Identifier then + Add_Name (Len, Id); + end if; + end Add_Identifier; + + -- Create an identifier from IIR node ID without the prefix. + function Create_Identifier_Without_Prefix (Id : Iir) return O_Ident + is + use Name_Table; + begin + Name_Id_To_String (Get_Identifier (Id)); + return Get_Identifier (Name_Buffer (1 .. Name_Length)); + end Create_Identifier_Without_Prefix; + + function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) + return O_Ident + is + use Name_Table; + begin + Name_Id_To_String (Id); + Name_Buffer (Name_Length + 1 .. Name_Length + Str'Length) := Str; + return Get_Identifier (Name_Buffer (1 .. Name_Length + Str'Length)); + end Create_Identifier_Without_Prefix; + + -- Create an identifier from IIR node ID with prefix. + function Create_Id (Id : Name_Id; Str : String; Is_Local : Boolean) + return O_Ident + is + L : Natural; + begin + L := Identifier_Len; + Add_Identifier (L, Id); + Add_String (L, Str); + --Identifier_Buffer (L + Str'Length + 1) := Nul; + if Is_Local then + return Get_Identifier + (Identifier_Buffer (Identifier_Start .. L)); + else + return Get_Identifier (Identifier_Buffer (1 .. L)); + end if; + end Create_Id; + + function Create_Identifier (Id : Name_Id; Str : String := "") + return O_Ident + is + begin + return Create_Id (Id, Str, False); + end Create_Identifier; + + function Create_Identifier (Id : Iir; Str : String := "") + return O_Ident + is + begin + return Create_Id (Get_Identifier (Id), Str, False); + end Create_Identifier; + + function Create_Identifier + (Id : Iir; Val : Iir_Int32; Str : String := "") + return O_Ident + is + Len : Natural; + begin + Len := Identifier_Len; + Add_Identifier (Len, Get_Identifier (Id)); + + if Val > 0 then + Add_String (Len, "O"); + Add_Nat (Len, Natural (Val)); + end if; + Add_String (Len, Str); + return Get_Identifier (Identifier_Buffer (1 .. Len)); + end Create_Identifier; + + function Create_Identifier (Str : String) + return O_Ident + is + Len : Natural; + begin + Len := Identifier_Len; + Add_String (Len, Str); + return Get_Identifier (Identifier_Buffer (1 .. Len)); + end Create_Identifier; + + function Create_Identifier return O_Ident + is + begin + return Get_Identifier (Identifier_Buffer (1 .. Identifier_Len - 2)); + end Create_Identifier; + + function Create_Var_Identifier_From_Buffer (L : Natural) + return Var_Ident_Type + is + Start : Natural; + begin + if Is_Local_Scope then + Start := Identifier_Start; + else + Start := 1; + end if; + return (Id => Get_Identifier (Identifier_Buffer (Start .. L))); + end Create_Var_Identifier_From_Buffer; + + function Create_Var_Identifier (Id : Iir) + return Var_Ident_Type + is + L : Natural := Identifier_Len; + begin + Add_Identifier (L, Get_Identifier (Id)); + return Create_Var_Identifier_From_Buffer (L); + end Create_Var_Identifier; + + function Create_Var_Identifier (Id : String) + return Var_Ident_Type + is + L : Natural := Identifier_Len; + begin + Add_String (L, Id); + return Create_Var_Identifier_From_Buffer (L); + end Create_Var_Identifier; + + function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural) + return Var_Ident_Type + is + L : Natural := Identifier_Len; + begin + Add_Identifier (L, Get_Identifier (Id)); + Add_String (L, Str); + if Val > 0 then + Add_String (L, "O"); + Add_Nat (L, Val); + end if; + return Create_Var_Identifier_From_Buffer (L); + end Create_Var_Identifier; + + function Create_Uniq_Identifier return Var_Ident_Type + is + Res : Var_Ident_Type; + begin + Res.Id := Create_Uniq_Identifier; + return Res; + end Create_Uniq_Identifier; + + type Instantiate_Var_Stack; + type Instantiate_Var_Stack_Acc is access Instantiate_Var_Stack; + + type Instantiate_Var_Stack is record + Orig_Scope : Var_Scope_Acc; + Inst_Scope : Var_Scope_Acc; + Prev : Instantiate_Var_Stack_Acc; + end record; + + Top_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null; + Free_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null; + + procedure Push_Instantiate_Var_Scope + (Inst_Scope : Var_Scope_Acc; Orig_Scope : Var_Scope_Acc) + is + Inst : Instantiate_Var_Stack_Acc; + begin + if Free_Instantiate_Var_Stack = null then + Inst := new Instantiate_Var_Stack; + else + Inst := Free_Instantiate_Var_Stack; + Free_Instantiate_Var_Stack := Inst.Prev; + end if; + Inst.all := (Orig_Scope => Orig_Scope, + Inst_Scope => Inst_Scope, + Prev => Top_Instantiate_Var_Stack); + Top_Instantiate_Var_Stack := Inst; + end Push_Instantiate_Var_Scope; + + procedure Pop_Instantiate_Var_Scope (Inst_Scope : Var_Scope_Acc) + is + Item : constant Instantiate_Var_Stack_Acc := + Top_Instantiate_Var_Stack; + begin + pragma Assert (Item /= null); + pragma Assert (Item.Inst_Scope = Inst_Scope); + Top_Instantiate_Var_Stack := Item.Prev; + Item.all := (Orig_Scope => null, + Inst_Scope => null, + Prev => Free_Instantiate_Var_Stack); + Free_Instantiate_Var_Stack := Item; + end Pop_Instantiate_Var_Scope; + + function Instantiated_Var_Scope (Scope : Var_Scope_Acc) + return Var_Scope_Acc + is + Item : Instantiate_Var_Stack_Acc; + begin + if Scope = null then + return null; + end if; + + Item := Top_Instantiate_Var_Stack; + loop + pragma Assert (Item /= null); + if Item.Orig_Scope = Scope then + return Item.Inst_Scope; + end if; + Item := Item.Prev; + end loop; + end Instantiated_Var_Scope; + + function Instantiate_Var (Var : Var_Type) return Var_Type is + begin + case Var.Kind is + when Var_None + | Var_Global + | Var_Local => + return Var; + when Var_Scope => + return Var_Type' + (Kind => Var_Scope, + I_Field => Var.I_Field, + I_Scope => Instantiated_Var_Scope (Var.I_Scope)); + end case; + end Instantiate_Var; + + function Instantiate_Var_Scope (Scope : Var_Scope_Type) + return Var_Scope_Type is + begin + case Scope.Kind is + when Var_Scope_None + | Var_Scope_Ptr + | Var_Scope_Decl => + return Scope; + when Var_Scope_Field => + return Var_Scope_Type' + (Kind => Var_Scope_Field, + Scope_Type => Scope.Scope_Type, + Field => Scope.Field, + Up_Link => Instantiated_Var_Scope (Scope.Up_Link)); + when Var_Scope_Field_Ptr => + return Var_Scope_Type' + (Kind => Var_Scope_Field_Ptr, + Scope_Type => Scope.Scope_Type, + Field => Scope.Field, + Up_Link => Instantiated_Var_Scope (Scope.Up_Link)); + end case; + end Instantiate_Var_Scope; + end Chap10; + + package body Chap14 is + function Translate_Array_Attribute_To_Range (Expr : Iir) return Mnode + is + Prefix : constant Iir := Get_Prefix (Expr); + Type_Name : constant Iir := Is_Type_Name (Prefix); + Arr : Mnode; + Dim : Natural; + begin + if Type_Name /= Null_Iir then + -- Prefix denotes a type name + Arr := T2M (Type_Name, Mode_Value); + else + -- Prefix is an object. + Arr := Chap6.Translate_Name (Prefix); + end if; + Dim := Natural (Get_Value (Get_Parameter (Expr))); + return Chap3.Get_Array_Range (Arr, Get_Type (Prefix), Dim); + end Translate_Array_Attribute_To_Range; + + function Translate_Range_Array_Attribute (Expr : Iir) + return O_Lnode is + begin + return M2Lv (Translate_Array_Attribute_To_Range (Expr)); + end Translate_Range_Array_Attribute; + + function Translate_Length_Array_Attribute (Expr : Iir; Rtype : Iir) + return O_Enode + is + Rng : Mnode; + Val : O_Enode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + Val := M2E (Chap3.Range_To_Length (Rng)); + if Rtype /= Null_Iir then + Val := New_Convert_Ov (Val, Get_Ortho_Type (Rtype, Mode_Value)); + end if; + return Val; + end Translate_Length_Array_Attribute; + + -- Extract high or low bound of RANGE_VAR. + function Range_To_High_Low + (Range_Var : Mnode; Range_Type : Iir; Is_High : Boolean) + return Mnode + is + Op : ON_Op_Kind; + If_Blk : O_If_Block; + Range_Svar : constant Mnode := Stabilize (Range_Var); + Res : O_Dnode; + Tinfo : constant Ortho_Info_Acc := + Get_Info (Get_Base_Type (Range_Type)); + begin + Res := Create_Temp (Tinfo.Ortho_Type (Mode_Value)); + Open_Temp; + if Is_High then + Op := ON_Neq; + else + Op := ON_Eq; + end if; + Start_If_Stmt (If_Blk, + New_Compare_Op (Op, + M2E (Chap3.Range_To_Dir (Range_Svar)), + New_Lit (Ghdl_Dir_To_Node), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Res), + M2E (Chap3.Range_To_Left (Range_Svar))); + New_Else_Stmt (If_Blk); + New_Assign_Stmt (New_Obj (Res), + M2E (Chap3.Range_To_Right (Range_Svar))); + Finish_If_Stmt (If_Blk); + Close_Temp; + return Dv2M (Res, Tinfo, Mode_Value); + end Range_To_High_Low; + + function Translate_High_Low_Type_Attribute + (Atype : Iir; Is_High : Boolean) return O_Enode + is + Cons : constant Iir := Get_Range_Constraint (Atype); + begin + -- FIXME: improve code if constraint is a range expression. + if Get_Type_Staticness (Atype) = Locally then + if Get_Direction (Cons) = Iir_To xor Is_High then + return New_Lit + (Chap7.Translate_Static_Range_Left (Cons, Atype)); + else + return New_Lit + (Chap7.Translate_Static_Range_Right (Cons, Atype)); + end if; + else + return M2E (Range_To_High_Low + (Chap3.Type_To_Range (Atype), Atype, Is_High)); + end if; + end Translate_High_Low_Type_Attribute; + + function Translate_High_Low_Array_Attribute (Expr : Iir; + Is_High : Boolean) + return O_Enode + is + begin + -- FIXME: improve code if index is a range expression. + return M2E (Range_To_High_Low + (Translate_Array_Attribute_To_Range (Expr), + Get_Type (Expr), Is_High)); + end Translate_High_Low_Array_Attribute; + + function Translate_Low_Array_Attribute (Expr : Iir) + return O_Enode + is + begin + return Translate_High_Low_Array_Attribute (Expr, False); + end Translate_Low_Array_Attribute; + + function Translate_High_Array_Attribute (Expr : Iir) + return O_Enode + is + begin + return Translate_High_Low_Array_Attribute (Expr, True); + end Translate_High_Array_Attribute; + + function Translate_Left_Array_Attribute (Expr : Iir) + return O_Enode + is + Rng : Mnode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + return M2E (Chap3.Range_To_Left (Rng)); + end Translate_Left_Array_Attribute; + + function Translate_Right_Array_Attribute (Expr : Iir) + return O_Enode + is + Rng : Mnode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + return M2E (Chap3.Range_To_Right (Rng)); + end Translate_Right_Array_Attribute; + + function Translate_Ascending_Array_Attribute (Expr : Iir) + return O_Enode + is + Rng : Mnode; + begin + Rng := Translate_Array_Attribute_To_Range (Expr); + return New_Compare_Op (ON_Eq, + M2E (Chap3.Range_To_Dir (Rng)), + New_Lit (Ghdl_Dir_To_Node), + Std_Boolean_Type_Node); + end Translate_Ascending_Array_Attribute; + + function Translate_Left_Type_Attribute (Atype : Iir) return O_Enode is + begin + if Get_Type_Staticness (Atype) = Locally then + return New_Lit (Chap7.Translate_Static_Range_Left + (Get_Range_Constraint (Atype), Atype)); + else + return M2E (Chap3.Range_To_Left (Chap3.Type_To_Range (Atype))); + end if; + end Translate_Left_Type_Attribute; + + function Translate_Right_Type_Attribute (Atype : Iir) return O_Enode is + begin + if Get_Type_Staticness (Atype) = Locally then + return New_Lit (Chap7.Translate_Static_Range_Right + (Get_Range_Constraint (Atype), Atype)); + else + return M2E (Chap3.Range_To_Right (Chap3.Type_To_Range (Atype))); + end if; + end Translate_Right_Type_Attribute; + + function Translate_Dir_Type_Attribute (Atype : Iir) return O_Enode + is + Info : Type_Info_Acc; + begin + if Get_Type_Staticness (Atype) = Locally then + return New_Lit (Chap7.Translate_Static_Range_Dir + (Get_Range_Constraint (Atype))); + else + Info := Get_Info (Atype); + return New_Value + (New_Selected_Element (Get_Var (Info.T.Range_Var), + Info.T.Range_Dir)); + end if; + end Translate_Dir_Type_Attribute; + + function Translate_Val_Attribute (Attr : Iir) return O_Enode + is + Val : O_Enode; + Attr_Type : Iir; + Res_Var : O_Dnode; + Res_Type : O_Tnode; + begin + Attr_Type := Get_Type (Attr); + Res_Type := Get_Ortho_Type (Attr_Type, Mode_Value); + Res_Var := Create_Temp (Res_Type); + Val := Chap7.Translate_Expression (Get_Parameter (Attr)); + + case Get_Kind (Attr_Type) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + -- For enumeration, always check the value is in the enum + -- range. + declare + Val_Type : O_Tnode; + Val_Var : O_Dnode; + If_Blk : O_If_Block; + begin + Val_Type := Get_Ortho_Type (Get_Type (Get_Parameter (Attr)), + Mode_Value); + Val_Var := Create_Temp_Init (Val_Type, Val); + Start_If_Stmt + (If_Blk, + New_Dyadic_Op + (ON_Or, + New_Compare_Op (ON_Lt, + New_Obj_Value (Val_Var), + New_Lit (New_Signed_Literal + (Val_Type, 0)), + Ghdl_Bool_Type), + New_Compare_Op (ON_Ge, + New_Obj_Value (Val_Var), + New_Lit (New_Signed_Literal + (Val_Type, + Integer_64 + (Get_Nbr_Elements + (Get_Enumeration_Literal_List + (Attr_Type))))), + Ghdl_Bool_Type))); + Chap6.Gen_Bound_Error (Attr); + Finish_If_Stmt (If_Blk); + Val := New_Obj_Value (Val_Var); + end; + when others => + null; + end case; + + New_Assign_Stmt (New_Obj (Res_Var), New_Convert_Ov (Val, Res_Type)); + Chap3.Check_Range + (Res_Var, Attr, Get_Type (Get_Prefix (Attr)), Attr); + return New_Obj_Value (Res_Var); + end Translate_Val_Attribute; + + function Translate_Pos_Attribute (Attr : Iir; Res_Type : Iir) + return O_Enode + is + T : O_Dnode; + Ttype : O_Tnode; + begin + Ttype := Get_Ortho_Type (Res_Type, Mode_Value); + T := Create_Temp (Ttype); + New_Assign_Stmt + (New_Obj (T), + New_Convert_Ov (Chap7.Translate_Expression (Get_Parameter (Attr)), + Ttype)); + Chap3.Check_Range (T, Attr, Res_Type, Attr); + return New_Obj_Value (T); + end Translate_Pos_Attribute; + + function Translate_Succ_Pred_Attribute (Attr : Iir) return O_Enode + is + Expr_Type : Iir; + Tinfo : Type_Info_Acc; + Ttype : O_Tnode; + Expr : O_Enode; + List : Iir_List; + Limit : Iir; + Is_Succ : Boolean; + Op : ON_Op_Kind; + begin + -- FIXME: should check bounds. + Expr_Type := Get_Type (Attr); + Tinfo := Get_Info (Expr_Type); + Expr := Chap7.Translate_Expression (Get_Parameter (Attr), Expr_Type); + Ttype := Tinfo.Ortho_Type (Mode_Value); + Is_Succ := Get_Kind (Attr) = Iir_Kind_Succ_Attribute; + if Is_Succ then + Op := ON_Add_Ov; + else + Op := ON_Sub_Ov; + end if; + case Tinfo.Type_Mode is + when Type_Mode_B1 + | Type_Mode_E8 + | Type_Mode_E32 => + -- Should check it is not the last. + declare + L : O_Dnode; + begin + List := Get_Enumeration_Literal_List (Get_Base_Type + (Expr_Type)); + L := Create_Temp_Init (Ttype, Expr); + if Is_Succ then + Limit := Get_Last_Element (List); + else + Limit := Get_First_Element (List); + end if; + Chap6.Check_Bound_Error + (New_Compare_Op (ON_Eq, + New_Obj_Value (L), + New_Lit (Get_Ortho_Expr (Limit)), + Ghdl_Bool_Type), + Attr, 0); + return New_Convert_Ov + (New_Dyadic_Op + (Op, + New_Convert_Ov (New_Obj_Value (L), Ghdl_I32_Type), + New_Lit (New_Signed_Literal (Ghdl_I32_Type, 1))), + Ttype); + end; + when Type_Mode_I32 + | Type_Mode_P64 => + return New_Dyadic_Op + (Op, Expr, New_Lit (New_Signed_Literal (Ttype, 1))); + when others => + raise Internal_Error; + end case; + end Translate_Succ_Pred_Attribute; + + type Bool_Sigattr_Data_Type is record + Label : O_Snode; + Field : O_Fnode; + end record; + + procedure Bool_Sigattr_Non_Composite_Signal + (Targ : Mnode; Targ_Type : Iir; Data : Bool_Sigattr_Data_Type) + is + pragma Unreferenced (Targ_Type); + begin + Gen_Exit_When (Data.Label, + New_Value (Get_Signal_Field (Targ, Data.Field))); + end Bool_Sigattr_Non_Composite_Signal; + + function Bool_Sigattr_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Bool_Sigattr_Data_Type) + return Bool_Sigattr_Data_Type + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Data; + end Bool_Sigattr_Prepare_Data_Composite; + + function Bool_Sigattr_Update_Data_Array (Data : Bool_Sigattr_Data_Type; + Targ_Type : Iir; + Index : O_Dnode) + return Bool_Sigattr_Data_Type + is + pragma Unreferenced (Targ_Type, Index); + begin + return Data; + end Bool_Sigattr_Update_Data_Array; + + function Bool_Sigattr_Update_Data_Record (Data : Bool_Sigattr_Data_Type; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Bool_Sigattr_Data_Type + is + pragma Unreferenced (Targ_Type, El); + begin + return Data; + end Bool_Sigattr_Update_Data_Record; + + procedure Bool_Sigattr_Finish_Data_Composite + (Data : in out Bool_Sigattr_Data_Type) + is + pragma Unreferenced (Data); + begin + null; + end Bool_Sigattr_Finish_Data_Composite; + + procedure Bool_Sigattr_Foreach is new Foreach_Non_Composite + (Data_Type => Bool_Sigattr_Data_Type, + Composite_Data_Type => Bool_Sigattr_Data_Type, + Do_Non_Composite => Bool_Sigattr_Non_Composite_Signal, + Prepare_Data_Array => Bool_Sigattr_Prepare_Data_Composite, + Update_Data_Array => Bool_Sigattr_Update_Data_Array, + Finish_Data_Array => Bool_Sigattr_Finish_Data_Composite, + Prepare_Data_Record => Bool_Sigattr_Prepare_Data_Composite, + Update_Data_Record => Bool_Sigattr_Update_Data_Record, + Finish_Data_Record => Bool_Sigattr_Finish_Data_Composite); + + function Translate_Bool_Signal_Attribute (Attr : Iir; Field : O_Fnode) + return O_Enode + is + Data : Bool_Sigattr_Data_Type; + Res : O_Dnode; + Name : Mnode; + Prefix : constant Iir := Get_Prefix (Attr); + Prefix_Type : constant Iir := Get_Type (Prefix); + begin + if Get_Kind (Prefix_Type) in Iir_Kinds_Scalar_Type_Definition then + -- Effecient handling for a scalar signal. + Name := Chap6.Translate_Name (Prefix); + return New_Value (Get_Signal_Field (Name, Field)); + else + -- Element per element handling for composite signals. + Res := Create_Temp (Std_Boolean_Type_Node); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_True_Node)); + Name := Chap6.Translate_Name (Prefix); + Start_Loop_Stmt (Data.Label); + Data.Field := Field; + Bool_Sigattr_Foreach (Name, Prefix_Type, Data); + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_False_Node)); + New_Exit_Stmt (Data.Label); + Finish_Loop_Stmt (Data.Label); + Close_Temp; + return New_Obj_Value (Res); + end if; + end Translate_Bool_Signal_Attribute; + + function Translate_Event_Attribute (Attr : Iir) return O_Enode is + begin + return Translate_Bool_Signal_Attribute + (Attr, Ghdl_Signal_Event_Field); + end Translate_Event_Attribute; + + function Translate_Active_Attribute (Attr : Iir) return O_Enode is + begin + return Translate_Bool_Signal_Attribute + (Attr, Ghdl_Signal_Active_Field); + end Translate_Active_Attribute; + + -- Read signal value FIELD of signal SIG. + function Get_Signal_Value_Field + (Sig : O_Enode; Sig_Type : Iir; Field : O_Fnode) + return O_Lnode + is + S_Type : O_Tnode; + T : O_Lnode; + begin + S_Type := Get_Ortho_Type (Sig_Type, Mode_Signal); + T := New_Access_Element (New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Access_Element + (New_Unchecked_Address (New_Selected_Element (T, Field), S_Type)); + end Get_Signal_Value_Field; + + function Get_Signal_Field (Sig : Mnode; Field : O_Fnode) + return O_Lnode + is + S : O_Enode; + begin + S := New_Convert_Ov (New_Value (M2Lv (Sig)), Ghdl_Signal_Ptr); + return New_Selected_Element (New_Access_Element (S), Field); + end Get_Signal_Field; + + function Read_Last_Value (Sig : O_Enode; Sig_Type : Iir) return O_Enode + is + begin + return New_Value (Get_Signal_Value_Field + (Sig, Sig_Type, Ghdl_Signal_Last_Value_Field)); + end Read_Last_Value; + + function Translate_Last_Value is new Chap7.Translate_Signal_Value + (Read_Value => Read_Last_Value); + + function Translate_Last_Value_Attribute (Attr : Iir) return O_Enode + is + Name : Mnode; + Prefix : Iir; + Prefix_Type : Iir; + begin + Prefix := Get_Prefix (Attr); + Prefix_Type := Get_Type (Prefix); + + Name := Chap6.Translate_Name (Prefix); + if Get_Object_Kind (Name) /= Mode_Signal then + raise Internal_Error; + end if; + return Translate_Last_Value (M2E (Name), Prefix_Type); + end Translate_Last_Value_Attribute; + + function Read_Last_Time (Sig : O_Enode; Field : O_Fnode) return O_Enode + is + T : O_Lnode; + begin + T := New_Access_Element (New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Value (New_Selected_Element (T, Field)); + end Read_Last_Time; + + type Last_Time_Data is record + Var : O_Dnode; + Field : O_Fnode; + end record; + + procedure Translate_Last_Time_Non_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Last_Time_Data) + is + pragma Unreferenced (Targ_Type); + Val : O_Dnode; + If_Blk : O_If_Block; + begin + Open_Temp; + Val := Create_Temp_Init + (Std_Time_Otype, + Read_Last_Time (New_Value (M2Lv (Targ)), Data.Field)); + Start_If_Stmt (If_Blk, + New_Compare_Op (ON_Gt, + New_Obj_Value (Val), + New_Obj_Value (Data.Var), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Data.Var), New_Obj_Value (Val)); + Finish_If_Stmt (If_Blk); + Close_Temp; + end Translate_Last_Time_Non_Composite; + + function Last_Time_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Data : Last_Time_Data) + return Last_Time_Data + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Data; + end Last_Time_Prepare_Data_Composite; + + function Last_Time_Update_Data_Array (Data : Last_Time_Data; + Targ_Type : Iir; + Index : O_Dnode) + return Last_Time_Data + is + pragma Unreferenced (Targ_Type, Index); + begin + return Data; + end Last_Time_Update_Data_Array; + + function Last_Time_Update_Data_Record (Data : Last_Time_Data; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return Last_Time_Data + is + pragma Unreferenced (Targ_Type, El); + begin + return Data; + end Last_Time_Update_Data_Record; + + procedure Last_Time_Finish_Data_Composite + (Data : in out Last_Time_Data) + is + pragma Unreferenced (Data); + begin + null; + end Last_Time_Finish_Data_Composite; + + procedure Translate_Last_Time is new Foreach_Non_Composite + (Data_Type => Last_Time_Data, + Composite_Data_Type => Last_Time_Data, + Do_Non_Composite => Translate_Last_Time_Non_Composite, + Prepare_Data_Array => Last_Time_Prepare_Data_Composite, + Update_Data_Array => Last_Time_Update_Data_Array, + Finish_Data_Array => Last_Time_Finish_Data_Composite, + Prepare_Data_Record => Last_Time_Prepare_Data_Composite, + Update_Data_Record => Last_Time_Update_Data_Record, + Finish_Data_Record => Last_Time_Finish_Data_Composite); + + function Translate_Last_Time_Attribute (Prefix : Iir; Field : O_Fnode) + return O_Enode + is + Prefix_Type : Iir; + Name : Mnode; + Info : Type_Info_Acc; + Var : O_Dnode; + Data : Last_Time_Data; + Right_Bound : Iir_Int64; + If_Blk : O_If_Block; + begin + Prefix_Type := Get_Type (Prefix); + Name := Chap6.Translate_Name (Prefix); + Info := Get_Info (Prefix_Type); + Var := Create_Temp (Std_Time_Otype); + + if Info.Type_Mode in Type_Mode_Scalar then + New_Assign_Stmt (New_Obj (Var), + Read_Last_Time (M2E (Name), Field)); + else + -- Init with a negative value. + New_Assign_Stmt + (New_Obj (Var), + New_Lit (New_Signed_Literal (Std_Time_Otype, -1))); + Data := Last_Time_Data'(Var => Var, Field => Field); + Translate_Last_Time (Name, Prefix_Type, Data); + end if; + + Right_Bound := Get_Value + (Get_Right_Limit (Get_Range_Constraint (Time_Subtype_Definition))); + + -- VAR < 0 ? + Start_If_Stmt + (If_Blk, + New_Compare_Op (ON_Lt, + New_Obj_Value (Var), + New_Lit (New_Signed_Literal (Std_Time_Otype, 0)), + Ghdl_Bool_Type)); + -- LRM 14.1 Predefined attributes + -- [...]; otherwise, it returns TIME'HIGH. + New_Assign_Stmt + (New_Obj (Var), + New_Lit (New_Signed_Literal + (Std_Time_Otype, Integer_64 (Right_Bound)))); + New_Else_Stmt (If_Blk); + -- Returns NOW - Var. + New_Assign_Stmt (New_Obj (Var), + New_Dyadic_Op (ON_Sub_Ov, + New_Obj_Value (Ghdl_Now), + New_Obj_Value (Var))); + Finish_If_Stmt (If_Blk); + return New_Obj_Value (Var); + end Translate_Last_Time_Attribute; + + -- Return TRUE if the scalar signal SIG is being driven. + function Read_Driving_Attribute (Sig : O_Enode) return O_Enode + is + Assoc : O_Assoc_List; + begin + Start_Association (Assoc, Ghdl_Signal_Driving); + New_Association (Assoc, New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Function_Call (Assoc); + end Read_Driving_Attribute; + + procedure Driving_Non_Composite_Signal + (Targ : Mnode; Targ_Type : Iir; Label : O_Snode) + is + pragma Unreferenced (Targ_Type); + begin + Gen_Exit_When + (Label, + New_Monadic_Op + (ON_Not, Read_Driving_Attribute (New_Value (M2Lv (Targ))))); + end Driving_Non_Composite_Signal; + + function Driving_Prepare_Data_Composite + (Targ : Mnode; Targ_Type : Iir; Label : O_Snode) + return O_Snode + is + pragma Unreferenced (Targ, Targ_Type); + begin + return Label; + end Driving_Prepare_Data_Composite; + + function Driving_Update_Data_Array (Label : O_Snode; + Targ_Type : Iir; + Index : O_Dnode) + return O_Snode + is + pragma Unreferenced (Targ_Type, Index); + begin + return Label; + end Driving_Update_Data_Array; + + function Driving_Update_Data_Record (Label : O_Snode; + Targ_Type : Iir; + El : Iir_Element_Declaration) + return O_Snode + is + pragma Unreferenced (Targ_Type, El); + begin + return Label; + end Driving_Update_Data_Record; + + procedure Driving_Finish_Data_Composite (Label : in out O_Snode) + is + pragma Unreferenced (Label); + begin + null; + end Driving_Finish_Data_Composite; + + procedure Driving_Foreach is new Foreach_Non_Composite + (Data_Type => O_Snode, + Composite_Data_Type => O_Snode, + Do_Non_Composite => Driving_Non_Composite_Signal, + Prepare_Data_Array => Driving_Prepare_Data_Composite, + Update_Data_Array => Driving_Update_Data_Array, + Finish_Data_Array => Driving_Finish_Data_Composite, + Prepare_Data_Record => Driving_Prepare_Data_Composite, + Update_Data_Record => Driving_Update_Data_Record, + Finish_Data_Record => Driving_Finish_Data_Composite); + + function Translate_Driving_Attribute (Attr : Iir) return O_Enode + is + Label : O_Snode; + Res : O_Dnode; + Name : Mnode; + Prefix : Iir; + Prefix_Type : Iir; + begin + Prefix := Get_Prefix (Attr); + Prefix_Type := Get_Type (Prefix); + + if Get_Kind (Prefix_Type) in Iir_Kinds_Scalar_Type_Definition then + -- Effecient handling for a scalar signal. + Name := Chap6.Translate_Name (Prefix); + return Read_Driving_Attribute (New_Value (M2Lv (Name))); + else + -- Element per element handling for composite signals. + Res := Create_Temp (Std_Boolean_Type_Node); + Open_Temp; + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_False_Node)); + Name := Chap6.Translate_Name (Prefix); + Start_Loop_Stmt (Label); + Driving_Foreach (Name, Prefix_Type, Label); + New_Assign_Stmt (New_Obj (Res), New_Lit (Std_Boolean_True_Node)); + New_Exit_Stmt (Label); + Finish_Loop_Stmt (Label); + Close_Temp; + return New_Obj_Value (Res); + end if; + end Translate_Driving_Attribute; + + function Read_Driving_Value (Sig : O_Enode; Sig_Type : Iir) + return O_Enode + is + Tinfo : Type_Info_Acc; + Subprg : O_Dnode; + Assoc : O_Assoc_List; + begin + Tinfo := Get_Info (Sig_Type); + case Tinfo.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Signal_Driving_Value_B1; + when Type_Mode_E8 => + Subprg := Ghdl_Signal_Driving_Value_E8; + when Type_Mode_E32 => + Subprg := Ghdl_Signal_Driving_Value_E32; + when Type_Mode_I32 + | Type_Mode_P32 => + Subprg := Ghdl_Signal_Driving_Value_I32; + when Type_Mode_P64 + | Type_Mode_I64 => + Subprg := Ghdl_Signal_Driving_Value_I64; + when Type_Mode_F64 => + Subprg := Ghdl_Signal_Driving_Value_F64; + when others => + raise Internal_Error; + end case; + Start_Association (Assoc, Subprg); + New_Association (Assoc, New_Convert_Ov (Sig, Ghdl_Signal_Ptr)); + return New_Convert_Ov (New_Function_Call (Assoc), + Tinfo.Ortho_Type (Mode_Value)); + end Read_Driving_Value; + + function Translate_Driving_Value is new Chap7.Translate_Signal_Value + (Read_Value => Read_Driving_Value); + + function Translate_Driving_Value_Attribute (Attr : Iir) return O_Enode + is + Name : Mnode; + Prefix : Iir; + Prefix_Type : Iir; + begin + Prefix := Get_Prefix (Attr); + Prefix_Type := Get_Type (Prefix); + + Name := Chap6.Translate_Name (Prefix); + if Get_Object_Kind (Name) /= Mode_Signal then + raise Internal_Error; + end if; + return Translate_Driving_Value (M2E (Name), Prefix_Type); + end Translate_Driving_Value_Attribute; + + function Translate_Image_Attribute (Attr : Iir) return O_Enode + is + Prefix_Type : constant Iir := + Get_Base_Type (Get_Type (Get_Prefix (Attr))); + Pinfo : constant Type_Info_Acc := Get_Info (Prefix_Type); + Res : O_Dnode; + Subprg : O_Dnode; + Assoc : O_Assoc_List; + Conv : O_Tnode; + begin + Res := Create_Temp (Std_String_Node); + Create_Temp_Stack2_Mark; + case Pinfo.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Image_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_Image_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_Image_E32; + Conv := Ghdl_I32_Type; + when Type_Mode_I32 => + Subprg := Ghdl_Image_I32; + Conv := Ghdl_I32_Type; + when Type_Mode_P32 => + Subprg := Ghdl_Image_P32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 => + Subprg := Ghdl_Image_P64; + Conv := Ghdl_I64_Type; + when Type_Mode_F64 => + Subprg := Ghdl_Image_F64; + Conv := Ghdl_Real_Type; + when others => + raise Internal_Error; + end case; + Start_Association (Assoc, Subprg); + New_Association (Assoc, + New_Address (New_Obj (Res), Std_String_Ptr_Node)); + New_Association + (Assoc, + New_Convert_Ov + (Chap7.Translate_Expression (Get_Parameter (Attr), Prefix_Type), + Conv)); + case Pinfo.Type_Mode is + when Type_Mode_B1 + | Type_Mode_E8 + | Type_Mode_E32 + | Type_Mode_P32 + | Type_Mode_P64 => + New_Association + (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti))); + when Type_Mode_I32 + | Type_Mode_F64 => + null; + when others => + raise Internal_Error; + end case; + New_Procedure_Call (Assoc); + return New_Address (New_Obj (Res), Std_String_Ptr_Node); + end Translate_Image_Attribute; + + function Translate_Value_Attribute (Attr : Iir) return O_Enode + is + Prefix_Type : constant Iir := + Get_Base_Type (Get_Type (Get_Prefix (Attr))); + Pinfo : constant Type_Info_Acc := Get_Info (Prefix_Type); + Subprg : O_Dnode; + Assoc : O_Assoc_List; + begin + case Pinfo.Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Value_B1; + when Type_Mode_E8 => + Subprg := Ghdl_Value_E8; + when Type_Mode_E32 => + Subprg := Ghdl_Value_E32; + when Type_Mode_I32 => + Subprg := Ghdl_Value_I32; + when Type_Mode_P32 => + Subprg := Ghdl_Value_P32; + when Type_Mode_P64 => + Subprg := Ghdl_Value_P64; + when Type_Mode_F64 => + Subprg := Ghdl_Value_F64; + when others => + raise Internal_Error; + end case; + Start_Association (Assoc, Subprg); + New_Association + (Assoc, + Chap7.Translate_Expression (Get_Parameter (Attr), + String_Type_Definition)); + case Pinfo.Type_Mode is + when Type_Mode_B1 + | Type_Mode_E8 + | Type_Mode_E32 + | Type_Mode_P32 + | Type_Mode_P64 => + New_Association + (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti))); + when Type_Mode_I32 + | Type_Mode_F64 => + null; + when others => + raise Internal_Error; + end case; + return New_Convert_Ov (New_Function_Call (Assoc), + Pinfo.Ortho_Type (Mode_Value)); + end Translate_Value_Attribute; + + function Translate_Path_Instance_Name_Attribute (Attr : Iir) + return O_Enode + is + Name : constant Path_Instance_Name_Type := + Get_Path_Instance_Name_Suffix (Attr); + Res : O_Dnode; + Name_Cst : O_Dnode; + Str_Cst : O_Cnode; + Constr : O_Assoc_List; + Is_Instance : constant Boolean := + Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; + begin + Create_Temp_Stack2_Mark; + + Res := Create_Temp (Std_String_Node); + Str_Cst := Create_String_Len (Name.Suffix, Create_Uniq_Identifier); + New_Const_Decl (Name_Cst, Create_Uniq_Identifier, O_Storage_Private, + Ghdl_Str_Len_Type_Node); + Start_Const_Value (Name_Cst); + Finish_Const_Value (Name_Cst, Str_Cst); + if Is_Instance then + Start_Association (Constr, Ghdl_Get_Instance_Name); + else + Start_Association (Constr, Ghdl_Get_Path_Name); + end if; + New_Association + (Constr, New_Address (New_Obj (Res), Std_String_Ptr_Node)); + if Name.Path_Instance = Null_Iir then + Rtis.Associate_Null_Rti_Context (Constr); + else + Rtis.Associate_Rti_Context (Constr, Name.Path_Instance); + end if; + New_Association (Constr, + New_Address (New_Obj (Name_Cst), + Ghdl_Str_Len_Ptr_Node)); + New_Procedure_Call (Constr); + return New_Address (New_Obj (Res), Std_String_Ptr_Node); + end Translate_Path_Instance_Name_Attribute; + end Chap14; + + package body Rtis is + -- Node for package, body, entity, architecture, block, generate, + -- processes. + Ghdl_Rtin_Block : O_Tnode; + Ghdl_Rtin_Block_Common : O_Fnode; + Ghdl_Rtin_Block_Name : O_Fnode; + Ghdl_Rtin_Block_Loc : O_Fnode; + Ghdl_Rtin_Block_Parent : O_Fnode; + Ghdl_Rtin_Block_Size : O_Fnode; + Ghdl_Rtin_Block_Nbr_Child : O_Fnode; + Ghdl_Rtin_Block_Children : O_Fnode; + + -- Node for scalar type decls. + Ghdl_Rtin_Type_Scalar : O_Tnode; + Ghdl_Rtin_Type_Scalar_Common : O_Fnode; + Ghdl_Rtin_Type_Scalar_Name : O_Fnode; + + -- Node for an enumeration type definition. + Ghdl_Rtin_Type_Enum : O_Tnode; + Ghdl_Rtin_Type_Enum_Common : O_Fnode; + Ghdl_Rtin_Type_Enum_Name : O_Fnode; + Ghdl_Rtin_Type_Enum_Nbr : O_Fnode; + Ghdl_Rtin_Type_Enum_Lits : O_Fnode; + + -- Node for an unit64. + Ghdl_Rtin_Unit64 : O_Tnode; + Ghdl_Rtin_Unit64_Common : O_Fnode; + Ghdl_Rtin_Unit64_Name : O_Fnode; + Ghdl_Rtin_Unit64_Value : O_Fnode; + + -- Node for an unitptr. + Ghdl_Rtin_Unitptr : O_Tnode; + Ghdl_Rtin_Unitptr_Common : O_Fnode; + Ghdl_Rtin_Unitptr_Name : O_Fnode; + Ghdl_Rtin_Unitptr_Value : O_Fnode; + + -- Node for a physical type + Ghdl_Rtin_Type_Physical : O_Tnode; + Ghdl_Rtin_Type_Physical_Common : O_Fnode; + Ghdl_Rtin_Type_Physical_Name : O_Fnode; + Ghdl_Rtin_Type_Physical_Nbr : O_Fnode; + Ghdl_Rtin_Type_Physical_Units : O_Fnode; + + -- Node for a scalar subtype definition. + Ghdl_Rtin_Subtype_Scalar : O_Tnode; + Ghdl_Rtin_Subtype_Scalar_Common : O_Fnode; + Ghdl_Rtin_Subtype_Scalar_Name : O_Fnode; + Ghdl_Rtin_Subtype_Scalar_Base : O_Fnode; + Ghdl_Rtin_Subtype_Scalar_Range : O_Fnode; + + -- Node for an access or a file type. + Ghdl_Rtin_Type_Fileacc : O_Tnode; + Ghdl_Rtin_Type_Fileacc_Common : O_Fnode; + Ghdl_Rtin_Type_Fileacc_Name : O_Fnode; + Ghdl_Rtin_Type_Fileacc_Base : O_Fnode; + + -- Node for an array type. + Ghdl_Rtin_Type_Array : O_Tnode; + Ghdl_Rtin_Type_Array_Common : O_Fnode; + Ghdl_Rtin_Type_Array_Name : O_Fnode; + Ghdl_Rtin_Type_Array_Element : O_Fnode; + Ghdl_Rtin_Type_Array_Nbrdim : O_Fnode; + Ghdl_Rtin_Type_Array_Indexes : O_Fnode; + + -- Node for an array subtype. + Ghdl_Rtin_Subtype_Array : O_Tnode; + Ghdl_Rtin_Subtype_Array_Common : O_Fnode; + Ghdl_Rtin_Subtype_Array_Name : O_Fnode; + Ghdl_Rtin_Subtype_Array_Basetype : O_Fnode; + Ghdl_Rtin_Subtype_Array_Bounds : O_Fnode; + Ghdl_Rtin_Subtype_Array_Valsize : O_Fnode; + Ghdl_Rtin_Subtype_Array_Sigsize : O_Fnode; + + -- Node for a record element. + Ghdl_Rtin_Element : O_Tnode; + Ghdl_Rtin_Element_Common : O_Fnode; + Ghdl_Rtin_Element_Name : O_Fnode; + Ghdl_Rtin_Element_Type : O_Fnode; + Ghdl_Rtin_Element_Valoff : O_Fnode; + Ghdl_Rtin_Element_Sigoff : O_Fnode; + + -- Node for a record type. + Ghdl_Rtin_Type_Record : O_Tnode; + Ghdl_Rtin_Type_Record_Common : O_Fnode; + Ghdl_Rtin_Type_Record_Name : O_Fnode; + Ghdl_Rtin_Type_Record_Nbrel : O_Fnode; + Ghdl_Rtin_Type_Record_Elements : O_Fnode; + --Ghdl_Rtin_Type_Record_Valsize : O_Fnode; + --Ghdl_Rtin_Type_Record_Sigsize : O_Fnode; + + -- Node for an object. + Ghdl_Rtin_Object : O_Tnode; + Ghdl_Rtin_Object_Common : O_Fnode; + Ghdl_Rtin_Object_Name : O_Fnode; + Ghdl_Rtin_Object_Loc : O_Fnode; + Ghdl_Rtin_Object_Type : O_Fnode; + + -- Node for an instance. + Ghdl_Rtin_Instance : O_Tnode; + Ghdl_Rtin_Instance_Common : O_Fnode; + Ghdl_Rtin_Instance_Name : O_Fnode; + Ghdl_Rtin_Instance_Loc : O_Fnode; + Ghdl_Rtin_Instance_Parent : O_Fnode; + Ghdl_Rtin_Instance_Type : O_Fnode; + + -- Node for a component. + Ghdl_Rtin_Component : O_Tnode; + Ghdl_Rtin_Component_Common : O_Fnode; + Ghdl_Rtin_Component_Name : O_Fnode; + Ghdl_Rtin_Component_Nbr_Child : O_Fnode; + Ghdl_Rtin_Component_Children : O_Fnode; + + procedure Rti_Initialize + is + begin + -- Create type ghdl_rti_kind is (ghdl_rtik_typedef_bool, ...) + declare + Constr : O_Enum_List; + begin + Start_Enum_Type (Constr, 8); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_top"), + Ghdl_Rtik_Top); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_library"), + Ghdl_Rtik_Library); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_package"), + Ghdl_Rtik_Package); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_package_body"), + Ghdl_Rtik_Package_Body); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_entity"), + Ghdl_Rtik_Entity); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_architecture"), + Ghdl_Rtik_Architecture); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_process"), + Ghdl_Rtik_Process); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_block"), + Ghdl_Rtik_Block); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_if_generate"), + Ghdl_Rtik_If_Generate); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_for_generate"), + Ghdl_Rtik_For_Generate); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_instance"), + Ghdl_Rtik_Instance); + + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_constant"), + Ghdl_Rtik_Constant); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_iterator"), + Ghdl_Rtik_Iterator); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_variable"), + Ghdl_Rtik_Variable); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_signal"), + Ghdl_Rtik_Signal); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_file"), + Ghdl_Rtik_File); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_port"), + Ghdl_Rtik_Port); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_generic"), + Ghdl_Rtik_Generic); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_alias"), + Ghdl_Rtik_Alias); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_guard"), + Ghdl_Rtik_Guard); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_component"), + Ghdl_Rtik_Component); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_attribute"), + Ghdl_Rtik_Attribute); + + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_b1"), + Ghdl_Rtik_Type_B1); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_e8"), + Ghdl_Rtik_Type_E8); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_e32"), + Ghdl_Rtik_Type_E32); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_i32"), + Ghdl_Rtik_Type_I32); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_i64"), + Ghdl_Rtik_Type_I64); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_f64"), + Ghdl_Rtik_Type_F64); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_p32"), + Ghdl_Rtik_Type_P32); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_p64"), + Ghdl_Rtik_Type_P64); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_access"), + Ghdl_Rtik_Type_Access); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_array"), + Ghdl_Rtik_Type_Array); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_record"), + Ghdl_Rtik_Type_Record); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_file"), + Ghdl_Rtik_Type_File); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_scalar"), + Ghdl_Rtik_Subtype_Scalar); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_array"), + Ghdl_Rtik_Subtype_Array); + New_Enum_Literal + (Constr, + Get_Identifier ("__ghdl_rtik_subtype_unconstrained_array"), + Ghdl_Rtik_Subtype_Unconstrained_Array); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_record"), + Ghdl_Rtik_Subtype_Record); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_subtype_access"), + Ghdl_Rtik_Subtype_Access); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_type_protected"), + Ghdl_Rtik_Type_Protected); + + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_element"), + Ghdl_Rtik_Element); + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_unit64"), + Ghdl_Rtik_Unit64); + New_Enum_Literal (Constr, Get_Identifier ("__ghdl_rtik_unitptr"), + Ghdl_Rtik_Unitptr); + + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_attribute_transaction"), + Ghdl_Rtik_Attribute_Transaction); + New_Enum_Literal + (Constr, Get_Identifier ("__ghdl_rtik_attribute_quiet"), + Ghdl_Rtik_Attribute_Quiet); + New_Enum_Literal + (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); + New_Type_Decl (Get_Identifier ("__ghdl_rtik"), Ghdl_Rtik); + end; + + -- Create type ghdl_rti_depth. + Ghdl_Rti_Depth := New_Unsigned_Type (8); + New_Type_Decl (Get_Identifier ("__ghdl_rti_depth"), Ghdl_Rti_Depth); + Ghdl_Rti_U8 := New_Unsigned_Type (8); + New_Type_Decl (Get_Identifier ("__ghdl_rti_u8"), Ghdl_Rti_U8); + + -- Create type ghdl_rti_common. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rti_Common_Kind, + Get_Identifier ("kind"), Ghdl_Rtik); + New_Record_Field (Constr, Ghdl_Rti_Common_Depth, + Get_Identifier ("depth"), Ghdl_Rti_Depth); + New_Record_Field (Constr, Ghdl_Rti_Common_Mode, + Get_Identifier ("mode"), Ghdl_Rti_U8); + New_Record_Field (Constr, Ghdl_Rti_Common_Max_Depth, + Get_Identifier ("max_depth"), Ghdl_Rti_Depth); + Finish_Record_Type (Constr, Ghdl_Rti_Common); + New_Type_Decl (Get_Identifier ("__ghdl_rti_common"), + Ghdl_Rti_Common); + end; + + Ghdl_Rti_Access := New_Access_Type (Ghdl_Rti_Common); + New_Type_Decl (Get_Identifier ("__ghdl_rti_access"), Ghdl_Rti_Access); + + Ghdl_Rti_Array := New_Array_Type (Ghdl_Rti_Access, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_rti_array"), Ghdl_Rti_Array); + + Ghdl_Rti_Arr_Acc := New_Access_Type (Ghdl_Rti_Array); + New_Type_Decl (Get_Identifier ("__ghdl_rti_arr_acc"), + Ghdl_Rti_Arr_Acc); + + -- Ghdl_Component_Link_Type. + New_Uncomplete_Record_Type (Ghdl_Component_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_component_link_type"), + Ghdl_Component_Link_Type); + + Ghdl_Component_Link_Acc := New_Access_Type (Ghdl_Component_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_component_link_acc"), + Ghdl_Component_Link_Acc); + + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Entity_Link_Rti, + Get_Identifier ("rti"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Entity_Link_Parent, + Wki_Parent, Ghdl_Component_Link_Acc); + Finish_Record_Type (Constr, Ghdl_Entity_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_entity_link_type"), + Ghdl_Entity_Link_Type); + end; + + Ghdl_Entity_Link_Acc := New_Access_Type (Ghdl_Entity_Link_Type); + New_Type_Decl (Get_Identifier ("__ghdl_entity_link_acc"), + Ghdl_Entity_Link_Acc); + + declare + Constr : O_Element_List; + begin + Start_Uncomplete_Record_Type (Ghdl_Component_Link_Type, Constr); + New_Record_Field (Constr, Ghdl_Component_Link_Instance, + Wki_Instance, Ghdl_Entity_Link_Acc); + New_Record_Field (Constr, Ghdl_Component_Link_Stmt, + Get_Identifier ("stmt"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Component_Link_Type); + end; + + -- Create type ghdl_rtin_block + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Block_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Block_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Loc, + Get_Identifier ("loc"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Parent, + Wki_Parent, Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Block_Size, + Get_Identifier ("size"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Nbr_Child, + Get_Identifier ("nbr_child"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Block_Children, + Get_Identifier ("children"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Block); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_block"), + Ghdl_Rtin_Block); + end; + + -- type (type and subtype declarations). + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Scalar_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Scalar_Name, + Get_Identifier ("name"), Char_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Scalar); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_scalar"), + Ghdl_Rtin_Type_Scalar); + end; + + -- Type_Enum + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Nbr, + Get_Identifier ("nbr"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Enum_Lits, + Get_Identifier ("lits"), + Char_Ptr_Array_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Enum); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_enum"), + Ghdl_Rtin_Type_Enum); + end; + + -- subtype_scalar + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Base, + Get_Identifier ("base"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Scalar_Range, + Get_Identifier ("range"), Ghdl_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Scalar); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_scalar"), + Ghdl_Rtin_Subtype_Scalar); + end; + + -- Unit64 + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Unit64_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Unit64_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Unit64_Value, + Wki_Val, Ghdl_I64_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Unit64); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_unit64"), + Ghdl_Rtin_Unit64); + end; + + -- Unitptr + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Unitptr_Value, + Get_Identifier ("addr"), Ghdl_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Unitptr); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_unitptr"), + Ghdl_Rtin_Unitptr); + end; + + -- Physical type. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Nbr, + Get_Identifier ("nbr"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Physical_Units, + Get_Identifier ("units"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Physical); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_physical"), + Ghdl_Rtin_Type_Physical); + end; + + -- file and access type. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Fileacc_Base, + Get_Identifier ("base"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Fileacc); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_fileacc"), + Ghdl_Rtin_Type_Fileacc); + end; + + -- arraytype. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Element, + Get_Identifier ("element"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Nbrdim, + Get_Identifier ("nbr_dim"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Array_Indexes, + Get_Identifier ("indexes"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Array); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_array"), + Ghdl_Rtin_Type_Array); + end; + + -- subtype_Array. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Basetype, + Get_Identifier ("basetype"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Bounds, + Get_Identifier ("bounds"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Valsize, + Get_Identifier ("val_size"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Subtype_Array_Sigsize, + Get_Identifier ("sig_size"), Ghdl_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Array); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_array"), + Ghdl_Rtin_Subtype_Array); + end; + + -- type record. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Nbrel, + Get_Identifier ("nbrel"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Elements, + Get_Identifier ("elements"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Type_Record); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_record"), + Ghdl_Rtin_Type_Record); + end; + + -- record element. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Element_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Element_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Element_Type, + Get_Identifier ("eltype"), Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Element_Valoff, + Get_Identifier ("val_off"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Element_Sigoff, + Get_Identifier ("sig_off"), Ghdl_Index_Type); + Finish_Record_Type (Constr, Ghdl_Rtin_Element); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_element"), + Ghdl_Rtin_Element); + end; + + -- Object. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Object_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Object_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Object_Loc, + Get_Identifier ("loc"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Object_Type, + Get_Identifier ("obj_type"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Rtin_Object); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_object"), + Ghdl_Rtin_Object); + end; + + -- Instance. + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Loc, + Get_Identifier ("loc"), Ghdl_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Parent, + Wki_Parent, Ghdl_Rti_Access); + New_Record_Field (Constr, Ghdl_Rtin_Instance_Type, + Get_Identifier ("instance"), Ghdl_Rti_Access); + Finish_Record_Type (Constr, Ghdl_Rtin_Instance); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_instance"), + Ghdl_Rtin_Instance); + end; + + -- Component + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Rtin_Component_Common, + Get_Identifier ("common"), Ghdl_Rti_Common); + New_Record_Field (Constr, Ghdl_Rtin_Component_Name, + Get_Identifier ("name"), Char_Ptr_Type); + New_Record_Field (Constr, Ghdl_Rtin_Component_Nbr_Child, + Get_Identifier ("nbr_child"), Ghdl_Index_Type); + New_Record_Field (Constr, Ghdl_Rtin_Component_Children, + Get_Identifier ("children"), Ghdl_Rti_Arr_Acc); + Finish_Record_Type (Constr, Ghdl_Rtin_Component); + New_Type_Decl (Get_Identifier ("__ghdl_rtin_component"), + Ghdl_Rtin_Component); + end; + + end Rti_Initialize; + + type Rti_Array is array (1 .. 8) of O_Dnode; + type Rti_Array_List; + type Rti_Array_List_Acc is access Rti_Array_List; + type Rti_Array_List is record + Rtis : Rti_Array; + Next : Rti_Array_List_Acc; + end record; + + type Rti_Block is record + Depth : Rti_Depth_Type; + Nbr : Integer; + List : Rti_Array_List; + Last_List : Rti_Array_List_Acc; + Last_Nbr : Integer; + end record; + + Cur_Block : Rti_Block := (Depth => 0, + Nbr => 0, + List => (Rtis => (others => O_Dnode_Null), + Next => null), + Last_List => null, + Last_Nbr => 0); + + Free_List : Rti_Array_List_Acc := null; + + procedure Push_Rti_Node (Prev : out Rti_Block; Deeper : Boolean := True) + is + Ndepth : Rti_Depth_Type; + begin + if Deeper then + Ndepth := Cur_Block.Depth + 1; + else + Ndepth := Cur_Block.Depth; + end if; + Prev := Cur_Block; + Cur_Block := (Depth => Ndepth, + Nbr => 0, + List => (Rtis => (others => O_Dnode_Null), + Next => null), + Last_List => null, + Last_Nbr => 0); + end Push_Rti_Node; + + procedure Add_Rti_Node (Node : O_Dnode) + is + begin + if Node = O_Dnode_Null then + -- FIXME: temporary for not yet handled types. + return; + end if; + if Cur_Block.Last_Nbr = Rti_Array'Last then + declare + N : Rti_Array_List_Acc; + begin + if Free_List = null then + N := new Rti_Array_List; + else + N := Free_List; + Free_List := N.Next; + end if; + N.Next := null; + if Cur_Block.Last_List = null then + Cur_Block.List.Next := N; + else + Cur_Block.Last_List.Next := N; + end if; + Cur_Block.Last_List := N; + end; + Cur_Block.Last_Nbr := 1; + else + Cur_Block.Last_Nbr := Cur_Block.Last_Nbr + 1; + end if; + if Cur_Block.Last_List = null then + Cur_Block.List.Rtis (Cur_Block.Last_Nbr) := Node; + else + Cur_Block.Last_List.Rtis (Cur_Block.Last_Nbr) := Node; + end if; + Cur_Block.Nbr := Cur_Block.Nbr + 1; + end Add_Rti_Node; + + function Generate_Rti_Array (Id : O_Ident) return O_Dnode + is + Arr_Type : O_Tnode; + List : O_Array_Aggr_List; + L : Rti_Array_List_Acc; + Nbr : Integer; + Val : O_Cnode; + Res : O_Dnode; + begin + Arr_Type := New_Constrained_Array_Type + (Ghdl_Rti_Array, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Cur_Block.Nbr + 1))); + New_Const_Decl (Res, Id, O_Storage_Private, Arr_Type); + Start_Const_Value (Res); + Start_Array_Aggr (List, Arr_Type); + Nbr := Cur_Block.Nbr; + for I in Cur_Block.List.Rtis'Range loop + exit when I > Nbr; + New_Array_Aggr_El + (List, New_Global_Unchecked_Address (Cur_Block.List.Rtis (I), + Ghdl_Rti_Access)); + end loop; + L := Cur_Block.List.Next; + while L /= null loop + Nbr := Nbr - Cur_Block.List.Rtis'Length; + for I in L.Rtis'Range loop + exit when I > Nbr; + New_Array_Aggr_El + (List, New_Global_Unchecked_Address (L.Rtis (I), + Ghdl_Rti_Access)); + end loop; + L := L.Next; + end loop; + New_Array_Aggr_El (List, New_Null_Access (Ghdl_Rti_Access)); + Finish_Array_Aggr (List, Val); + Finish_Const_Value (Res, Val); + return Res; + end Generate_Rti_Array; + + procedure Pop_Rti_Node (Prev : Rti_Block) + is + L : Rti_Array_List_Acc; + begin + L := Cur_Block.List.Next; + if L /= null then + Cur_Block.Last_List.Next := Free_List; + Free_List := Cur_Block.List.Next; + Cur_Block.List.Next := null; + end if; + Cur_Block := Prev; + end Pop_Rti_Node; + + function Get_Depth_From_Var (Var : Var_Type) return Rti_Depth_Type + is + begin + if Var = Null_Var or else Is_Var_Field (Var) then + return Cur_Block.Depth; + else + return 0; + end if; + end Get_Depth_From_Var; + + function Generate_Common + (Kind : O_Cnode; Var : Var_Type := Null_Var; Mode : Natural := 0) + return O_Cnode + is + List : O_Record_Aggr_List; + Res : O_Cnode; + Val : Unsigned_64; + begin + Start_Record_Aggr (List, Ghdl_Rti_Common); + New_Record_Aggr_El (List, Kind); + Val := Unsigned_64 (Get_Depth_From_Var (Var)); + New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Rti_Depth, Val)); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Rti_U8, Unsigned_64 (Mode))); + New_Record_Aggr_El (List, New_Unsigned_Literal (Ghdl_Rti_Depth, 0)); + Finish_Record_Aggr (List, Res); + return Res; + end Generate_Common; + + -- Same as Generat_Common but for types. + function Generate_Common_Type (Kind : O_Cnode; + Depth : Rti_Depth_Type; + Max_Depth : Rti_Depth_Type; + Mode : Natural := 0) + return O_Cnode + is + List : O_Record_Aggr_List; + Res : O_Cnode; + begin + Start_Record_Aggr (List, Ghdl_Rti_Common); + New_Record_Aggr_El (List, Kind); + New_Record_Aggr_El + (List, + New_Unsigned_Literal (Ghdl_Rti_Depth, Unsigned_64 (Depth))); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Rti_U8, Unsigned_64 (Mode))); + New_Record_Aggr_El + (List, + New_Unsigned_Literal (Ghdl_Rti_Depth, Unsigned_64 (Max_Depth))); + Finish_Record_Aggr (List, Res); + return Res; + end Generate_Common_Type; + + function Generate_Name (Node : Iir) return O_Dnode + is + use Name_Table; + Id : Name_Id; + begin + Id := Get_Identifier (Node); + if Is_Character (Id) then + Name_Buffer (1) := '''; + Name_Buffer (2) := Get_Character (Id); + Name_Buffer (3) := '''; + Name_Length := 3; + else + Image (Id); + end if; + return Create_String (Name_Buffer (1 .. Name_Length), + Create_Identifier ("RTISTR")); + end Generate_Name; + + function Get_Null_Loc return O_Cnode is + begin + return New_Null_Access (Ghdl_Ptr_Type); + end Get_Null_Loc; + + function Var_Acc_To_Loc (Var : Var_Type) return O_Cnode + is + begin + if Is_Var_Field (Var) then + return Get_Var_Offset (Var, Ghdl_Ptr_Type); + else + return New_Global_Unchecked_Address (Get_Var_Label (Var), + Ghdl_Ptr_Type); + end if; + end Var_Acc_To_Loc; + + -- Generate a name constant for the name of type definition DEF. + -- If DEF is an anonymous subtype, returns O_LNODE_NULL. + -- Use function NEW_NAME_ADDRESS (defined below) to convert the + -- result into an address expression. + function Generate_Type_Name (Def : Iir) return O_Dnode + is + Decl : Iir; + begin + Decl := Get_Type_Declarator (Def); + if Decl /= Null_Iir then + return Generate_Name (Decl); + else + return O_Dnode_Null; + end if; + end Generate_Type_Name; + + -- Convert a name constant NAME into an address. + -- If NAME is O_LNODE_NULL, return a null address. + -- To be used with GENERATE_TYPE_NAME. + function New_Name_Address (Name : O_Dnode) return O_Cnode + is + begin + if Name = O_Dnode_Null then + return New_Null_Access (Char_Ptr_Type); + else + return New_Global_Unchecked_Address (Name, Char_Ptr_Type); + end if; + end New_Name_Address; + + function New_Rti_Address (Rti : O_Dnode) return O_Cnode is + begin + return New_Global_Unchecked_Address (Rti, Ghdl_Rti_Access); + end New_Rti_Address; + + -- Declare the RTI constant for type definition attached to INFO. + -- The only feature is not to declare it if it was already declared. + -- (due to an incomplete type declaration). + procedure Generate_Type_Rti (Info : Type_Info_Acc; Rti_Type : O_Tnode) + is + begin + if Info.Type_Rti = O_Dnode_Null then + New_Const_Decl (Info.Type_Rti, Create_Identifier ("RTI"), + Global_Storage, Rti_Type); + end if; + end Generate_Type_Rti; + + function Generate_Type_Definition (Atype : Iir; Force : Boolean := False) + return O_Dnode; + + procedure Generate_Enumeration_Type_Definition (Atype : Iir) + is + Info : constant Type_Info_Acc := Get_Info (Atype); + Val : O_Cnode; + begin + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Enum); + Info.T.Rti_Max_Depth := 0; + + if Global_Storage = O_Storage_External then + return; + end if; + + declare + Lit_List : constant Iir_List := + Get_Enumeration_Literal_List (Atype); + Nbr_Lit : constant Integer := Get_Nbr_Elements (Lit_List); + Lit : Iir; + + type Dnode_Array is array (Natural range <>) of O_Dnode; + Name_Lits : Dnode_Array (0 .. Nbr_Lit - 1); + Mark : Id_Mark_Type; + Name_Arr_Type : O_Tnode; + Name_Arr : O_Dnode; + + Arr_Aggr : O_Array_Aggr_List; + Rec_Aggr : O_Record_Aggr_List; + Kind : O_Cnode; + Name : O_Dnode; + begin + -- Generate name for each literal. + for I in Name_Lits'Range loop + Lit := Get_Nth_Element (Lit_List, I); + Push_Identifier_Prefix (Mark, Get_Identifier (Lit)); + Name_Lits (I) := Generate_Name (Lit); + Pop_Identifier_Prefix (Mark); + end loop; + + -- Generate array of names. + Name_Arr_Type := New_Constrained_Array_Type + (Char_Ptr_Array_Type, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Lit))); + New_Const_Decl (Name_Arr, Create_Identifier ("RTINAMES"), + O_Storage_Private, Name_Arr_Type); + Start_Const_Value (Name_Arr); + Start_Array_Aggr (Arr_Aggr, Name_Arr_Type); + for I in Name_Lits'Range loop + New_Array_Aggr_El + (Arr_Aggr, New_Global_Address (Name_Lits (I), Char_Ptr_Type)); + end loop; + Finish_Array_Aggr (Arr_Aggr, Val); + Finish_Const_Value (Name_Arr, Val); + + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + case Info.Type_Mode is + when Type_Mode_B1 => + Kind := Ghdl_Rtik_Type_B1; + when Type_Mode_E8 => + Kind := Ghdl_Rtik_Type_E8; + when Type_Mode_E32 => + Kind := Ghdl_Rtik_Type_E32; + when others => + raise Internal_Error; + end case; + Start_Record_Aggr (Rec_Aggr, Ghdl_Rtin_Type_Enum); + New_Record_Aggr_El (Rec_Aggr, Generate_Common_Type (Kind, 0, 0)); + New_Record_Aggr_El (Rec_Aggr, New_Name_Address (Name)); + New_Record_Aggr_El + (Rec_Aggr, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Lit))); + New_Record_Aggr_El + (Rec_Aggr, + New_Global_Address (Name_Arr, Char_Ptr_Array_Ptr_Type)); + Finish_Record_Aggr (Rec_Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end; + end Generate_Enumeration_Type_Definition; + + procedure Generate_Scalar_Type_Definition (Atype : Iir; Name : O_Dnode) + is + Info : Type_Info_Acc; + Kind : O_Cnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Scalar); + Info.T.Rti_Max_Depth := 0; + + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Const_Value (Info.Type_Rti); + 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 => + Kind := Ghdl_Rtik_Type_P64; + when others => + Error_Kind ("generate_scalar_type_definition", Atype); + end case; + Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El (List, Generate_Common_Type (Kind, 0, 0)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Scalar_Type_Definition; + + procedure Generate_Unit_Declaration (Unit : Iir_Unit_Declaration) + is + Name : O_Dnode; + Mark : Id_Mark_Type; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + Const : O_Dnode; + Info : constant Object_Info_Acc := Get_Info (Unit); + Rti_Type : O_Tnode; + Rtik : O_Cnode; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Unit)); + Name := Generate_Name (Unit); + if Info /= null then + -- Non-static units. The only possibility is a unit of + -- std.standard.time. + Rti_Type := Ghdl_Rtin_Unitptr; + Rtik := Ghdl_Rtik_Unitptr; + else + Rti_Type := Ghdl_Rtin_Unit64; + Rtik := Ghdl_Rtik_Unit64; + end if; + New_Const_Decl (Const, Create_Identifier ("RTI"), + Global_Storage, Rti_Type); + Start_Const_Value (Const); + Start_Record_Aggr (Aggr, Rti_Type); + New_Record_Aggr_El (Aggr, Generate_Common (Rtik)); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + if Info /= null then + -- Handle non-static units. The only possibility is a unit of + -- std.standard.time. + Val := New_Global_Unchecked_Address + (Get_Var_Label (Info.Object_Var), Ghdl_Ptr_Type); + else + Val := Chap7.Translate_Numeric_Literal (Unit, Ghdl_I64_Type); + end if; + New_Record_Aggr_El (Aggr, Val); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Const, Val); + Add_Rti_Node (Const); + Pop_Identifier_Prefix (Mark); + end Generate_Unit_Declaration; + + procedure Generate_Physical_Type_Definition (Atype : Iir; Name : O_Dnode) + is + Info : Type_Info_Acc; + Val : O_Cnode; + List : O_Record_Aggr_List; + Prev : Rti_Block; + Unit : Iir_Unit_Declaration; + Nbr_Units : Integer; + Unit_Arr : O_Dnode; + Rti_Kind : O_Cnode; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Physical); + + if Global_Storage = O_Storage_External then + return; + end if; + + Push_Rti_Node (Prev, False); + Unit := Get_Unit_Chain (Atype); + Nbr_Units := 0; + while Unit /= Null_Iir loop + Generate_Unit_Declaration (Unit); + Nbr_Units := Nbr_Units + 1; + Unit := Get_Chain (Unit); + end loop; + Unit_Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + Pop_Rti_Node (Prev); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Physical); + case Info.Type_Mode is + when Type_Mode_P64 => + Rti_Kind := Ghdl_Rtik_Type_P64; + when Type_Mode_P32 => + Rti_Kind := Ghdl_Rtik_Type_P32; + when others => + raise Internal_Error; + end case; + New_Record_Aggr_El (List, Generate_Common_Type (Rti_Kind, 0, 0, 0)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + New_Record_Aggr_El + (List, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Units))); + New_Record_Aggr_El + (List, New_Global_Address (Unit_Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Physical_Type_Definition; + + procedure Generate_Scalar_Subtype_Definition (Atype : Iir) + is + Base_Type : Iir; + Base_Info : Type_Info_Acc; + Info : Type_Info_Acc; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + Name : O_Dnode; + begin + Info := Get_Info (Atype); + + if Global_Storage = O_Storage_External then + Name := O_Dnode_Null; + else + Name := Generate_Type_Name (Atype); + end if; + + -- Generate base type definition, if necessary. + -- (do it even in packages). + Base_Type := Get_Base_Type (Atype); + Base_Info := Get_Info (Base_Type); + if Base_Info.Type_Rti = O_Dnode_Null then + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, "BT"); + if Get_Kind (Base_Type) = Iir_Kind_Physical_Type_Definition then + Generate_Physical_Type_Definition (Base_Type, Name); + else + Generate_Scalar_Type_Definition (Base_Type, Name); + end if; + Pop_Identifier_Prefix (Mark); + end; + end if; + + Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Scalar); + Info.T.Rti_Max_Depth := Get_Depth_From_Var (Info.T.Range_Var); + if Global_Storage = O_Storage_External then + return; + end if; + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Scalar); + New_Record_Aggr_El + (Aggr, Generate_Common_Type (Ghdl_Rtik_Subtype_Scalar, + Info.T.Rti_Max_Depth, + Info.T.Rti_Max_Depth)); + + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); + New_Record_Aggr_El (Aggr, Var_Acc_To_Loc (Info.T.Range_Var)); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Scalar_Subtype_Definition; + + procedure Generate_Fileacc_Type_Definition (Atype : Iir) + is + Info : Type_Info_Acc; + Kind : O_Cnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + Name : O_Dnode; + Base : O_Dnode; + Base_Type : Iir; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Fileacc); + + if Global_Storage = O_Storage_External then + return; + end if; + + case Get_Kind (Atype) is + when Iir_Kind_Access_Type_Definition => + declare + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, "AT"); + Base := Generate_Type_Definition + (Get_Designated_Type (Atype)); + Pop_Identifier_Prefix (Mark); + end; + if Get_Kind (Atype) = Iir_Kind_Access_Subtype_Definition then + Kind := Ghdl_Rtik_Subtype_Access; + else + Kind := Ghdl_Rtik_Type_Access; + end if; + -- Don't bother with designated type. This at least avoid + -- loops. + Base_Type := Null_Iir; + when Iir_Kind_File_Type_Definition => + Base_Type := Get_Type (Get_File_Type_Mark (Atype)); + Base := Generate_Type_Definition (Base_Type); + Kind := Ghdl_Rtik_Type_File; + when Iir_Kind_Record_Subtype_Definition => + Base_Type := Get_Base_Type (Atype); + Base := Get_Info (Base_Type).Type_Rti; + Kind := Ghdl_Rtik_Subtype_Record; + when Iir_Kind_Access_Subtype_Definition => + Base_Type := Get_Base_Type (Atype); + Base := Get_Info (Base_Type).Type_Rti; + Kind := Ghdl_Rtik_Subtype_Access; + when others => + Error_Kind ("rti.generate_fileacc_type_definition", Atype); + end case; + if Base_Type = Null_Iir then + Info.T.Rti_Max_Depth := 0; + else + Info.T.Rti_Max_Depth := Get_Info (Base_Type).T.Rti_Max_Depth; + end if; + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Fileacc); + New_Record_Aggr_El + (List, Generate_Common_Type (Kind, 0, Info.T.Rti_Max_Depth)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + New_Record_Aggr_El (List, New_Rti_Address (Base)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Fileacc_Type_Definition; + + procedure Generate_Array_Type_Indexes + (Atype : Iir; Res : out O_Dnode; Max_Depth : in out Rti_Depth_Type) + is + List : constant Iir_List := Get_Index_Subtype_List (Atype); + Nbr_Indexes : constant Natural := Get_Nbr_Elements (List); + Index : Iir; + Tmp : O_Dnode; + pragma Unreferenced (Tmp); + Arr_Type : O_Tnode; + Arr_Aggr : O_Array_Aggr_List; + Val : O_Cnode; + Mark : Id_Mark_Type; + begin + -- Translate each index. + for I in 1 .. Nbr_Indexes loop + Index := Get_Index_Type (List, I - 1); + Push_Identifier_Prefix (Mark, "DIM", Iir_Int32 (I)); + Tmp := Generate_Type_Definition (Index); + Max_Depth := Rti_Depth_Type'Max (Max_Depth, + Get_Info (Index).T.Rti_Max_Depth); + Pop_Identifier_Prefix (Mark); + end loop; + + -- Generate array of index. + Arr_Type := New_Constrained_Array_Type + (Ghdl_Rti_Array, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Indexes))); + New_Const_Decl (Res, Create_Identifier ("RTIINDEXES"), + Global_Storage, Arr_Type); + Start_Const_Value (Res); + + Start_Array_Aggr (Arr_Aggr, Arr_Type); + for I in 1 .. Nbr_Indexes loop + Index := Get_Index_Type (List, I - 1); + New_Array_Aggr_El + (Arr_Aggr, New_Rti_Address (Generate_Type_Definition (Index))); + end loop; + Finish_Array_Aggr (Arr_Aggr, Val); + Finish_Const_Value (Res, Val); + end Generate_Array_Type_Indexes; + + function Type_To_Mode (Atype : Iir) return Natural is + Res : Natural := 0; + begin + if Is_Complex_Type (Get_Info (Atype)) then + Res := Res + 1; + end if; + if Is_Anonymous_Type_Definition (Atype) + or else (Get_Kind (Get_Type_Declarator (Atype)) + = Iir_Kind_Anonymous_Type_Declaration) + then + Res := Res + 2; + end if; + return Res; + end Type_To_Mode; + + procedure Generate_Array_Type_Definition + (Atype : Iir_Array_Type_Definition) + is + Info : Type_Info_Acc; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + List : Iir_List; + Arr : O_Dnode; + Element : Iir; + Name : O_Dnode; + El_Info : Type_Info_Acc; + Max_Depth : Rti_Depth_Type; + begin + Info := Get_Info (Atype); + + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Array); + + if Global_Storage = O_Storage_External then + return; + end if; + + Name := Generate_Type_Name (Atype); + Element := Get_Element_Subtype (Atype); + El_Info := Get_Info (Element); + if El_Info.Type_Rti = O_Dnode_Null then + declare + Mark : Id_Mark_Type; + El_Rti : O_Dnode; + pragma Unreferenced (El_Rti); + begin + Push_Identifier_Prefix (Mark, "EL"); + El_Rti := Generate_Type_Definition (Element); + Pop_Identifier_Prefix (Mark); + end; + end if; + Max_Depth := El_Info.T.Rti_Max_Depth; + + -- Translate each index. + Generate_Array_Type_Indexes (Atype, Arr, Max_Depth); + Info.T.Rti_Max_Depth := Max_Depth; + List := Get_Index_Subtype_List (Atype); + + -- Generate node. + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Array); + New_Record_Aggr_El + (Aggr, + Generate_Common_Type + (Ghdl_Rtik_Type_Array, 0, Max_Depth, Type_To_Mode (Atype))); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (El_Info.Type_Rti)); + New_Record_Aggr_El + (Aggr, + New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Get_Nbr_Elements (List)))); + New_Record_Aggr_El (Aggr, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Array_Type_Definition; + + procedure Generate_Array_Subtype_Definition + (Atype : Iir_Array_Subtype_Definition) + is + Base_Type : Iir; + Base_Info : Type_Info_Acc; + Info : Type_Info_Acc; + Aggr : O_Record_Aggr_List; + Val : O_Cnode; + Base_Rti : O_Dnode; + pragma Unreferenced (Base_Rti); + Bounds : Var_Type; + Name : O_Dnode; + Kind : O_Cnode; + Mark : Id_Mark_Type; + Depth : Rti_Depth_Type; + begin + -- FIXME: temporary work-around + if Get_Constraint_State (Atype) /= Fully_Constrained then + return; + end if; + + Info := Get_Info (Atype); + + Base_Type := Get_Base_Type (Atype); + Base_Info := Get_Info (Base_Type); + if Base_Info.Type_Rti = O_Dnode_Null then + Push_Identifier_Prefix (Mark, "BT"); + Base_Rti := Generate_Type_Definition (Base_Type); + Pop_Identifier_Prefix (Mark); + end if; + + Bounds := Info.T.Array_Bounds; + Depth := Get_Depth_From_Var (Bounds); + Info.T.Rti_Max_Depth := + Rti_Depth_Type'Max (Depth, Base_Info.T.Rti_Max_Depth); + + -- Generate node. + Generate_Type_Rti (Info, Ghdl_Rtin_Subtype_Array); + + if Global_Storage = O_Storage_External then + return; + end if; + + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Subtype_Array); + case Info.Type_Mode is + when Type_Mode_Array => + Kind := Ghdl_Rtik_Subtype_Array; + when Type_Mode_Fat_Array => + Kind := Ghdl_Rtik_Subtype_Unconstrained_Array; + when others => + Error_Kind ("generate_array_subtype_definition", Atype); + end case; + New_Record_Aggr_El + (Aggr, + Generate_Common_Type + (Kind, Depth, Info.T.Rti_Max_Depth, Type_To_Mode (Atype))); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); + if Bounds = Null_Var then + Val := Get_Null_Loc; + else + Val := Var_Acc_To_Loc (Bounds); + end if; + New_Record_Aggr_El (Aggr, Val); + for I in Mode_Value .. Mode_Signal loop + case Info.Type_Mode is + when Type_Mode_Array => + Val := Get_Null_Loc; + if Info.Ortho_Type (I) /= O_Tnode_Null then + if Is_Complex_Type (Info) then + if Info.C (I).Size_Var /= Null_Var then + Val := Var_Acc_To_Loc (Info.C (I).Size_Var); + end if; + else + Val := New_Sizeof (Info.Ortho_Type (I), + Ghdl_Ptr_Type); + end if; + end if; + when Type_Mode_Fat_Array => + Val := Get_Null_Loc; + when others => + Error_Kind ("generate_array_subtype_definition", Atype); + end case; + New_Record_Aggr_El (Aggr, Val); + end loop; + + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Array_Subtype_Definition; + + procedure Generate_Record_Type_Definition (Atype : Iir) + is + El_List : Iir_List; + El : Iir; + Prev : Rti_Block; + El_Arr : O_Dnode; + Res : O_Cnode; + Info : constant Type_Info_Acc := Get_Info (Atype); + Max_Depth : Rti_Depth_Type; + begin + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Record); + if Global_Storage = O_Storage_External then + return; + end if; + + El_List := Get_Elements_Declaration_List (Atype); + Max_Depth := 0; + + -- Generate elements. + Push_Rti_Node (Prev, False); + for I in Natural loop + El := Get_Nth_Element (El_List, I); + exit when El = Null_Iir; + declare + Type_Rti : O_Dnode; + El_Name : O_Dnode; + El_Type : constant Iir := Get_Type (El); + Aggr : O_Record_Aggr_List; + Field_Info : constant Field_Info_Acc := Get_Info (El); + Val : O_Cnode; + El_Const : O_Dnode; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (El)); + + Type_Rti := Generate_Type_Definition (El_Type); + Max_Depth := + Rti_Depth_Type'Max (Max_Depth, + Get_Info (El_Type).T.Rti_Max_Depth); + + El_Name := Generate_Name (El); + New_Const_Decl (El_Const, Create_Identifier ("RTIEL"), + Global_Storage, Ghdl_Rtin_Element); + Start_Const_Value (El_Const); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Element); + New_Record_Aggr_El (Aggr, + Generate_Common (Ghdl_Rtik_Element)); + New_Record_Aggr_El (Aggr, New_Name_Address (El_Name)); + New_Record_Aggr_El (Aggr, New_Rti_Address (Type_Rti)); + for I in Object_Kind_Type loop + if Field_Info.Field_Node (I) /= O_Fnode_Null then + Val := New_Offsetof (Info.Ortho_Type (I), + Field_Info.Field_Node (I), + Ghdl_Index_Type); + else + Val := Ghdl_Index_0; + end if; + New_Record_Aggr_El (Aggr, Val); + end loop; + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (El_Const, Val); + Add_Rti_Node (El_Const); + + Pop_Identifier_Prefix (Mark); + end; + end loop; + El_Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + Pop_Rti_Node (Prev); + + Info.T.Rti_Max_Depth := Max_Depth; + -- Generate record. + declare + Aggr : O_Record_Aggr_List; + Name : O_Dnode; + begin + Name := Generate_Type_Name (Atype); + + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Record); + New_Record_Aggr_El + (Aggr, + Generate_Common_Type (Ghdl_Rtik_Type_Record, 0, Max_Depth, + Type_To_Mode (Atype))); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + New_Record_Aggr_El + (Aggr, New_Unsigned_Literal + (Ghdl_Index_Type, Unsigned_64 (Get_Nbr_Elements (El_List)))); + New_Record_Aggr_El (Aggr, + New_Global_Address (El_Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (Aggr, Res); + Finish_Const_Value (Info.Type_Rti, Res); + end; + end Generate_Record_Type_Definition; + + procedure Generate_Protected_Type_Declaration (Atype : Iir) + is + Info : Type_Info_Acc; + Name : O_Dnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + begin + Info := Get_Info (Atype); + Generate_Type_Rti (Info, Ghdl_Rtin_Type_Scalar); + if Global_Storage = O_Storage_External then + return; + end if; + + Name := Generate_Type_Name (Atype); + Start_Const_Value (Info.Type_Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El + (List, + Generate_Common_Type (Ghdl_Rtik_Type_Protected, 0, 0, + Type_To_Mode (Atype))); + New_Record_Aggr_El (List, New_Name_Address (Name)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Type_Rti, Val); + end Generate_Protected_Type_Declaration; + + -- If FORCE is true, force the creation of the type RTI. + -- Otherwise, only the declaration (and not the definition) may have + -- been created. + function Generate_Type_Definition (Atype : Iir; Force : Boolean := False) + return O_Dnode + is + Info : constant Type_Info_Acc := Get_Info (Atype); + begin + if not Force and then Info.Type_Rti /= O_Dnode_Null then + return Info.Type_Rti; + end if; + case Get_Kind (Atype) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition => + raise Internal_Error; + when Iir_Kind_Enumeration_Type_Definition => + Generate_Enumeration_Type_Definition (Atype); + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Generate_Scalar_Subtype_Definition (Atype); + when Iir_Kind_Array_Type_Definition => + Generate_Array_Type_Definition (Atype); + when Iir_Kind_Array_Subtype_Definition => + Generate_Array_Subtype_Definition (Atype); + when Iir_Kind_Access_Type_Definition + | Iir_Kind_File_Type_Definition => + Generate_Fileacc_Type_Definition (Atype); + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition => + -- FIXME: No separate infos (yet). + null; + when Iir_Kind_Record_Type_Definition => + Generate_Record_Type_Definition (Atype); + when Iir_Kind_Protected_Type_Declaration => + Generate_Protected_Type_Declaration (Atype); + when others => + Error_Kind ("rti.generate_type_definition", Atype); + return O_Dnode_Null; + end case; + return Info.Type_Rti; + end Generate_Type_Definition; + + function Generate_Incomplete_Type_Definition (Def : Iir) + return O_Dnode + is + Ndef : constant Iir := Get_Type (Get_Type_Declarator (Def)); + Info : constant Type_Info_Acc := Get_Info (Ndef); + Rti_Type : O_Tnode; + begin + case Get_Kind (Ndef) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Scalar; + when Iir_Kind_Physical_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Physical; + when Iir_Kind_Enumeration_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Enum; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Rti_Type := Ghdl_Rtin_Subtype_Scalar; + when Iir_Kind_Array_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Array; + when Iir_Kind_Array_Subtype_Definition => + Rti_Type := Ghdl_Rtin_Subtype_Array; + when Iir_Kind_Access_Type_Definition + | Iir_Kind_File_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Fileacc; + when Iir_Kind_Record_Type_Definition => + Rti_Type := Ghdl_Rtin_Type_Record; + when others => + Error_Kind ("rti.generate_incomplete_type_definition", Ndef); + end case; + New_Const_Decl (Info.Type_Rti, Create_Identifier ("RTI"), + Global_Storage, Rti_Type); + return Info.Type_Rti; + end Generate_Incomplete_Type_Definition; + + function Generate_Type_Decl (Decl : Iir) return O_Dnode + is + Id : constant Name_Id := Get_Identifier (Decl); + Def : constant Iir := Get_Type (Decl); + Rti : O_Dnode; + Mark : Id_Mark_Type; + begin + Push_Identifier_Prefix (Mark, Id); + if Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then + Rti := Generate_Incomplete_Type_Definition (Def); + else + Rti := Generate_Type_Definition (Def, True); + end if; + Pop_Identifier_Prefix (Mark); + return Rti; + end Generate_Type_Decl; + + procedure Generate_Signal_Rti (Sig : Iir) + is + Info : Object_Info_Acc; + begin + Info := Get_Info (Sig); + New_Const_Decl (Info.Object_Rti, Create_Identifier (Sig, "__RTI"), + Global_Storage, Ghdl_Rtin_Object); + end Generate_Signal_Rti; + + procedure Generate_Object (Decl : Iir; Rti : in out O_Dnode) + is + Decl_Type : Iir; + Type_Info : Type_Info_Acc; + Name : O_Dnode; + Comm : O_Cnode; + Val : O_Cnode; + List : O_Record_Aggr_List; + Info : Ortho_Info_Acc; + Mark : Id_Mark_Type; + Var : Var_Type; + Mode : Natural; + Has_Id : Boolean; + begin + case Get_Kind (Decl) is + when Iir_Kind_Transaction_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute => + Has_Id := False; + Push_Identifier_Prefix_Uniq (Mark); + when others => + Has_Id := True; + Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + end case; + + if Rti = O_Dnode_Null then + New_Const_Decl (Rti, Create_Identifier ("RTI"), + Global_Storage, Ghdl_Rtin_Object); + end if; + + if Global_Storage /= O_Storage_External then + Decl_Type := Get_Type (Decl); + Type_Info := Get_Info (Decl_Type); + if Type_Info.Type_Rti = O_Dnode_Null then + declare + Mark : Id_Mark_Type; + Tmp : O_Dnode; + pragma Unreferenced (Tmp); + begin + Push_Identifier_Prefix (Mark, "OT"); + Tmp := Generate_Type_Definition (Decl_Type); + Pop_Identifier_Prefix (Mark); + end; + end if; + + if Has_Id then + Name := Generate_Name (Decl); + else + Name := O_Dnode_Null; + end if; + + Info := Get_Info (Decl); + + Start_Const_Value (Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Object); + Mode := 0; + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration => + Comm := Ghdl_Rtik_Signal; + Var := Info.Object_Var; + when Iir_Kind_Interface_Signal_Declaration => + Comm := Ghdl_Rtik_Port; + Var := Info.Object_Var; + Mode := Iir_Mode'Pos (Get_Mode (Decl)); + when Iir_Kind_Constant_Declaration => + Comm := Ghdl_Rtik_Constant; + Var := Info.Object_Var; + when Iir_Kind_Interface_Constant_Declaration => + Comm := Ghdl_Rtik_Generic; + Var := Info.Object_Var; + when Iir_Kind_Variable_Declaration => + Comm := Ghdl_Rtik_Variable; + Var := Info.Object_Var; + when Iir_Kind_Guard_Signal_Declaration => + Comm := Ghdl_Rtik_Guard; + Var := Info.Object_Var; + when Iir_Kind_Iterator_Declaration => + Comm := Ghdl_Rtik_Iterator; + Var := Info.Iterator_Var; + when Iir_Kind_File_Declaration => + Comm := Ghdl_Rtik_File; + Var := Info.Object_Var; + when Iir_Kind_Attribute_Declaration => + Comm := Ghdl_Rtik_Attribute; + Var := Null_Var; + when Iir_Kind_Transaction_Attribute => + Comm := Ghdl_Rtik_Attribute_Transaction; + Var := Info.Object_Var; + when Iir_Kind_Quiet_Attribute => + Comm := Ghdl_Rtik_Attribute_Quiet; + Var := Info.Object_Var; + when Iir_Kind_Stable_Attribute => + Comm := Ghdl_Rtik_Attribute_Stable; + Var := Info.Object_Var; + when Iir_Kind_Object_Alias_Declaration => + Comm := Ghdl_Rtik_Alias; + Var := Info.Alias_Var; + Mode := Object_Kind_Type'Pos (Info.Alias_Kind); + when others => + Error_Kind ("rti.generate_object", Decl); + end case; + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration => + Mode := Mode + + 16 * Iir_Signal_Kind'Pos (Get_Signal_Kind (Decl)); + when others => + null; + end case; + case Get_Kind (Decl) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Guard_Signal_Declaration + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Stable_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Delayed_Attribute => + if Get_Has_Active_Flag (Decl) then + Mode := Mode + 64; + end if; + when others => + null; + end case; + New_Record_Aggr_El (List, Generate_Common (Comm, Var, Mode)); + New_Record_Aggr_El (List, New_Name_Address (Name)); + if Var = Null_Var then + Val := Get_Null_Loc; + else + Val := Var_Acc_To_Loc (Var); + end if; + New_Record_Aggr_El (List, Val); + New_Record_Aggr_El (List, New_Rti_Address (Type_Info.Type_Rti)); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Rti, Val); + end if; + Pop_Identifier_Prefix (Mark); + end Generate_Object; + + procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode); + procedure Generate_Declaration_Chain (Chain : Iir); + + procedure Generate_Component_Declaration (Comp : Iir) + is + Prev : Rti_Block; + Name : O_Dnode; + Arr : O_Dnode; + List : O_Record_Aggr_List; + Res : O_Cnode; + Mark : Id_Mark_Type; + Info : Comp_Info_Acc; + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Comp)); + Info := Get_Info (Comp); + + New_Const_Decl (Info.Comp_Rti_Const, Create_Identifier ("RTI"), + Global_Storage, Ghdl_Rtin_Component); + + if Global_Storage /= O_Storage_External then + Push_Rti_Node (Prev); + + Generate_Declaration_Chain (Get_Generic_Chain (Comp)); + Generate_Declaration_Chain (Get_Port_Chain (Comp)); + + Name := Generate_Name (Comp); + + Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + + Start_Const_Value (Info.Comp_Rti_Const); + Start_Record_Aggr (List, Ghdl_Rtin_Component); + New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Component)); + New_Record_Aggr_El (List, + New_Global_Address (Name, Char_Ptr_Type)); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Cur_Block.Nbr))); + New_Record_Aggr_El (List, + New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (List, Res); + Finish_Const_Value (Info.Comp_Rti_Const, Res); + Pop_Rti_Node (Prev); + end if; + + Pop_Identifier_Prefix (Mark); + Add_Rti_Node (Info.Comp_Rti_Const); + end Generate_Component_Declaration; + + -- Generate RTIs only for types. + procedure Generate_Declaration_Chain_Depleted (Chain : Iir) + is + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Type_Declaration => + -- FIXME: physicals ? + if Get_Kind (Get_Type_Definition (Decl)) + = Iir_Kind_Enumeration_Type_Definition + then + Add_Rti_Node (Generate_Type_Decl (Decl)); + end if; + when Iir_Kind_Subtype_Declaration => + -- In a subprogram, a subtype may depends on parameters. + -- Eg: array subtypes. + null; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Stable_Attribute => + null; + when Iir_Kind_Delayed_Attribute => + -- FIXME: to be added. + null; + when Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Attribute_Declaration => + null; + when Iir_Kind_Component_Declaration => + null; + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- FIXME: to be added (for foreign). + null; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + when Iir_Kind_Anonymous_Type_Declaration => + -- Handled in subtype declaration. + null; + when Iir_Kind_Configuration_Specification + | Iir_Kind_Attribute_Specification + | Iir_Kind_Disconnection_Specification => + null; + when Iir_Kind_Protected_Type_Body => + null; + when Iir_Kind_Non_Object_Alias_Declaration => + null; + when Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + when others => + Error_Kind ("rti.generate_declaration_chain_depleted", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Generate_Declaration_Chain_Depleted; + + procedure Generate_Subprogram_Body (Bod : Iir) + is + --Decl : Iir; + --Mark : Id_Mark_Type; + begin + --Decl := Get_Subprogram_Specification (Bod); + + --Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); + -- Generate RTI only for types. + Generate_Declaration_Chain_Depleted (Get_Declaration_Chain (Bod)); + --Pop_Identifier_Prefix (Mark); + end Generate_Subprogram_Body; + + procedure Generate_Instance (Stmt : Iir; Parent : O_Dnode) + is + Name : O_Dnode; + List : O_Record_Aggr_List; + Val : O_Cnode; + Inst : constant Iir := Get_Instantiated_Unit (Stmt); + Info : constant Block_Info_Acc := Get_Info (Stmt); + begin + Name := Generate_Name (Stmt); + + New_Const_Decl (Info.Block_Rti_Const, Create_Identifier ("RTI"), + Global_Storage, Ghdl_Rtin_Instance); + + Start_Const_Value (Info.Block_Rti_Const); + Start_Record_Aggr (List, Ghdl_Rtin_Instance); + New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Instance)); + New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + New_Record_Aggr_El + (List, New_Offsetof (Get_Scope_Type + (Get_Info (Get_Parent (Stmt)).Block_Scope), + Info.Block_Link_Field, + Ghdl_Ptr_Type)); + New_Record_Aggr_El (List, New_Rti_Address (Parent)); + if Is_Component_Instantiation (Stmt) then + Val := New_Rti_Address + (Get_Info (Get_Named_Entity (Inst)).Comp_Rti_Const); + else + declare + Ent : constant Iir := Get_Entity_From_Entity_Aspect (Inst); + begin + Val := New_Rti_Address (Get_Info (Ent).Block_Rti_Const); + end; + end if; + + New_Record_Aggr_El (List, Val); + Finish_Record_Aggr (List, Val); + Finish_Const_Value (Info.Block_Rti_Const, Val); + Add_Rti_Node (Info.Block_Rti_Const); + end Generate_Instance; + + procedure Generate_Psl_Directive (Stmt : Iir) + is + Name : O_Dnode; + List : O_Record_Aggr_List; + + Rti : O_Dnode; + Res : O_Cnode; + Info : constant Psl_Info_Acc := Get_Info (Stmt); + Mark : Id_Mark_Type; + begin + 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 Generate_Psl_Directive; + + procedure Generate_Declaration_Chain (Chain : Iir) + is + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Anonymous_Type_Declaration => + -- Handled in subtype declaration. + null; + when Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Add_Rti_Node (Generate_Type_Decl (Decl)); + when Iir_Kind_Constant_Declaration => + -- Do not generate RTIs for full declarations. + -- (RTI will be generated for the deferred declaration). + if Get_Deferred_Declaration (Decl) = Null_Iir + or else Get_Deferred_Declaration_Flag (Decl) + then + declare + Info : Object_Info_Acc; + begin + Info := Get_Info (Decl); + Generate_Object (Decl, Info.Object_Rti); + Add_Rti_Node (Info.Object_Rti); + end; + end if; + when Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Transaction_Attribute + | Iir_Kind_Quiet_Attribute + | Iir_Kind_Stable_Attribute => + declare + Info : Object_Info_Acc; + begin + Info := Get_Info (Decl); + Generate_Object (Decl, Info.Object_Rti); + Add_Rti_Node (Info.Object_Rti); + end; + when Iir_Kind_Delayed_Attribute => + -- FIXME: to be added. + null; + when Iir_Kind_Object_Alias_Declaration + | Iir_Kind_Attribute_Declaration => + declare + Rti : O_Dnode := O_Dnode_Null; + begin + Generate_Object (Decl, Rti); + Add_Rti_Node (Rti); + end; + when Iir_Kind_Component_Declaration => + Generate_Component_Declaration (Decl); + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- FIXME: to be added (for foreign). + null; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + -- Already handled by Translate_Subprogram_Body. + null; + when Iir_Kind_Configuration_Specification + | Iir_Kind_Attribute_Specification + | Iir_Kind_Disconnection_Specification => + null; + when Iir_Kind_Protected_Type_Body => + null; + when Iir_Kind_Non_Object_Alias_Declaration => + null; + when Iir_Kind_Group_Template_Declaration + | Iir_Kind_Group_Declaration => + null; + when others => + Error_Kind ("rti.generate_declaration_chain", Decl); + end case; + Decl := Get_Chain (Decl); + end loop; + end Generate_Declaration_Chain; + + procedure Generate_Concurrent_Statement_Chain + (Chain : Iir; Parent_Rti : O_Dnode) + is + Stmt : Iir; + Mark : Id_Mark_Type; + begin + Stmt := Chain; + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); + Generate_Block (Stmt, Parent_Rti); + Pop_Identifier_Prefix (Mark); + when Iir_Kind_Component_Instantiation_Statement => + 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 => + Generate_Psl_Directive (Stmt); + when Iir_Kind_Psl_Cover_Statement => + Generate_Psl_Directive (Stmt); + when others => + Error_Kind ("rti.generate_concurrent_statement_chain", Stmt); + end case; + Stmt := Get_Chain (Stmt); + end loop; + end Generate_Concurrent_Statement_Chain; + + procedure Generate_Block (Blk : Iir; Parent_Rti : O_Dnode) + is + Name : O_Dnode; + Arr : O_Dnode; + List : O_Record_Aggr_List; + + Rti : O_Dnode; + + Kind : O_Cnode; + Res : O_Cnode; + + Prev : Rti_Block; + Info : Ortho_Info_Acc; + + Field_Off : O_Cnode; + Inst : O_Tnode; + begin + -- The type of a generator iterator is elaborated in the parent. + if Get_Kind (Blk) = Iir_Kind_Generate_Statement then + declare + Scheme : Iir; + Iter_Type : Iir; + Type_Info : Type_Info_Acc; + Mark : Id_Mark_Type; + Tmp : O_Dnode; + begin + Scheme := Get_Generation_Scheme (Blk); + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Iter_Type := Get_Type (Scheme); + Type_Info := Get_Info (Iter_Type); + if Type_Info.Type_Rti = O_Dnode_Null then + Push_Identifier_Prefix (Mark, "ITERATOR"); + Tmp := Generate_Type_Definition (Iter_Type); + Add_Rti_Node (Tmp); + Pop_Identifier_Prefix (Mark); + end if; + end if; + end; + end if; + + New_Const_Decl (Rti, Create_Identifier ("RTI"), + O_Storage_Public, Ghdl_Rtin_Block); + Push_Rti_Node (Prev); + + Field_Off := O_Cnode_Null; + Inst := O_Tnode_Null; + Info := Get_Info (Blk); + case Get_Kind (Blk) is + when Iir_Kind_Package_Declaration => + Kind := Ghdl_Rtik_Package; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + when Iir_Kind_Package_Body => + Kind := Ghdl_Rtik_Package_Body; + -- Required at least for 'image + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + when Iir_Kind_Architecture_Body => + Kind := Ghdl_Rtik_Architecture; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Inst := Get_Scope_Type (Info.Block_Scope); + Field_Off := New_Offsetof + (Get_Scope_Type (Info.Block_Scope), + Info.Block_Parent_Field, Ghdl_Ptr_Type); + when Iir_Kind_Entity_Declaration => + Kind := Ghdl_Rtik_Entity; + Generate_Declaration_Chain (Get_Generic_Chain (Blk)); + Generate_Declaration_Chain (Get_Port_Chain (Blk)); + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Inst := Get_Scope_Type (Info.Block_Scope); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Kind := Ghdl_Rtik_Process; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Field_Off := + Get_Scope_Offset (Info.Process_Scope, Ghdl_Ptr_Type); + Inst := Get_Scope_Type (Info.Process_Scope); + when Iir_Kind_Block_Statement => + Kind := Ghdl_Rtik_Block; + declare + Guard : constant Iir := Get_Guard_Decl (Blk); + Header : constant Iir := Get_Block_Header (Blk); + Guard_Info : Object_Info_Acc; + begin + if Guard /= Null_Iir then + Guard_Info := Get_Info (Guard); + Generate_Object (Guard, Guard_Info.Object_Rti); + Add_Rti_Node (Guard_Info.Object_Rti); + end if; + if Header /= Null_Iir then + Generate_Declaration_Chain (Get_Generic_Chain (Header)); + Generate_Declaration_Chain (Get_Port_Chain (Header)); + end if; + end; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Field_Off := Get_Scope_Offset (Info.Block_Scope, Ghdl_Ptr_Type); + Inst := Get_Scope_Type (Info.Block_Scope); + when Iir_Kind_Generate_Statement => + declare + Scheme : constant Iir := Get_Generation_Scheme (Blk); + Scheme_Rti : O_Dnode := O_Dnode_Null; + begin + if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then + Generate_Object (Scheme, Scheme_Rti); + Add_Rti_Node (Scheme_Rti); + Kind := Ghdl_Rtik_For_Generate; + else + Kind := Ghdl_Rtik_If_Generate; + end if; + end; + Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); + Generate_Concurrent_Statement_Chain + (Get_Concurrent_Statement_Chain (Blk), Rti); + Inst := Get_Scope_Type (Info.Block_Scope); + Field_Off := New_Offsetof + (Get_Scope_Type (Get_Info (Get_Parent (Blk)).Block_Scope), + Info.Block_Parent_Field, Ghdl_Ptr_Type); + when others => + Error_Kind ("rti.generate_block", Blk); + end case; + + Name := Generate_Name (Blk); + + Arr := Generate_Rti_Array (Create_Identifier ("RTIARRAY")); + + Start_Const_Value (Rti); + Start_Record_Aggr (List, Ghdl_Rtin_Block); + New_Record_Aggr_El (List, Generate_Common (Kind)); + New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); + if Field_Off = O_Cnode_Null then + Field_Off := Get_Null_Loc; + end if; + New_Record_Aggr_El (List, Field_Off); + if Parent_Rti = O_Dnode_Null then + Res := New_Null_Access (Ghdl_Rti_Access); + else + Res := New_Rti_Address (Parent_Rti); + end if; + New_Record_Aggr_El (List, Res); + if Inst = O_Tnode_Null then + Res := Ghdl_Index_0; + else + Res := New_Sizeof (Inst, Ghdl_Index_Type); + end if; + New_Record_Aggr_El (List, Res); + New_Record_Aggr_El + (List, New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Cur_Block.Nbr))); + New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc)); + Finish_Record_Aggr (List, Res); + Finish_Const_Value (Rti, Res); + + Pop_Rti_Node (Prev); + + -- Put children in the parent list. + case Get_Kind (Blk) is + when Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Add_Rti_Node (Rti); + when others => + null; + end case; + + -- Store the RTI. + case Get_Kind (Blk) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Info.Block_Rti_Const := Rti; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Info.Process_Rti_Const := Rti; + when Iir_Kind_Package_Declaration => + Info.Package_Rti_Const := Rti; + when Iir_Kind_Package_Body => + -- Replace package declaration RTI with the body one. + Get_Info (Get_Package (Blk)).Package_Rti_Const := Rti; + when others => + Error_Kind ("rti.generate_block", Blk); + end case; + end Generate_Block; + + procedure Generate_Library (Lib : Iir_Library_Declaration; + Public : Boolean) + is + use Name_Table; + Info : Library_Info_Acc; + Id : Name_Id; + Val : O_Cnode; + Aggr : O_Record_Aggr_List; + Name : O_Dnode; + Storage : O_Storage; + begin + Info := Get_Info (Lib); + if Info /= null then + return; + end if; + Info := Add_Info (Lib, Kind_Library); + + if Lib = Libraries.Work_Library then + Id := Libraries.Work_Library_Name; + else + Id := Get_Identifier (Lib); + end if; + + if Public then + Storage := O_Storage_Public; + else + Storage := O_Storage_External; + end if; + + New_Const_Decl (Info.Library_Rti_Const, + Create_Identifier_Without_Prefix (Id, "__RTI"), + Storage, Ghdl_Rtin_Type_Scalar); + + if Public then + Image (Id); + Name := Create_String + (Name_Buffer (1 .. Name_Length), + Create_Identifier_Without_Prefix (Id, "__RTISTR")); + Start_Const_Value (Info.Library_Rti_Const); + Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Scalar); + New_Record_Aggr_El (Aggr, Generate_Common (Ghdl_Rtik_Library)); + New_Record_Aggr_El (Aggr, New_Name_Address (Name)); + Finish_Record_Aggr (Aggr, Val); + Finish_Const_Value (Info.Library_Rti_Const, Val); + end if; + end Generate_Library; + + procedure Generate_Unit (Lib_Unit : Iir) + is + Rti : O_Dnode; + Info : Ortho_Info_Acc; + Mark : Id_Mark_Type; + begin + Info := Get_Info (Lib_Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Configuration_Declaration => + return; + when Iir_Kind_Architecture_Body => + if Info.Block_Rti_Const /= O_Dnode_Null then + return; + end if; + when Iir_Kind_Package_Body => + Push_Identifier_Prefix (Mark, "BODY"); + when others => + null; + end case; + + -- Declare node. + if Global_Storage = O_Storage_External then + New_Const_Decl (Rti, Create_Identifier ("RTI"), + O_Storage_External, Ghdl_Rtin_Block); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration => + declare + Prev : Rti_Block; + begin + Push_Rti_Node (Prev); + Generate_Declaration_Chain + (Get_Declaration_Chain (Lib_Unit)); + Pop_Rti_Node (Prev); + end; + when others => + null; + end case; + case Get_Kind (Lib_Unit) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body => + Info.Block_Rti_Const := Rti; + when Iir_Kind_Package_Declaration => + Info.Package_Rti_Const := Rti; + when Iir_Kind_Package_Body => + -- Replace package declaration RTI with the body one. + Get_Info (Get_Package (Lib_Unit)).Package_Rti_Const := Rti; + when others => + null; + end case; + else + case Get_Kind (Lib_Unit) is + when Iir_Kind_Package_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration => + declare + Lib : Iir_Library_Declaration; + begin + Lib := Get_Library (Get_Design_File + (Get_Design_Unit (Lib_Unit))); + Generate_Library (Lib, False); + Rti := Get_Info (Lib).Library_Rti_Const; + end; + when Iir_Kind_Package_Body => + Rti := Get_Info (Get_Package (Lib_Unit)).Package_Rti_Const; + when Iir_Kind_Architecture_Body => + Rti := Get_Info (Get_Entity (Lib_Unit)).Block_Rti_Const; + when others => + raise Internal_Error; + end case; + Generate_Block (Lib_Unit, Rti); + end if; + + if Get_Kind (Lib_Unit) = Iir_Kind_Package_Body then + Pop_Identifier_Prefix (Mark); + end if; + end Generate_Unit; + + procedure Generate_Top (Nbr_Pkgs : out Natural) + is + use Configuration; + + Unit : Iir_Design_Unit; + Lib : Iir_Library_Declaration; + Prev : Rti_Block; + begin + Push_Rti_Node (Prev); + + -- Generate RTI for libraries, count number of packages. + Nbr_Pkgs := 1; -- At least std.standard. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + + -- Generate RTI for the library. + Lib := Get_Library (Get_Design_File (Unit)); + Generate_Library (Lib, True); + + if Get_Kind (Get_Library_Unit (Unit)) + = Iir_Kind_Package_Declaration + then + Nbr_Pkgs := Nbr_Pkgs + 1; + end if; + end loop; + + Pop_Rti_Node (Prev); + end Generate_Top; + + function Get_Context_Rti (Node : Iir) return O_Cnode + is + Node_Info : Ortho_Info_Acc; + + Rti_Const : O_Dnode; + begin + Node_Info := Get_Info (Node); + + case Get_Kind (Node) is + when Iir_Kind_Component_Declaration => + Rti_Const := Node_Info.Comp_Rti_Const; + when Iir_Kind_Component_Instantiation_Statement => + Rti_Const := Node_Info.Block_Rti_Const; + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Rti_Const := Node_Info.Block_Rti_Const; + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + Rti_Const := Node_Info.Package_Rti_Const; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Rti_Const := Node_Info.Process_Rti_Const; + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Rti_Const := Node_Info.Psl_Rti_Const; + when others => + Error_Kind ("get_context_rti", Node); + end case; + return New_Rti_Address (Rti_Const); + end Get_Context_Rti; + + function Get_Context_Addr (Node : Iir) return O_Enode + is + Node_Info : constant Ortho_Info_Acc := Get_Info (Node); + Ref : O_Lnode; + begin + case Get_Kind (Node) is + when Iir_Kind_Component_Declaration => + Ref := Get_Instance_Ref (Node_Info.Comp_Scope); + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Ref := Get_Instance_Ref (Node_Info.Block_Scope); + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + return New_Lit (New_Null_Access (Ghdl_Ptr_Type)); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Ref := Get_Instance_Ref (Node_Info.Process_Scope); + when Iir_Kind_Psl_Assert_Statement + | Iir_Kind_Psl_Cover_Statement => + Ref := Get_Instance_Ref (Node_Info.Psl_Scope); + when others => + Error_Kind ("get_context_addr", Node); + end case; + return New_Unchecked_Address (Ref, Ghdl_Ptr_Type); + end Get_Context_Addr; + + procedure Associate_Rti_Context (Assoc : in out O_Assoc_List; Node : Iir) + is + begin + New_Association (Assoc, New_Lit (Get_Context_Rti (Node))); + New_Association (Assoc, Get_Context_Addr (Node)); + end Associate_Rti_Context; + + procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List) is + begin + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Rti_Access))); + New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + end Associate_Null_Rti_Context; + end Rtis; + + procedure Gen_Filename (Design_File : Iir) + is + Info : Design_File_Info_Acc; + begin + if Current_Filename_Node /= O_Dnode_Null then + raise Internal_Error; + end if; + Info := Get_Info (Design_File); + if Info = null then + Info := Add_Info (Design_File, Kind_Design_File); + Info.Design_Filename := Create_String + (Get_Design_File_Filename (Design_File), + Create_Uniq_Identifier, O_Storage_Private); + end if; + Current_Filename_Node := Info.Design_Filename; + end Gen_Filename; + + -- Decorate the tree in order to be usable with the internal simulator. + procedure Translate (Unit : Iir_Design_Unit; Main : Boolean) + is + Design_File : Iir_Design_File; + El : Iir; + Lib : Iir_Library_Declaration; + Lib_Mark, Ent_Mark, Sep_Mark, Unit_Mark : Id_Mark_Type; + Id : Name_Id; + begin + Update_Node_Infos; + + Design_File := Get_Design_File (Unit); + + if False then + El := Get_Context_Items (Unit); + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Use_Clause => + null; + when Iir_Kind_Library_Clause => + null; + when others => + Error_Kind ("translate1", El); + end case; + El := Get_Chain (El); + end loop; + end if; + + El := Get_Library_Unit (Unit); + if Flags.Verbose then + Ada.Text_IO.Put ("translating "); + if Main then + Ada.Text_IO.Put ("(with code generation) "); + end if; + Ada.Text_IO.Put_Line (Disp_Node (El)); + end if; + + -- Create the prefix for identifiers. + Lib := Get_Library (Get_Design_File (Unit)); + Reset_Identifier_Prefix; + if Lib = Libraries.Work_Library then + Id := Libraries.Work_Library_Name; + else + Id := Get_Identifier (Lib); + end if; + Push_Identifier_Prefix (Lib_Mark, Id); + + if Get_Kind (El) = Iir_Kind_Architecture_Body then + -- Put 'ARCH' between the entity name and the architecture name, to + -- avoid a name clash with names from entity (eg an entity port with + -- the same name as an architecture). + Push_Identifier_Prefix (Ent_Mark, Get_Identifier (Get_Entity (El))); + Push_Identifier_Prefix (Sep_Mark, "ARCH"); + end if; + Id := Get_Identifier (El); + if Id /= Null_Identifier then + Push_Identifier_Prefix (Unit_Mark, Id); + end if; + + if Main then + Set_Global_Storage (O_Storage_Public); + -- Create the variable containing the current file name. + Gen_Filename (Get_Design_File (Unit)); + else + Set_Global_Storage (O_Storage_External); + end if; + + New_Debug_Filename_Decl + (Name_Table.Image (Get_Design_File_Filename (Design_File))); + + Current_Library_Unit := El; + + case Get_Kind (El) is + when Iir_Kind_Package_Declaration => + New_Debug_Comment_Decl + ("package declaration " & Image_Identifier (El)); + Chap2.Translate_Package_Declaration (El); + when Iir_Kind_Package_Body => + New_Debug_Comment_Decl ("package body " & Image_Identifier (El)); + Chap2.Translate_Package_Body (El); + when Iir_Kind_Package_Instantiation_Declaration => + New_Debug_Comment_Decl + ("package instantiation " & Image_Identifier (El)); + Chap2.Translate_Package_Instantiation_Declaration (El); + when Iir_Kind_Entity_Declaration => + New_Debug_Comment_Decl ("entity " & Image_Identifier (El)); + Chap1.Translate_Entity_Declaration (El); + when Iir_Kind_Architecture_Body => + New_Debug_Comment_Decl ("architecture " & Image_Identifier (El)); + Chap1.Translate_Architecture_Body (El); + when Iir_Kind_Configuration_Declaration => + New_Debug_Comment_Decl ("configuration " & Image_Identifier (El)); + if Id = Null_Identifier then + declare + Mark : Id_Mark_Type; + Mark_Entity : Id_Mark_Type; + Mark_Arch : Id_Mark_Type; + Mark_Sep : Id_Mark_Type; + Arch : Iir; + Entity : constant Iir := Get_Entity (El); + begin + -- Note: this is done inside the architecture identifier. + Push_Identifier_Prefix + (Mark_Entity, Get_Identifier (Entity)); + Arch := Get_Block_Specification + (Get_Block_Configuration (El)); + Push_Identifier_Prefix (Mark_Sep, "ARCH"); + Push_Identifier_Prefix (Mark_Arch, Get_Identifier (Arch)); + Push_Identifier_Prefix + (Mark, Name_Table.Get_Identifier ("DEFAULT_CONFIG")); + Chap1.Translate_Configuration_Declaration (El); + Pop_Identifier_Prefix (Mark); + Pop_Identifier_Prefix (Mark_Arch); + Pop_Identifier_Prefix (Mark_Sep); + Pop_Identifier_Prefix (Mark_Entity); + end; + else + Chap1.Translate_Configuration_Declaration (El); + end if; + when others => + Error_Kind ("translate", El); + end case; + + Current_Filename_Node := O_Dnode_Null; + Current_Library_Unit := Null_Iir; + + --Pop_Global_Factory; + if Id /= Null_Identifier then + Pop_Identifier_Prefix (Unit_Mark); + end if; + if Get_Kind (El) = Iir_Kind_Architecture_Body then + Pop_Identifier_Prefix (Sep_Mark); + Pop_Identifier_Prefix (Ent_Mark); + end if; + Pop_Identifier_Prefix (Lib_Mark); + end Translate; + + procedure Initialize + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + -- Create the node extension for translate. + Node_Infos.Init; + Node_Infos.Set_Last (4); + Node_Infos.Table (0 .. 4) := (others => null); + + -- Force to unnest subprograms is the code generator doesn't support + -- nested subprograms. + if not Ortho_Nodes.Has_Nested_Subprograms then + Flag_Unnest_Subprograms := True; + end if; + + New_Debug_Comment_Decl ("internal declarations, part 1"); + + -- Create well known identifiers. + Wki_This := Get_Identifier ("this"); + Wki_Size := Get_Identifier ("size"); + Wki_Res := Get_Identifier ("res"); + Wki_Dir_To := Get_Identifier ("dir_to"); + Wki_Dir_Downto := Get_Identifier ("dir_downto"); + Wki_Left := Get_Identifier ("left"); + Wki_Right := Get_Identifier ("right"); + Wki_Dir := Get_Identifier ("dir"); + Wki_Length := Get_Identifier ("length"); + Wki_I := Get_Identifier ("I"); + Wki_Instance := Get_Identifier ("INSTANCE"); + Wki_Arch_Instance := Get_Identifier ("ARCH_INSTANCE"); + Wki_Name := Get_Identifier ("NAME"); + Wki_Sig := Get_Identifier ("sig"); + Wki_Obj := Get_Identifier ("OBJ"); + Wki_Rti := Get_Identifier ("RTI"); + 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"); + Wki_Upframe := Get_Identifier ("UPFRAME"); + Wki_Frame := Get_Identifier ("FRAME"); + Wki_Val := Get_Identifier ("val"); + Wki_L_Len := Get_Identifier ("l_len"); + Wki_R_Len := Get_Identifier ("r_len"); + + Sizetype := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype); + + -- Create __ghdl_index_type, which is the type for *all* array index. + Ghdl_Index_Type := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_index_type"), Ghdl_Index_Type); + + Ghdl_Index_0 := New_Unsigned_Literal (Ghdl_Index_Type, 0); + Ghdl_Index_1 := New_Unsigned_Literal (Ghdl_Index_Type, 1); + + Ghdl_I32_Type := New_Signed_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_i32"), Ghdl_I32_Type); + + Ghdl_Real_Type := New_Float_Type; + New_Type_Decl (Get_Identifier ("__ghdl_real"), Ghdl_Real_Type); + + if not Flag_Only_32b then + Ghdl_I64_Type := New_Signed_Type (64); + New_Type_Decl (Get_Identifier ("__ghdl_i64"), Ghdl_I64_Type); + end if; + + -- File index for elaborated file object. + Ghdl_File_Index_Type := New_Unsigned_Type (32); + New_Type_Decl (Get_Identifier ("__ghdl_file_index"), + Ghdl_File_Index_Type); + Ghdl_File_Index_Ptr_Type := New_Access_Type (Ghdl_File_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_file_index_ptr"), + Ghdl_File_Index_Ptr_Type); + + -- Create char, char [] and char *. + Char_Type_Node := New_Unsigned_Type (8); + New_Type_Decl (Get_Identifier ("__ghdl_char"), Char_Type_Node); + + Chararray_Type := New_Array_Type (Char_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_chararray"), Chararray_Type); + + Char_Ptr_Type := New_Access_Type (Chararray_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr"), Char_Ptr_Type); + + Char_Ptr_Array_Type := New_Array_Type (Char_Ptr_Type, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array"), + Char_Ptr_Array_Type); + + Char_Ptr_Array_Ptr_Type := New_Access_Type (Char_Ptr_Array_Type); + New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array_ptr"), + Char_Ptr_Array_Ptr_Type); + + -- Generic pointer. + Ghdl_Ptr_Type := New_Access_Type (Char_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_ptr"), Ghdl_Ptr_Type); + + -- Create record + -- len : natural; + -- str : C_String; + -- end record; + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field (Constr, Ghdl_Str_Len_Type_Len_Field, + Get_Identifier ("len"), Ghdl_Index_Type); + New_Record_Field + (Constr, Ghdl_Str_Len_Type_Str_Field, + Get_Identifier ("str"), Char_Ptr_Type); + Finish_Record_Type (Constr, Ghdl_Str_Len_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_str_len"), + Ghdl_Str_Len_Type_Node); + end; + + Ghdl_Str_Len_Array_Type_Node := New_Array_Type + (Ghdl_Str_Len_Type_Node, Ghdl_Index_Type); + New_Type_Decl (Get_Identifier ("__ghdl_str_len_array"), + Ghdl_Str_Len_Array_Type_Node); + + -- Create type __ghdl_str_len_ptr is access all __ghdl_str_len + Ghdl_Str_Len_Ptr_Node := New_Access_Type (Ghdl_Str_Len_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_str_len_ptr"), + Ghdl_Str_Len_Ptr_Node); + + -- Create type __ghdl_bool_type is (false, true) + New_Boolean_Type (Ghdl_Bool_Type, + Get_Identifier ("false"), + Ghdl_Bool_False_Node, + Get_Identifier ("true"), + Ghdl_Bool_True_Node); + New_Type_Decl (Get_Identifier ("__ghdl_bool_type"), + Ghdl_Bool_Type); + + -- __ghdl_bool_array is array (ghdl_index_type) of ghdl_bool_type + Ghdl_Bool_Array_Type := + New_Array_Type (Ghdl_Bool_Type, Ghdl_Index_Type); + New_Type_Decl + (Get_Identifier ("__ghdl_bool_array_type"), Ghdl_Bool_Array_Type); + + -- __ghdl_bool_array_ptr is access __ghdl_bool_array; + Ghdl_Bool_Array_Ptr := New_Access_Type (Ghdl_Bool_Array_Type); + New_Type_Decl + (Get_Identifier ("__ghdl_bool_array_ptr"), Ghdl_Bool_Array_Ptr); + + -- Create type ghdl_compare_type is (lt, eq, ge); + declare + Constr : O_Enum_List; + begin + Start_Enum_Type (Constr, 8); + New_Enum_Literal (Constr, Get_Identifier ("lt"), Ghdl_Compare_Lt); + New_Enum_Literal (Constr, Get_Identifier ("eq"), Ghdl_Compare_Eq); + New_Enum_Literal (Constr, Get_Identifier ("gt"), Ghdl_Compare_Gt); + Finish_Enum_Type (Constr, Ghdl_Compare_Type); + New_Type_Decl (Get_Identifier ("__ghdl_compare_type"), + Ghdl_Compare_Type); + end; + + -- Create: + -- type __ghdl_location is record + -- file : char_ptr_type; + -- line : ghdl_i32; + -- col : ghdl_i32; + -- end record; + declare + Constr : O_Element_List; + begin + Start_Record_Type (Constr); + New_Record_Field + (Constr, Ghdl_Location_Filename_Node, Wki_Filename, Char_Ptr_Type); + New_Record_Field + (Constr, Ghdl_Location_Line_Node, Wki_Line, Ghdl_I32_Type); + New_Record_Field (Constr, Ghdl_Location_Col_Node, + Get_Identifier ("col"), + Ghdl_I32_Type); + Finish_Record_Type (Constr, Ghdl_Location_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_location"), + Ghdl_Location_Type_Node); + end; + -- Create type __ghdl_location_ptr is access __ghdl_location; + Ghdl_Location_Ptr_Node := New_Access_Type (Ghdl_Location_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_location_ptr"), + Ghdl_Location_Ptr_Node); + + -- Create type ghdl_dir_type is (dir_to, dir_downto); + declare + Constr : O_Enum_List; + begin + Start_Enum_Type (Constr, 8); + New_Enum_Literal (Constr, Wki_Dir_To, Ghdl_Dir_To_Node); + New_Enum_Literal (Constr, Wki_Dir_Downto, Ghdl_Dir_Downto_Node); + Finish_Enum_Type (Constr, Ghdl_Dir_Type_Node); + New_Type_Decl (Get_Identifier ("__ghdl_dir_type"), + Ghdl_Dir_Type_Node); + end; + + -- Create void* __ghdl_alloc (unsigned size); + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_alloc"), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Size, Sizetype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Alloc_Ptr); + + -- procedure __ghdl_program_error (filename : char_ptr_type; + -- line : ghdl_i32; + -- code : ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_program_error"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("code"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Program_Error); + + -- procedure __ghdl_bound_check_failed_l1 (filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_bound_check_failed_l1"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Bound_Check_Failed_L1); + + -- Secondary stack subprograms. + -- function __ghdl_stack2_allocate (size : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_stack2_allocate"), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Size, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Allocate); + + -- function __ghdl_stack2_mark return ghdl_ptr_type; + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_stack2_mark"), + O_Storage_External, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Mark); + + -- procedure __ghdl_stack2_release (mark : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_stack2_release"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mark"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Stack2_Release); + + -- procedure __ghdl_memcpy (dest : ghdl_ptr_type; + -- src : ghdl_ptr_type; + -- length : ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_memcpy"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("dest"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Memcpy); + + -- procedure __ghdl_deallocate (ptr : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_deallocate"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Deallocate); + + -- function __ghdl_malloc (length : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_malloc"), O_Storage_External, + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Malloc); + + -- function __ghdl_malloc0 (length : ghdl_index_type) + -- return ghdl_ptr_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_malloc0"), O_Storage_External, + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Malloc0); + + -- function __ghdl_text_file_elaborate return file_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_elaborate"), + O_Storage_External, Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Elaborate); + + -- function __ghdl_file_elaborate (name : char_ptr_type) + -- return file_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_file_elaborate"), + O_Storage_External, Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Name, Char_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Elaborate); + + -- procedure __ghdl_file_finalize (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_file_finalize"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Finalize); + + -- procedure __ghdl_text_file_finalize (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_finalize"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Finalize); + + declare + procedure Create_Protected_Subprg + (Name : String; Subprg : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Protected_Subprg; + begin + -- procedure __ghdl_protected_enter (obj : ghdl_ptr_type); + Create_Protected_Subprg + ("__ghdl_protected_enter", Ghdl_Protected_Enter); + + -- procedure __ghdl_protected_leave (obj : ghdl_ptr_type); + Create_Protected_Subprg + ("__ghdl_protected_leave", Ghdl_Protected_Leave); + + Create_Protected_Subprg + ("__ghdl_protected_init", Ghdl_Protected_Init); + + Create_Protected_Subprg + ("__ghdl_protected_fini", Ghdl_Protected_Fini); + end; + + if Flag_Rti then + Rtis.Rti_Initialize; + end if; + + -- procedure __ghdl_signal_name_rti + -- (obj : ghdl_rti_access; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_name_rti"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Obj, Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Name_Rti); + + declare + -- procedure NAME (this : ghdl_ptr_type; + -- proc : ghdl_ptr_type; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type); + procedure Create_Process_Register (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_This, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("proc"), Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Process_Register; + begin + Create_Process_Register ("__ghdl_process_register", + Ghdl_Process_Register); + Create_Process_Register ("__ghdl_sensitized_process_register", + Ghdl_Sensitized_Process_Register); + Create_Process_Register ("__ghdl_postponed_process_register", + Ghdl_Postponed_Process_Register); + Create_Process_Register + ("__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 + (Suffix : String; + Val_Type : O_Tnode; + Create_Signal : out O_Dnode; + Init_Signal : out O_Dnode; + Simple_Assign : out O_Dnode; + Start_Assign : out O_Dnode; + Next_Assign : out O_Dnode; + Associate_Value : out O_Dnode; + Driving_Value : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + -- function __ghdl_create_signal_XXX (init_val : VAL_TYPE) + -- resolv_func : ghdl_ptr_type; + -- resolv_inst : ghdl_ptr_type; + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_signal_" & Suffix), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("init_val"), Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("resolv_func"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("resolv_inst"), + Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Create_Signal); + + -- procedure __ghdl_signal_init_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_init_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type); + Finish_Subprogram_Decl (Interfaces, Init_Signal); + + -- procedure __ghdl_signal_simple_assign_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_simple_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type); + Finish_Subprogram_Decl (Interfaces, Simple_Assign); + + -- procedure __ghdl_signal_start_assign_XXX (sign : __ghdl_signal_ptr; + -- reject : std_time; + -- val : VAL_TYPE; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Val, + Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Start_Assign); + + -- procedure __ghdl_signal_next_assign_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, + Val_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Next_Assign); + + -- procedure __ghdl_signal_associate_XXX (sign : __ghdl_signal_ptr; + -- val : VAL_TYPE); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_associate_" & Suffix), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, + Val_Type); + Finish_Subprogram_Decl (Interfaces, Associate_Value); + + -- function __ghdl_signal_driving_value_XXX (sign : __ghdl_signal_ptr) + -- return VAL_TYPE; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_driving_value_" & Suffix), + O_Storage_External, Val_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Driving_Value); + end Create_Signal_Subprograms; + + -- procedure __ghdl_image_NAME (res : std_string_ptr_node; + -- val : VAL_TYPE; + -- rti : ghdl_rti_access); + -- + -- function __ghdl_value_NAME (val : std_string_ptr_node; + -- rti : ghdl_rti_access); + -- return VAL_TYPE; + procedure Create_Image_Value_Subprograms (Name : String; + Val_Type : O_Tnode; + Has_Td : Boolean; + Image_Subprg : out O_Dnode; + Value_Subprg : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_image_" & Name), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("res"), Std_String_Ptr_Node); + New_Interface_Decl + (Interfaces, Param, Wki_Val, Val_Type); + if Has_Td then + New_Interface_Decl + (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + end if; + Finish_Subprogram_Decl (Interfaces, Image_Subprg); + + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_value_" & Name), + O_Storage_External, Val_Type); + New_Interface_Decl + (Interfaces, Param, Wki_Val, Std_String_Ptr_Node); + if Has_Td then + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("rti"), Rtis.Ghdl_Rti_Access); + end if; + Finish_Subprogram_Decl (Interfaces, Value_Subprg); + end Create_Image_Value_Subprograms; + + -- function __ghdl_std_ulogic_match_NAME (l : __ghdl_e8; r : __ghdl_e8) + -- return __ghdl_e8; + procedure Create_Std_Ulogic_Match_Subprogram (Name : String; + Subprg : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_std_ulogic_match_" & Name), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Right, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Std_Ulogic_Match_Subprogram; + + -- function __ghdl_std_ulogic_array_match_NAME + -- (l : __ghdl_ptr; l_len : ghdl_index_type; + -- r : __ghdl_ptr; r_len : ghdl_index_type) + -- return __ghdl_i32; + procedure Create_Std_Ulogic_Array_Match_Subprogram (Name : String; + Subprg : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_std_ulogic_array_match_" & Name), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_L_Len, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Right, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_R_Len, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Std_Ulogic_Array_Match_Subprogram; + + -- procedure NAME (res : std_string_ptr_node; + -- val : VAL_TYPE; + -- ARG2_NAME : ARG2_TYPE); + procedure Create_To_String_Subprogram (Name : String; + Subprg : out O_Dnode; + Val_Type : O_Tnode; + Arg2_Type : O_Tnode := O_Tnode_Null; + Arg2_Id : O_Ident := O_Ident_Nul; + Arg3_Type : O_Tnode := O_Tnode_Null; + Arg3_Id : O_Ident := O_Ident_Nul) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Res, Std_String_Ptr_Node); + New_Interface_Decl + (Interfaces, Param, Wki_Val, Val_Type); + if Arg2_Type /= O_Tnode_Null then + New_Interface_Decl + (Interfaces, Param, Arg2_Id, Arg2_Type); + if Arg3_Type /= O_Tnode_Null then + New_Interface_Decl + (Interfaces, Param, Arg3_Id, Arg3_Type); + end if; + end if; + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_To_String_Subprogram; + + -- Do internal declarations that need std.standard declarations. + procedure Post_Initialize + is + Interfaces : O_Inter_List; + Rec : O_Element_List; + Param : O_Dnode; + Info : Type_Info_Acc; + begin + New_Debug_Comment_Decl ("internal declarations, part 2"); + + -- Remember some pervasive types. + Info := Get_Info (String_Type_Definition); + Std_String_Node := Info.Ortho_Type (Mode_Value); + Std_String_Ptr_Node := Info.Ortho_Ptr_Type (Mode_Value); + + Std_Integer_Otype := + Get_Ortho_Type (Integer_Type_Definition, Mode_Value); + Std_Real_Otype := + Get_Ortho_Type (Real_Type_Definition, Mode_Value); + Std_Time_Otype := Get_Ortho_Type (Time_Type_Definition, Mode_Value); + + -- __ghdl_now : time; + -- ??? maybe this should be a function ? + New_Var_Decl (Ghdl_Now, Get_Identifier ("__ghdl_now"), + O_Storage_External, Std_Time_Otype); + + -- procedure __ghdl_assert_failed (str : __ghdl_array_template; + -- severity : ghdl_int); + -- loc : __ghdl_location_acc); + + -- procedure __ghdl_report (str : __ghdl_array_template; + -- severity : ghdl_int); + -- loc : __ghdl_location_acc); + declare + procedure Create_Report_Subprg (Name : String; Subprg : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("msg"), Std_String_Ptr_Node); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("severity"), + Get_Ortho_Type (Severity_Level_Type_Definition, Mode_Value)); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("location"), + Ghdl_Location_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Report_Subprg; + begin + Create_Report_Subprg + ("__ghdl_assert_failed", Ghdl_Assert_Failed); + Create_Report_Subprg + ("__ghdl_ieee_assert_failed", Ghdl_Ieee_Assert_Failed); + Create_Report_Subprg ("__ghdl_psl_assert_failed", + Ghdl_Psl_Assert_Failed); + Create_Report_Subprg ("__ghdl_psl_cover", Ghdl_Psl_Cover); + Create_Report_Subprg ("__ghdl_psl_cover_failed", + Ghdl_Psl_Cover_Failed); + Create_Report_Subprg ("__ghdl_report", Ghdl_Report); + end; + + -- procedure __ghdl_text_write (file : __ghdl_file_index; + -- str : std_string_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_write"), O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_Write); + + -- function __ghdl_text_read_length (file : __ghdl_file_index; + -- str : std_string_ptr) + -- return std__standard_integer; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_read_length"), + O_Storage_External, Std_Integer_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_Read_Length); + + -- procedure __ghdl_write_scalar (file : __ghdl_file_index; + -- ptr : __ghdl_ptr_type; + -- length : __ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_write_scalar"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ptr"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Write_Scalar); + + -- procedure __ghdl_read_scalar (file : __ghdl_file_index; + -- ptr : __ghdl_ptr_type; + -- length : __ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_read_scalar"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ptr"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Length, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Read_Scalar); + + -- function __ghdl_real_exp (left : std__standard__real; + -- right : std__standard__integer) + -- return std__standard__real; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_real_exp"), O_Storage_External, + Std_Real_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("left"), + Std_Real_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("right"), + Std_Integer_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Real_Exp); + + -- function __ghdl_integer_exp (left : std__standard__integer; + -- right : std__standard__integer) + -- return std__standard__integer; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_integer_exp"), O_Storage_External, + Std_Integer_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Left, Std_Integer_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Right, Std_Integer_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Integer_Exp); + + + -- procedure __ghdl_image_b1 (res : std_string_ptr_node; + -- val : ghdl_bool_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("b1", Ghdl_Bool_Type, True, Ghdl_Image_B1, Ghdl_Value_B1); + + -- procedure __ghdl_image_e8 (res : std_string_ptr_node; + -- val : ghdl_i32_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("e8", Ghdl_I32_Type, True, Ghdl_Image_E8, Ghdl_Value_E8); + + -- procedure __ghdl_image_e32 (res : std_string_ptr_node; + -- val : ghdl_i32_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("e32", Ghdl_I32_Type, True, Ghdl_Image_E32, Ghdl_Value_E32); + + -- procedure __ghdl_image_i32 (res : std_string_ptr_node; + -- val : ghdl_i32_type); + Create_Image_Value_Subprograms + ("i32", Ghdl_I32_Type, False, Ghdl_Image_I32, Ghdl_Value_I32); + + -- procedure __ghdl_image_p32 (res : std_string_ptr_node; + -- val : ghdl_i32_type; + -- rti : ghdl_rti_access); + Create_Image_Value_Subprograms + ("p32", Ghdl_I32_Type, True, Ghdl_Image_P32, Ghdl_Value_P32); + + -- procedure __ghdl_image_p64 (res : std_string_ptr_node; + -- val : ghdl_i64_type; + -- rti : ghdl_rti_access); + if not Flag_Only_32b then + Create_Image_Value_Subprograms + ("p64", Ghdl_I64_Type, True, Ghdl_Image_P64, Ghdl_Value_P64); + end if; + + -- procedure __ghdl_image_f64 (res : std_string_ptr_node; + -- val : ghdl_real_type); + Create_Image_Value_Subprograms + ("f64", Ghdl_Real_Type, False, Ghdl_Image_F64, Ghdl_Value_F64); + + ------------- + -- files -- + ------------- + + -- procedure __ghdl_text_file_open (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_open"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Open); + + -- procedure __ghdl_file_open (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_file_open"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Open); + + -- function __ghdl_text_file_open_status + -- (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR) + -- return ghdl_i32_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_open_status"), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Open_Status); + + -- function __ghdl_file_open_status (file : file_index_type; + -- mode : Ghdl_I32_Type; + -- str : std__standard__string_PTR) + -- return ghdl_i32_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_file_open_status"), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("mode"), + Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("str"), + Std_String_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Open_Status); + + -- function __ghdl_file_endfile (file : file_index_type) + -- return std_boolean_type_node; + Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_file_endfile"), + O_Storage_External, Std_Boolean_Type_Node); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Endfile); + + -- procedure __ghdl_text_file_close (file : file_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_text_file_close"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Text_File_Close); + + -- procedure __ghdl_file_close (file : file_index_type); + Start_Procedure_Decl (Interfaces, Get_Identifier ("__ghdl_file_close"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Close); + + -- procedure __ghdl_file_flush (file : file_index_type); + Start_Procedure_Decl (Interfaces, Get_Identifier ("__ghdl_file_flush"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("file"), + Ghdl_File_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_File_Flush); + + --------------- + -- signals -- + --------------- + + -- procedure __ghdl_signal_create_resolution + -- (func : ghdl_ptr_type; + -- instance : ghdl_ptr_type; + -- sig : ghdl_ptr_type; + -- nbr_sig : ghdl_index_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_create_resolution"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("func"), Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("nbr_sig"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Create_Resolution); + + -- Declarations for signals. + -- Max length of a scalar type. + -- type __ghdl_scalar_bytes is __ghdl_chararray (0 .. 8); + Ghdl_Scalar_Bytes := New_Constrained_Array_Type + (Chararray_Type, New_Unsigned_Literal (Ghdl_Index_Type, 8)); + New_Type_Decl (Get_Identifier ("__ghdl_scalar_bytes"), + Ghdl_Scalar_Bytes); + + New_Uncomplete_Record_Type (Ghdl_Signal_Type); + New_Type_Decl (Get_Identifier ("__ghdl_signal"), Ghdl_Signal_Type); + + Ghdl_Signal_Ptr := New_Access_Type (Ghdl_Signal_Type); + New_Type_Decl (Get_Identifier ("__ghdl_signal_ptr"), Ghdl_Signal_Ptr); + + -- Type __signal_signal is record + Start_Uncomplete_Record_Type (Ghdl_Signal_Type, Rec); + New_Record_Field (Rec, Ghdl_Signal_Value_Field, + Get_Identifier ("value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Driving_Value_Field, + Get_Identifier ("driving_value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Last_Value_Field, + Get_Identifier ("last_value"), + Ghdl_Scalar_Bytes); + New_Record_Field (Rec, Ghdl_Signal_Last_Event_Field, + Get_Identifier ("last_event"), + Std_Time_Otype); + New_Record_Field (Rec, Ghdl_Signal_Last_Active_Field, + Get_Identifier ("last_active"), + Std_Time_Otype); + New_Record_Field (Rec, Ghdl_Signal_Event_Field, + Get_Identifier ("event"), + Std_Boolean_Type_Node); + New_Record_Field (Rec, Ghdl_Signal_Active_Field, + Get_Identifier ("active"), + Std_Boolean_Type_Node); + New_Record_Field (Rec, Ghdl_Signal_Has_Active_Field, + Get_Identifier ("has_active"), + Ghdl_Bool_Type); + Finish_Record_Type (Rec, Ghdl_Signal_Type); + + Ghdl_Signal_Ptr_Ptr := New_Access_Type (Ghdl_Signal_Ptr); + New_Type_Decl (Get_Identifier ("__ghdl_signal_ptr_ptr"), + Ghdl_Signal_Ptr_Ptr); + + -- procedure __ghdl_signal_merge_rti + -- (sig : ghdl_signal_ptr; rti : ghdl_rti_access) + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_merge_rti"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Merge_Rti); + + -- procedure __ghdl_signal_add_source (targ : __ghdl_signal_ptr; + -- src : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_add_source"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("targ"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Add_Source); + + -- procedure __ghdl_signal_effective_value (targ : __ghdl_signal_ptr; + -- src : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_effective_value"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("targ"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("src"), + Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Effective_Value); + + -- procedure __ghdl_signal_set_disconnect (sig : __ghdl_signal_ptr; + -- val : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_set_disconnect"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("time"), Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Set_Disconnect); + + -- procedure __ghdl_signal_disconnect (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_disconnect"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Disconnect); + + -- function __ghdl_signal_get_nbr_drivers (sig : __ghdl_signal_ptr) + -- return ghdl_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_get_nbr_drivers"), + O_Storage_External, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Get_Nbr_Drivers); + + -- function __ghdl_signal_get_nbr_sources (sig : __ghdl_signal_ptr) + -- return ghdl_index_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_get_nbr_ports"), + O_Storage_External, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Get_Nbr_Ports); + + -- function __ghdl_signal_read_driver (sig : __ghdl_signal_ptr; + -- num : ghdl_index_type) + -- return ghdl_ptr_type; + declare + procedure Create_Signal_Read (Name : String; Subprg : out O_Dnode) is + begin + Start_Function_Decl + (Interfaces, Get_Identifier (Name), + O_Storage_External, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("num"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Signal_Read; + begin + Create_Signal_Read + ("__ghdl_signal_read_driver", Ghdl_Signal_Read_Driver); + Create_Signal_Read + ("__ghdl_signal_read_port", Ghdl_Signal_Read_Port); + end; + + -- function __ghdl_signal_driving (sig : __ghdl_signal_ptr) + -- return std_boolean; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_driving"), + O_Storage_External, Std_Boolean_Type_Node); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Driving); + + -- procedure __ghdl_signal_simple_assign_error + -- (sig : __ghdl_signal_ptr; + -- filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_simple_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Simple_Assign_Error); + + -- procedure __ghdl_signal_start_assign_error (sign : __ghdl_signal_ptr; + -- reject : std_time; + -- after : std_time; + -- filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Start_Assign_Error); + + -- procedure __ghdl_signal_next_assign_error (sig : __ghdl_signal_ptr; + -- after : std_time; + -- filename : char_ptr_type; + -- line : ghdl_i32); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_error"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Filename, Char_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_Line, Ghdl_I32_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Next_Assign_Error); + + -- procedure __ghdl_signal_start_assign_null (sig : __ghdl_signal_ptr; + -- reject : std_time; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_start_assign_null"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), + Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Start_Assign_Null); + + -- procedure __ghdl_signal_next_assign_null (sig : __ghdl_signal_ptr; + -- after : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_null"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Next_Assign_Null); + + -- function __ghdl_create_signal_e8 (init_val : ghdl_i32_type) + -- return __ghdl_signal_ptr; + -- procedure __ghdl_signal_simple_assign_e8 (sign : __ghdl_signal_ptr; + -- val : __ghdl_integer); + Create_Signal_Subprograms ("e8", Ghdl_I32_Type, + Ghdl_Create_Signal_E8, + Ghdl_Signal_Init_E8, + Ghdl_Signal_Simple_Assign_E8, + Ghdl_Signal_Start_Assign_E8, + Ghdl_Signal_Next_Assign_E8, + Ghdl_Signal_Associate_E8, + Ghdl_Signal_Driving_Value_E8); + + -- function __ghdl_create_signal_e32 (init_val : ghdl_i32_type) + -- return __ghdl_signal_ptr; + -- procedure __ghdl_signal_simple_assign_e32 (sign : __ghdl_signal_ptr; + -- val : __ghdl_integer); + Create_Signal_Subprograms ("e32", Ghdl_I32_Type, + Ghdl_Create_Signal_E32, + Ghdl_Signal_Init_E32, + Ghdl_Signal_Simple_Assign_E32, + Ghdl_Signal_Start_Assign_E32, + Ghdl_Signal_Next_Assign_E32, + Ghdl_Signal_Associate_E32, + Ghdl_Signal_Driving_Value_E32); + + -- function __ghdl_create_signal_b1 (init_val : ghdl_bool_type) + -- return __ghdl_signal_ptr; + -- procedure __ghdl_signal_simple_assign_b1 (sign : __ghdl_signal_ptr; + -- val : ghdl_bool_type); + Create_Signal_Subprograms ("b1", Ghdl_Bool_Type, + Ghdl_Create_Signal_B1, + Ghdl_Signal_Init_B1, + Ghdl_Signal_Simple_Assign_B1, + Ghdl_Signal_Start_Assign_B1, + Ghdl_Signal_Next_Assign_B1, + Ghdl_Signal_Associate_B1, + Ghdl_Signal_Driving_Value_B1); + + Create_Signal_Subprograms ("i32", Ghdl_I32_Type, + Ghdl_Create_Signal_I32, + Ghdl_Signal_Init_I32, + Ghdl_Signal_Simple_Assign_I32, + Ghdl_Signal_Start_Assign_I32, + Ghdl_Signal_Next_Assign_I32, + Ghdl_Signal_Associate_I32, + Ghdl_Signal_Driving_Value_I32); + + Create_Signal_Subprograms ("f64", Ghdl_Real_Type, + Ghdl_Create_Signal_F64, + Ghdl_Signal_Init_F64, + Ghdl_Signal_Simple_Assign_F64, + Ghdl_Signal_Start_Assign_F64, + Ghdl_Signal_Next_Assign_F64, + Ghdl_Signal_Associate_F64, + Ghdl_Signal_Driving_Value_F64); + + if not Flag_Only_32b then + Create_Signal_Subprograms ("i64", Ghdl_I64_Type, + Ghdl_Create_Signal_I64, + Ghdl_Signal_Init_I64, + Ghdl_Signal_Simple_Assign_I64, + Ghdl_Signal_Start_Assign_I64, + Ghdl_Signal_Next_Assign_I64, + Ghdl_Signal_Associate_I64, + Ghdl_Signal_Driving_Value_I64); + end if; + + -- procedure __ghdl_process_add_sensitivity (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_add_sensitivity"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Add_Sensitivity); + + -- procedure __ghdl_process_add_driver (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_add_driver"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Add_Driver); + + -- procedure __ghdl_signal_add_direct_driver (sig : __ghdl_signal_ptr; + -- Drv : Ghdl_Ptr_type); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_add_direct_driver"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("drv"), Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Add_Direct_Driver); + + -- procedure __ghdl_signal_direct_assign (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_direct_assign"), + O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Direct_Assign); + + declare + procedure Create_Signal_Conversion (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("func"), Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("src"), Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("src_len"), Ghdl_Index_Type); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("dst"), Ghdl_Signal_Ptr); + New_Interface_Decl + (Interfaces, Param, Get_Identifier ("dst_len"), Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Signal_Conversion; + begin + -- procedure __ghdl_signal_in_conversion (func : ghdl_ptr_type; + -- instance : ghdl_ptr_type; + -- src : ghdl_signal_ptr; + -- src_len : ghdl_index_type; + -- dst : ghdl_signal_ptr; + -- dst_len : ghdl_index_type); + Create_Signal_Conversion + ("__ghdl_signal_in_conversion", Ghdl_Signal_In_Conversion); + Create_Signal_Conversion + ("__ghdl_signal_out_conversion", Ghdl_Signal_Out_Conversion); + end; + + declare + -- function __ghdl_create_XXX_signal (val : std_time) + -- return __ghdl_signal_ptr; + procedure Create_Signal_Attribute (Name : String; Res : out O_Dnode) + is + begin + Start_Function_Decl (Interfaces, Get_Identifier (Name), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Signal_Attribute; + begin + -- function __ghdl_create_stable_signal (val : std_time) + -- return __ghdl_signal_ptr; + Create_Signal_Attribute + ("__ghdl_create_stable_signal", Ghdl_Create_Stable_Signal); + + -- function __ghdl_create_quiet_signal (val : std_time) + -- return __ghdl_signal_ptr; + Create_Signal_Attribute + ("__ghdl_create_quiet_signal", Ghdl_Create_Quiet_Signal); + + -- function __ghdl_create_transaction_signal + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_transaction_signal"), + O_Storage_External, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Create_Transaction_Signal); + end; + + -- procedure __ghdl_signal_attribute_register_prefix + -- (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, + Get_Identifier ("__ghdl_signal_attribute_register_prefix"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl + (Interfaces, Ghdl_Signal_Attribute_Register_Prefix); + + -- function __ghdl_create_delayed_signal (sig : __ghdl_signal_ptr; + -- val : std_time) + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_create_delayed_signal"), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("sig"), + Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Wki_Val, Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Create_Delayed_Signal); + + -- function __ghdl_signal_create_guard + -- (this : ghdl_ptr_type; + -- proc : ghdl_ptr_type; + -- instance_name : __ghdl_instance_name_acc) + -- return __ghdl_signal_ptr; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_create_guard"), + O_Storage_External, Ghdl_Signal_Ptr); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("this"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("proc"), + Ghdl_Ptr_Type); +-- New_Interface_Decl (Interfaces, Param, Get_Identifier ("instance_name"), +-- Ghdl_Instance_Name_Acc); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Create_Guard); + + -- procedure __ghdl_signal_guard_dependence (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_signal_guard_dependence"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Signal_Guard_Dependence); + + -- procedure __ghdl_process_wait_exit (void); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_exit"), + O_Storage_External); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Exit); + + -- void __ghdl_process_wait_timeout (time : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_timeout"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("time"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Timeout); + + -- void __ghdl_process_wait_set_timeout (time : std_time); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_set_timeout"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("time"), + Std_Time_Otype); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Set_Timeout); + + -- void __ghdl_process_wait_add_sensitivity (sig : __ghdl_signal_ptr); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_add_sensitivity"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Add_Sensitivity); + + -- function __ghdl_process_wait_suspend return __ghdl_bool_type; + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_suspend"), + O_Storage_External, Ghdl_Bool_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Suspend); + + -- void __ghdl_process_wait_close (void); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_process_wait_close"), + O_Storage_External); + Finish_Subprogram_Decl (Interfaces, Ghdl_Process_Wait_Close); + + declare + procedure Create_Get_Name (Name : String; Res : out O_Dnode) + is + begin + Start_Procedure_Decl + (Interfaces, Get_Identifier (Name), O_Storage_External); + New_Interface_Decl + (Interfaces, Param, Wki_Res, Std_String_Ptr_Node); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("ctxt"), + Rtis.Ghdl_Rti_Access); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("addr"), + Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("name"), + Ghdl_Str_Len_Ptr_Node); + Finish_Subprogram_Decl (Interfaces, Res); + end Create_Get_Name; + begin + -- procedure __ghdl_get_path_name (res : std_string_ptr_node; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type; + -- name : __ghdl_str_len_ptr); + Create_Get_Name ("__ghdl_get_path_name", Ghdl_Get_Path_Name); + + -- procedure __ghdl_get_instance_name (res : std_string_ptr_node; + -- ctxt : ghdl_rti_access; + -- addr : ghdl_ptr_type; + -- name : __ghdl_str_len_ptr); + Create_Get_Name ("__ghdl_get_instance_name", Ghdl_Get_Instance_Name); + end; + + -- procedure __ghdl_rti_add_package (rti : ghdl_rti_access) + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_rti_add_package"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + Finish_Subprogram_Decl (Interfaces, Ghdl_Rti_Add_Package); + + -- procedure __ghdl_rti_add_top (max_pkgs : ghdl_index_type; + -- pkgs : ghdl_rti_arr_acc); + Start_Procedure_Decl + (Interfaces, Get_Identifier ("__ghdl_rti_add_top"), + O_Storage_External); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("max_pkgs"), + Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Get_Identifier ("pkgs"), + Rtis.Ghdl_Rti_Arr_Acc); + New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); + New_Interface_Decl + (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type); + Finish_Subprogram_Decl (Interfaces, Ghdl_Rti_Add_Top); + + -- Create match subprograms for std_ulogic type. + Create_Std_Ulogic_Match_Subprogram ("eq", Ghdl_Std_Ulogic_Match_Eq); + Create_Std_Ulogic_Match_Subprogram ("ne", Ghdl_Std_Ulogic_Match_Ne); + Create_Std_Ulogic_Match_Subprogram ("lt", Ghdl_Std_Ulogic_Match_Lt); + Create_Std_Ulogic_Match_Subprogram ("le", Ghdl_Std_Ulogic_Match_Le); + + Create_Std_Ulogic_Array_Match_Subprogram + ("eq", Ghdl_Std_Ulogic_Array_Match_Eq); + Create_Std_Ulogic_Array_Match_Subprogram + ("ne", Ghdl_Std_Ulogic_Array_Match_Ne); + + -- Create To_String subprograms. + Create_To_String_Subprogram + ("__ghdl_to_string_i32", Ghdl_To_String_I32, Ghdl_I32_Type); + Create_To_String_Subprogram + ("__ghdl_to_string_f64", Ghdl_To_String_F64, Ghdl_Real_Type); + Create_To_String_Subprogram + ("__ghdl_to_string_f64_digits", Ghdl_To_String_F64_Digits, + Ghdl_Real_Type, Ghdl_I32_Type, Get_Identifier ("nbr_digits")); + Create_To_String_Subprogram + ("__ghdl_to_string_f64_format", Ghdl_To_String_F64_Format, + Ghdl_Real_Type, Std_String_Ptr_Node, Get_Identifier ("format")); + declare + Bv_Base_Ptr : constant O_Tnode := + Get_Info (Bit_Vector_Type_Definition).T.Base_Ptr_Type (Mode_Value); + begin + Create_To_String_Subprogram + ("__ghdl_bv_to_ostring", Ghdl_BV_To_Ostring, + Bv_Base_Ptr, Ghdl_Index_Type, Wki_Length); + Create_To_String_Subprogram + ("__ghdl_bv_to_hstring", Ghdl_BV_To_Hstring, + Bv_Base_Ptr, Ghdl_Index_Type, Wki_Length); + end; + Create_To_String_Subprogram + ("__ghdl_to_string_b1", Ghdl_To_String_B1, Ghdl_Bool_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_e8", Ghdl_To_String_E8, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_char", Ghdl_To_String_Char, + Get_Ortho_Type (Character_Type_Definition, Mode_Value)); + Create_To_String_Subprogram + ("__ghdl_to_string_e32", Ghdl_To_String_E32, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_p32", Ghdl_To_String_P32, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_p64", Ghdl_To_String_P64, Ghdl_I64_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_timue_to_string_unit", Ghdl_Time_To_String_Unit, + Std_Time_Otype, Std_Time_Otype, Get_Identifier ("unit"), + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_b1", Ghdl_Array_Char_To_String_B1, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_e8", Ghdl_Array_Char_To_String_E8, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_e32", Ghdl_Array_Char_To_String_E32, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + + end Post_Initialize; + + procedure Translate_Type_Implicit_Subprograms (Decl : in out Iir) + is + Infos : Chap7.Implicit_Subprogram_Infos; + begin + -- Skip type declaration. + pragma Assert (Get_Kind (Decl) in Iir_Kinds_Type_Declaration); + Decl := Get_Chain (Decl); + + Chap7.Init_Implicit_Subprogram_Infos (Infos); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration => + Chap7.Translate_Implicit_Subprogram (Decl, Infos); + Decl := Get_Chain (Decl); + when others => + exit; + end case; + end loop; + end Translate_Type_Implicit_Subprograms; + + procedure Translate_Standard (Main : Boolean) + is + Lib_Mark, Unit_Mark : Id_Mark_Type; + Info : Ortho_Info_Acc; + pragma Unreferenced (Info); + Decl : Iir; + Time_Type_Staticness : Iir_Staticness; + Time_Subtype_Staticness : Iir_Staticness; + begin + Update_Node_Infos; + + New_Debug_Comment_Decl ("package std.standard"); + if Main then + Gen_Filename (Std_Standard_File); + Set_Global_Storage (O_Storage_Public); + else + Set_Global_Storage (O_Storage_External); + end if; + + Info := Add_Info (Standard_Package, Kind_Package); + + Reset_Identifier_Prefix; + Push_Identifier_Prefix + (Lib_Mark, Get_Identifier (Libraries.Std_Library)); + Push_Identifier_Prefix + (Unit_Mark, Get_Identifier (Standard_Package)); + + -- With VHDL93 and later, time type is globally static. As a result, + -- it will be elaborated at run-time (and not statically). + -- However, there is no elaboration of std.standard. Furthermore, + -- time type can be pre-elaborated without any difficulties. + -- There is a kludge here: set type staticess of time type locally + -- and then revert it just after its translation. + Time_Type_Staticness := Get_Type_Staticness (Time_Type_Definition); + Time_Subtype_Staticness := Get_Type_Staticness (Time_Subtype_Definition); + if Flags.Flag_Time_64 then + Set_Type_Staticness (Time_Type_Definition, Locally); + end if; + Set_Type_Staticness (Time_Subtype_Definition, Locally); + if Flags.Vhdl_Std > Vhdl_87 then + Set_Type_Staticness (Delay_Length_Subtype_Definition, Locally); + end if; + + Decl := Get_Declaration_Chain (Standard_Package); + + -- The first (and one of the most important) declaration is the + -- boolean type declaration. + pragma Assert (Decl = Boolean_Type_Declaration); + Chap4.Translate_Bool_Type_Declaration (Boolean_Type_Declaration); + -- We need this type very early, for predefined functions. + Std_Boolean_Type_Node := + Get_Ortho_Type (Boolean_Type_Definition, Mode_Value); + 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); + Translate_Type_Implicit_Subprograms (Decl); + + -- Second declaration: bit. + pragma Assert (Decl = Bit_Type_Declaration); + Chap4.Translate_Bool_Type_Declaration (Bit_Type_Declaration); + Translate_Type_Implicit_Subprograms (Decl); + + -- Nothing special for other declarations. + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Type_Declaration => + Chap4.Translate_Type_Declaration (Decl); + Translate_Type_Implicit_Subprograms (Decl); + when Iir_Kind_Anonymous_Type_Declaration => + Chap4.Translate_Anonymous_Type_Declaration (Decl); + Translate_Type_Implicit_Subprograms (Decl); + when Iir_Kind_Subtype_Declaration => + Chap4.Translate_Subtype_Declaration (Decl); + Decl := Get_Chain (Decl); + when Iir_Kind_Attribute_Declaration => + Decl := Get_Chain (Decl); + when Iir_Kind_Implicit_Function_Declaration => + case Get_Implicit_Definition (Decl) is + when Iir_Predefined_Now_Function => + null; + when Iir_Predefined_Enum_To_String + | Iir_Predefined_Integer_To_String + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Real_To_String_Digits + | Iir_Predefined_Real_To_String_Format + | Iir_Predefined_Physical_To_String + | Iir_Predefined_Time_To_String_Unit => + -- These are defined after the types. + null; + when others => + Error_Kind + ("translate_standard (" + & Iir_Predefined_Functions'Image + (Get_Implicit_Definition (Decl)) & ")", + Decl); + end case; + Decl := Get_Chain (Decl); + when others => + Error_Kind ("translate_standard", Decl); + end case; + -- DECL was updated by Translate_Type_Implicit_Subprograms or + -- explicitly in other branches. + end loop; + + -- These types don't appear in std.standard. + Chap4.Translate_Anonymous_Type_Declaration + (Convertible_Integer_Type_Declaration); + Chap4.Translate_Anonymous_Type_Declaration + (Convertible_Real_Type_Declaration); + + -- Restore time type staticness. + + if Flags.Vhdl_Std > Vhdl_87 then + Set_Type_Staticness (Delay_Length_Subtype_Definition, + Time_Subtype_Staticness); + end if; + Set_Type_Staticness (Time_Type_Definition, Time_Type_Staticness); + Set_Type_Staticness (Time_Subtype_Definition, Time_Subtype_Staticness); + + if Flag_Rti then + Rtis.Generate_Unit (Standard_Package); + Std_Standard_Boolean_Rti + := Get_Info (Boolean_Type_Definition).Type_Rti; + Std_Standard_Bit_Rti + := 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); + + Post_Initialize; + Current_Filename_Node := O_Dnode_Null; + --Pop_Global_Factory; + end Translate_Standard; + + procedure Finalize + is + Info : Ortho_Info_Acc; + Prev_Info : Ortho_Info_Acc; + begin + Prev_Info := null; + for I in Node_Infos.First .. Node_Infos.Last loop + Info := Get_Info (I); + if Info /= null and then Info /= Prev_Info then + case Get_Kind (I) is + when Iir_Kind_Constant_Declaration => + if Get_Deferred_Declaration_Flag (I) = False + and then Get_Deferred_Declaration (I) /= Null_Iir + then + -- Info are copied from incomplete constant declaration + -- to full constant declaration. + Clear_Info (I); + else + Free_Info (I); + end if; + when Iir_Kind_Record_Subtype_Definition + | Iir_Kind_Access_Subtype_Definition => + null; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Free_Type_Info (Info); + when Iir_Kind_Array_Subtype_Definition => + if Get_Index_Constraint_Flag (I) then + Info.T := Ortho_Info_Type_Array_Init; + Free_Type_Info (Info); + end if; + when Iir_Kind_Implicit_Function_Declaration => + case Get_Implicit_Definition (I) is + when Iir_Predefined_Bit_Array_Match_Equality + | Iir_Predefined_Bit_Array_Match_Inequality => + -- Not in sequence. + null; + when others => + -- By default, info are not shared. + -- The exception is infos for implicit subprograms, + -- but they are always consecutive and not free twice + -- due to prev_info mechanism. + Free_Info (I); + end case; + when others => + -- By default, info are not shared. + Free_Info (I); + end case; + Prev_Info := Info; + end if; + end loop; + Node_Infos.Free; + Free_Old_Temp; + end Finalize; + + package body Chap12 is + -- Create __ghdl_ELABORATE + procedure Gen_Main (Entity : Iir_Entity_Declaration; + Arch : Iir_Architecture_Body; + Config_Subprg : O_Dnode; + Nbr_Pkgs : Natural) + is + Entity_Info : Block_Info_Acc; + Arch_Info : Block_Info_Acc; + Inter_List : O_Inter_List; + Assoc : O_Assoc_List; + Instance : O_Dnode; + Arch_Instance : O_Dnode; + Mark : Id_Mark_Type; + Arr_Type : O_Tnode; + Arr : O_Dnode; + begin + Arch_Info := Get_Info (Arch); + Entity_Info := Get_Info (Entity); + + -- We need to create code. + Set_Global_Storage (O_Storage_Private); + + -- Create the array of RTIs for packages (as a variable, initialized + -- during elaboration). + Arr_Type := New_Constrained_Array_Type + (Rtis.Ghdl_Rti_Array, + New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Pkgs))); + New_Var_Decl (Arr, Get_Identifier ("__ghdl_top_RTIARRAY"), + O_Storage_Private, Arr_Type); + + -- The elaboration entry point. + Start_Procedure_Decl (Inter_List, Get_Identifier ("__ghdl_ELABORATE"), + O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Ghdl_Elaborate); + + Start_Subprogram_Body (Ghdl_Elaborate); + New_Var_Decl (Arch_Instance, Wki_Arch_Instance, + O_Storage_Local, Arch_Info.Block_Decls_Ptr_Type); + + New_Var_Decl (Instance, Wki_Instance, O_Storage_Local, + Entity_Info.Block_Decls_Ptr_Type); + + -- Create instance for the architecture. + New_Assign_Stmt + (New_Obj (Arch_Instance), + Gen_Alloc (Alloc_System, + New_Lit (Get_Scope_Size (Arch_Info.Block_Scope)), + Arch_Info.Block_Decls_Ptr_Type)); + + -- Set the top instance. + New_Assign_Stmt + (New_Obj (Instance), + New_Address (New_Selected_Acc_Value (New_Obj (Arch_Instance), + Arch_Info.Block_Parent_Field), + Entity_Info.Block_Decls_Ptr_Type)); + + -- Clear parent field of entity link. + New_Assign_Stmt + (New_Selected_Element + (New_Selected_Acc_Value (New_Obj (Instance), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Parent), + New_Lit (New_Null_Access (Rtis.Ghdl_Component_Link_Acc))); + + -- Set top instances and RTI. + -- Do it before the elaboration code, since it may be used to + -- diagnose errors. + -- Call ghdl_rti_add_top + Start_Association (Assoc, Ghdl_Rti_Add_Top); + New_Association + (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type, + Unsigned_64 (Nbr_Pkgs)))); + New_Association + (Assoc, New_Lit (New_Global_Address (Arr, Rtis.Ghdl_Rti_Arr_Acc))); + New_Association + (Assoc, + New_Lit (Rtis.New_Rti_Address (Get_Info (Arch).Block_Rti_Const))); + New_Association + (Assoc, New_Convert_Ov (New_Obj_Value (Arch_Instance), + Ghdl_Ptr_Type)); + New_Procedure_Call (Assoc); + + -- Add std.standard rti + Start_Association (Assoc, Ghdl_Rti_Add_Package); + New_Association + (Assoc, + New_Lit (Rtis.New_Rti_Address + (Get_Info (Standard_Package).Package_Rti_Const))); + New_Procedure_Call (Assoc); + + Gen_Filename (Get_Design_File (Get_Design_Unit (Entity))); + + -- Elab package dependences of top entity (so that default + -- expressions can be evaluated). + Start_Association (Assoc, Entity_Info.Block_Elab_Pkg_Subprg); + New_Procedure_Call (Assoc); + + -- init instance + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Instance); + Push_Identifier_Prefix (Mark, ""); + Chap1.Translate_Entity_Init (Entity); + + -- elab instance + Start_Association (Assoc, Arch_Info.Block_Elab_Subprg); + New_Association (Assoc, New_Obj_Value (Instance)); + New_Procedure_Call (Assoc); + + --Chap6.Link_Instance_Name (Null_Iir, Entity); + + -- configure instance. + Start_Association (Assoc, Config_Subprg); + New_Association (Assoc, New_Obj_Value (Arch_Instance)); + New_Procedure_Call (Assoc); + + Pop_Identifier_Prefix (Mark); + Clear_Scope (Entity_Info.Block_Scope); + Finish_Subprogram_Body; + + Current_Filename_Node := O_Dnode_Null; + end Gen_Main; + + procedure Gen_Setup_Info + is + Cst : O_Dnode; + pragma Unreferenced (Cst); + begin + Cst := Create_String (Flags.Flag_String, + Get_Identifier ("__ghdl_flag_string"), + O_Storage_Public); + end Gen_Setup_Info; + + procedure Gen_Last_Arch (Entity : Iir_Entity_Declaration) + is + Entity_Info : Block_Info_Acc; + + Arch : Iir_Architecture_Body; + Arch_Info : Block_Info_Acc; + + Lib : Iir_Library_Declaration; + Lib_Mark, Entity_Mark, Arch_Mark : Id_Mark_Type; + + Config : Iir_Configuration_Declaration; + Config_Info : Config_Info_Acc; + + Const : O_Dnode; + Instance : O_Dnode; + Inter_List : O_Inter_List; + Constr : O_Assoc_List; + Subprg : O_Dnode; + begin + Arch := Libraries.Get_Latest_Architecture (Entity); + if Arch = Null_Iir then + Error_Msg_Elab ("no architecture for " & Disp_Node (Entity)); + end if; + Arch_Info := Get_Info (Arch); + if Arch_Info = null then + -- Nothing to do here, since the architecture is not used. + return; + end if; + Entity_Info := Get_Info (Entity); + + -- Create trampoline for elab, default_architecture + -- re-create instsize. + Reset_Identifier_Prefix; + Lib := Get_Library (Get_Design_File (Get_Design_Unit (Entity))); + Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); + Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity)); + Push_Identifier_Prefix (Arch_Mark, "LASTARCH"); + + -- Instance size. + New_Const_Decl + (Const, Create_Identifier ("INSTSIZE"), O_Storage_Public, + Ghdl_Index_Type); + Start_Const_Value (Const); + Finish_Const_Value (Const, Get_Scope_Size (Arch_Info.Block_Scope)); + + -- Elaborator. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("ELAB"), O_Storage_Public); + New_Interface_Decl + (Inter_List, Instance, Wki_Instance, + Entity_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Subprg); + + Start_Subprogram_Body (Subprg); + Start_Association (Constr, Arch_Info.Block_Elab_Subprg); + New_Association (Constr, New_Obj_Value (Instance)); + New_Procedure_Call (Constr); + Finish_Subprogram_Body; + + -- Default config. + Config := Get_Library_Unit + (Get_Default_Configuration_Declaration (Arch)); + Config_Info := Get_Info (Config); + if Config_Info /= null then + -- Do not create a trampoline for the default_config if it is not + -- used. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), + O_Storage_Public); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Arch_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Subprg); + + Start_Subprogram_Body (Subprg); + Start_Association (Constr, Config_Info.Config_Subprg); + New_Association (Constr, New_Obj_Value (Instance)); + New_Procedure_Call (Constr); + Finish_Subprogram_Body; + end if; + + Pop_Identifier_Prefix (Arch_Mark); + Pop_Identifier_Prefix (Entity_Mark); + Pop_Identifier_Prefix (Lib_Mark); + end Gen_Last_Arch; + + procedure Gen_Dummy_Default_Config (Arch : Iir_Architecture_Body) + is + Entity : Iir_Entity_Declaration; + Lib : Iir_Library_Declaration; + Lib_Mark, Entity_Mark, Sep_Mark, Arch_Mark : Id_Mark_Type; + + Inter_List : O_Inter_List; + + Subprg : O_Dnode; + begin + Reset_Identifier_Prefix; + Entity := Get_Entity (Arch); + Lib := Get_Library (Get_Design_File (Get_Design_Unit (Arch))); + Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); + Push_Identifier_Prefix (Entity_Mark, Get_Identifier (Entity)); + Push_Identifier_Prefix (Sep_Mark, "ARCH"); + Push_Identifier_Prefix (Arch_Mark, Get_Identifier (Arch)); + + -- Elaborator. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), + O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Subprg); + + Start_Subprogram_Body (Subprg); + Chap6.Gen_Program_Error (Arch, Chap6.Prg_Err_Dummy_Config); + Finish_Subprogram_Body; + + Pop_Identifier_Prefix (Arch_Mark); + Pop_Identifier_Prefix (Sep_Mark); + Pop_Identifier_Prefix (Entity_Mark); + Pop_Identifier_Prefix (Lib_Mark); + end Gen_Dummy_Default_Config; + + procedure Gen_Dummy_Package_Declaration (Unit : Iir_Design_Unit) + is + Pkg : Iir_Package_Declaration; + Lib : Iir_Library_Declaration; + Lib_Mark, Pkg_Mark : Id_Mark_Type; + + Decl : Iir; + begin + Libraries.Load_Design_Unit (Unit, Null_Iir); + Pkg := Get_Library_Unit (Unit); + Reset_Identifier_Prefix; + Lib := Get_Library (Get_Design_File (Get_Design_Unit (Pkg))); + Push_Identifier_Prefix (Lib_Mark, Get_Identifier (Lib)); + Push_Identifier_Prefix (Pkg_Mark, Get_Identifier (Pkg)); + + if Get_Need_Body (Pkg) then + Decl := Get_Declaration_Chain (Pkg); + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + -- Generate empty body. + + -- Never a second spec, as this is within a package + -- declaration. + pragma Assert + (not Is_Second_Subprogram_Specification (Decl)); + + if not Get_Foreign_Flag (Decl) then + declare + Mark : Id_Mark_Type; + Inter_List : O_Inter_List; + Proc : O_Dnode; + begin + Chap2.Push_Subprg_Identifier (Decl, Mark); + Start_Procedure_Decl + (Inter_List, Create_Identifier, O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Proc); + Start_Subprogram_Body (Proc); + Finish_Subprogram_Body; + Pop_Identifier_Prefix (Mark); + end; + end if; + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + end if; + + -- Create the body elaborator. + declare + Inter_List : O_Inter_List; + Proc : O_Dnode; + begin + Start_Procedure_Decl + (Inter_List, Create_Identifier ("ELAB_BODY"), O_Storage_Public); + Finish_Subprogram_Decl (Inter_List, Proc); + Start_Subprogram_Body (Proc); + Finish_Subprogram_Body; + end; + + Pop_Identifier_Prefix (Pkg_Mark); + Pop_Identifier_Prefix (Lib_Mark); + end Gen_Dummy_Package_Declaration; + + procedure Write_File_List (Filelist : String) + is + use Interfaces.C_Streams; + use System; + use Configuration; + use Name_Table; + + -- Add all dependences of UNIT. + -- UNIT is not used, but added during link. + procedure Add_Unit_Dependences (Unit : Iir_Design_Unit) + is + Dep_List : Iir_List; + Dep : Iir; + Dep_Unit : Iir_Design_Unit; + Lib_Unit : Iir; + begin + -- Load the unit in memory to compute the dependence list. + Libraries.Load_Design_Unit (Unit, Null_Iir); + Update_Node_Infos; + + Set_Elab_Flag (Unit, True); + Design_Units.Append (Unit); + + if Flag_Rti then + Rtis.Generate_Library + (Get_Library (Get_Design_File (Unit)), True); + end if; + + Lib_Unit := Get_Library_Unit (Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Package_Declaration => + -- The body may be required due to incomplete constant + -- declarations, or to call to a subprogram. + declare + Pack_Body : Iir; + begin + Pack_Body := Libraries.Find_Secondary_Unit + (Unit, Null_Identifier); + if Pack_Body /= Null_Iir then + Add_Unit_Dependences (Pack_Body); + else + Gen_Dummy_Package_Declaration (Unit); + end if; + end; + when Iir_Kind_Architecture_Body => + Gen_Dummy_Default_Config (Lib_Unit); + when others => + null; + end case; + + Dep_List := Get_Dependence_List (Unit); + for I in Natural loop + Dep := Get_Nth_Element (Dep_List, I); + exit when Dep = Null_Iir; + Dep_Unit := Libraries.Find_Design_Unit (Dep); + if Dep_Unit = Null_Iir then + Error_Msg_Elab + ("could not find design unit " & Disp_Node (Dep)); + elsif not Get_Elab_Flag (Dep_Unit) then + Add_Unit_Dependences (Dep_Unit); + end if; + end loop; + end Add_Unit_Dependences; + + -- Add not yet added units of FILE. + procedure Add_File_Units (File : Iir_Design_File) + is + Unit : Iir_Design_Unit; + begin + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + if not Get_Elab_Flag (Unit) then + -- Unit not used. + Add_Unit_Dependences (Unit); + end if; + Unit := Get_Chain (Unit); + end loop; + end Add_File_Units; + + Nul : constant Character := Character'Val (0); + Fname : String := Filelist & Nul; + Mode : constant String := "wt" & Nul; + F : FILEs; + R : int; + S : size_t; + pragma Unreferenced (R, S); -- FIXME + Id : Name_Id; + Lib : Iir_Library_Declaration; + File : Iir_Design_File; + Unit : Iir_Design_Unit; + J : Natural; + begin + F := fopen (Fname'Address, Mode'Address); + if F = NULL_Stream then + Error_Msg_Elab ("cannot open " & Filelist); + end if; + + -- Set elab flags on units, and remove it on design files. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Set_Elab_Flag (Unit, True); + File := Get_Design_File (Unit); + Set_Elab_Flag (File, False); + end loop; + + J := Design_Units.First; + while J <= Design_Units.Last loop + Unit := Design_Units.Table (J); + File := Get_Design_File (Unit); + if not Get_Elab_Flag (File) then + Set_Elab_Flag (File, True); + + -- Add dependences of unused design units, otherwise the object + -- link case failed. + Add_File_Units (File); + + Lib := Get_Library (File); + R := fputc (Character'Pos ('>'), F); + Id := Get_Library_Directory (Lib); + S := fwrite (Get_Address (Id), + size_t (Get_Name_Length (Id)), 1, F); + R := fputc (10, F); + + Id := Get_Design_File_Filename (File); + S := fwrite (Get_Address (Id), + size_t (Get_Name_Length (Id)), 1, F); + R := fputc (10, F); + end if; + J := J + 1; + end loop; + end Write_File_List; + + procedure Elaborate + (Primary : String; + Secondary : String; + Filelist : String; + Whole : Boolean) + is + use Name_Table; + use Configuration; + + Primary_Id : Name_Id; + Secondary_Id : Name_Id; + Unit : Iir_Design_Unit; + Lib_Unit : Iir; + Config : Iir_Design_Unit; + Config_Lib : Iir_Configuration_Declaration; + Entity : Iir_Entity_Declaration; + Arch : Iir_Architecture_Body; + Conf_Info : Config_Info_Acc; + Last_Design_Unit : Natural; + Nbr_Pkgs : Natural; + begin + Primary_Id := Get_Identifier (Primary); + if Secondary /= "" then + Secondary_Id := Get_Identifier (Secondary); + else + Secondary_Id := Null_Identifier; + end if; + Config := Configure (Primary_Id, Secondary_Id); + if Config = Null_Iir then + return; + end if; + Config_Lib := Get_Library_Unit (Config); + Entity := Get_Entity (Config_Lib); + Arch := Get_Block_Specification + (Get_Block_Configuration (Config_Lib)); + + -- Be sure the entity can be at the top of a design. + Check_Entity_Declaration_Top (Entity); + + -- If all design units are loaded, late semantic checks can be + -- performed. + if Flag_Load_All_Design_Units then + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Sem.Sem_Analysis_Checks_List (Unit, False); + -- There cannot be remaining checks to do. + pragma Assert + (Get_Analysis_Checks_List (Unit) = Null_Iir_List); + end loop; + end if; + + -- Return now in case of errors. + if Nbr_Errors /= 0 then + return; + end if; + + if Flags.Verbose then + Ada.Text_IO.Put_Line ("List of units in the hierarchy design:"); + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit)); + end loop; + end if; + + if Whole then + -- In compile-and-elaborate mode, do not generate code for + -- unused subprograms. + -- FIXME: should be improved by creating a span-tree. + Flag_Discard_Unused := True; + Flag_Discard_Unused_Implicit := True; + end if; + + -- Generate_Library add infos, therefore the info array must be + -- adjusted. + Update_Node_Infos; + Rtis.Generate_Library (Libraries.Std_Library, True); + Translate_Standard (Whole); + + -- Translate all configurations needed. + -- Also, set the ELAB_FLAG on package with body. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + + if Whole then + -- In whole compilation mode, force to generate RTIS of + -- libraries. + Rtis.Generate_Library + (Get_Library (Get_Design_File (Unit)), True); + end if; + + case Get_Kind (Lib_Unit) is + when Iir_Kind_Configuration_Declaration => + -- Always generate code for configuration. + -- Because default binding may be changed between analysis + -- and elaboration. + Translate (Unit, True); + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + -- For package spec, mark it as 'body is not present', this + -- flag will be set below when the body is translated. + Set_Elab_Flag (Unit, False); + Translate (Unit, Whole); + when Iir_Kind_Package_Body => + -- Mark the spec with 'body is present' flag. + Set_Elab_Flag + (Get_Design_Unit (Get_Package (Lib_Unit)), True); + Translate (Unit, Whole); + when others => + Error_Kind ("elaborate", Lib_Unit); + end case; + end loop; + + -- Generate code to elaboration body-less package. + -- + -- When a package is analyzed, we don't know wether there is body + -- or not. Therefore, we assume there is always a body, and will + -- elaborate the body (which elaborates its spec). If a package + -- has no body, create the body elaboration procedure. + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Package_Declaration => + if not Get_Elab_Flag (Unit) then + Chap2.Elab_Package_Body (Lib_Unit, Null_Iir); + end if; + when Iir_Kind_Entity_Declaration => + Gen_Last_Arch (Lib_Unit); + when Iir_Kind_Architecture_Body + | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + null; + when others => + Error_Kind ("elaborate(2)", Lib_Unit); + end case; + end loop; + + Rtis.Generate_Top (Nbr_Pkgs); + + -- Create main code. + Conf_Info := Get_Info (Config_Lib); + Gen_Main (Entity, Arch, Conf_Info.Config_Subprg, Nbr_Pkgs); + + Gen_Setup_Info; + + -- Index of the last design unit, required by the design. + Last_Design_Unit := Design_Units.Last; + + -- Disp list of files needed. + -- FIXME: extract the link completion part of WRITE_FILE_LIST. + if Filelist /= "" then + Write_File_List (Filelist); + end if; + + if Flags.Verbose then + Ada.Text_IO.Put_Line ("List of units not used:"); + for I in Last_Design_Unit + 1 .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Lib_Unit := Get_Library_Unit (Unit); + Ada.Text_IO.Put_Line (' ' & Disp_Node (Lib_Unit)); + end loop; + end if; + end Elaborate; + end Chap12; +end Translation; diff --git a/src/translate/translation.ads b/src/translate/translation.ads new file mode 100644 index 0000000..e779685 --- /dev/null +++ b/src/translate/translation.ads @@ -0,0 +1,120 @@ +-- Iir to ortho translator. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iirs; use Iirs; +with Ortho_Nodes; + +package Translation is + -- Initialize the package: create internal nodes. + procedure Initialize; + + -- Translate (generate code) for design unit UNIT. + -- If MAIN is true, the unit is really the unit being compiled (not an + -- external unit). Code shouldn't be generated for external units. + procedure Translate (Unit : Iir_Design_Unit; Main : Boolean); + + -- Translate std.standard. + procedure Translate_Standard (Main : Boolean); + + -- Get the ortho node for subprogram declaration DECL. + function Get_Ortho_Decl (Subprg : Iir) return Ortho_Nodes.O_Dnode; + + -- Get the internal _RESOLV function for FUNC. + function Get_Resolv_Ortho_Decl (Func : Iir) return Ortho_Nodes.O_Dnode; + + procedure Finalize; + + package Chap12 is + -- Primary unit + secondary unit (architecture name which may be null) + -- to elaborate. + procedure Elaborate (Primary : String; + Secondary : String; + Filelist : String; + Whole : Boolean); + end Chap12; + + -- If set, generate Run-Time Information nodes. + Flag_Rti : Boolean := True; + + -- If set, do not generate 64 bits integer types and operations. + Flag_Only_32b : Boolean := False; + + -- If set, do not generate code for unused subprograms. + -- Be careful: unless you are in whole compilation mode, this + -- flag shouldn't be set for packages and entities. + Flag_Discard_Unused : Boolean := False; + + -- If set, do not generate code for unused implicit subprograms. + Flag_Discard_Unused_Implicit : Boolean := False; + + -- If set, dump drivers per process during compilation. + Flag_Dump_Drivers : Boolean := False; + + -- If set, try to create direct drivers. + Flag_Direct_Drivers : Boolean := True; + + -- If set, checks ranges (subtype ranges). + Flag_Range_Checks : Boolean := True; + + -- If set, checks indexes (arrays index and slice). + Flag_Index_Checks : Boolean := True; + + -- If set, do not create identifiers (for in memory compilation). + Flag_Discard_Identifiers : Boolean := False; + + -- If true, do not create nested subprograms. + -- This flag is forced during initialization if the code generated doesn't + -- support nested subprograms. + Flag_Unnest_Subprograms : Boolean := False; + + type Foreign_Kind_Type is (Foreign_Unknown, + Foreign_Vhpidirect, + Foreign_Intrinsic); + + type Foreign_Info_Type (Kind : Foreign_Kind_Type := Foreign_Unknown) + is record + case Kind is + when Foreign_Unknown => + null; + when Foreign_Vhpidirect => + -- Positions in name_table.name_buffer. + Lib_First : Natural; + Lib_Last : Natural; + Subprg_First : Natural; + Subprg_Last : Natural; + when Foreign_Intrinsic => + null; + end case; + end record; + + Foreign_Bad : constant Foreign_Info_Type := (Kind => Foreign_Unknown); + + -- Return a foreign_info for DECL. + -- Can generate error messages, if the attribute expression is ill-formed. + -- If EXTRACT_NAME is set, internal fields of foreign_info are set. + -- Otherwise, only KIND discriminent is set. + -- EXTRACT_NAME should be set only inside translation itself, since the + -- name can be based on the prefix. + function Translate_Foreign_Id (Decl : Iir) return Foreign_Info_Type; + + -- If not null, this procedure is called when a foreign subprogram is + -- created. + type Foreign_Hook_Access is access procedure (Decl : Iir; + Info : Foreign_Info_Type; + Ortho : Ortho_Nodes.O_Dnode); + Foreign_Hook : Foreign_Hook_Access := null; +end Translation; |