diff options
Diffstat (limited to 'translate')
167 files changed, 0 insertions, 73994 deletions
diff --git a/translate/Makefile b/translate/Makefile deleted file mode 100644 index b331b57..0000000 --- a/translate/Makefile +++ /dev/null @@ -1,45 +0,0 @@ -# -*- 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/translate/gcc/ANNOUNCE b/translate/gcc/ANNOUNCE deleted file mode 100644 index 7b1060e..0000000 --- a/translate/gcc/ANNOUNCE +++ /dev/null @@ -1,21 +0,0 @@ -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/translate/gcc/INSTALL b/translate/gcc/INSTALL deleted file mode 100644 index e710f91..0000000 --- a/translate/gcc/INSTALL +++ /dev/null @@ -1,24 +0,0 @@ -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/translate/gcc/Make-lang.in b/translate/gcc/Make-lang.in deleted file mode 100644 index cde3e6c..0000000 --- a/translate/gcc/Make-lang.in +++ /dev/null @@ -1,190 +0,0 @@ -# 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/translate/gcc/Makefile.in b/translate/gcc/Makefile.in deleted file mode 100644 index 13f3296..0000000 --- a/translate/gcc/Makefile.in +++ /dev/null @@ -1,299 +0,0 @@ -# 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/translate/gcc/README b/translate/gcc/README deleted file mode 100644 index 1152e99..0000000 --- a/translate/gcc/README +++ /dev/null @@ -1,87 +0,0 @@ -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/translate/gcc/config-lang.in b/translate/gcc/config-lang.in deleted file mode 100644 index 7010b11..0000000 --- a/translate/gcc/config-lang.in +++ /dev/null @@ -1,38 +0,0 @@ -# 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/translate/gcc/dist-common.sh b/translate/gcc/dist-common.sh deleted file mode 100644 index ad22297..0000000 --- a/translate/gcc/dist-common.sh +++ /dev/null @@ -1,337 +0,0 @@ -# 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/translate/gcc/dist.sh b/translate/gcc/dist.sh deleted file mode 100755 index 8632dc5..0000000 --- a/translate/gcc/dist.sh +++ /dev/null @@ -1,471 +0,0 @@ -#!/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/translate/gcc/lang-options.h b/translate/gcc/lang-options.h deleted file mode 100644 index c92b121..0000000 --- a/translate/gcc/lang-options.h +++ /dev/null @@ -1,29 +0,0 @@ -/* 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/translate/gcc/lang-specs.h b/translate/gcc/lang-specs.h deleted file mode 100644 index 0504435..0000000 --- a/translate/gcc/lang-specs.h +++ /dev/null @@ -1,28 +0,0 @@ -/* 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/translate/ghdldrv/Makefile b/translate/ghdldrv/Makefile deleted file mode 100644 index ebf23c2..0000000 --- a/translate/ghdldrv/Makefile +++ /dev/null @@ -1,193 +0,0 @@ -# -*- 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/translate/ghdldrv/default_pathes.ads.in b/translate/ghdldrv/default_pathes.ads.in deleted file mode 100644 index 7f471a5..0000000 --- a/translate/ghdldrv/default_pathes.ads.in +++ /dev/null @@ -1,39 +0,0 @@ --- 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/translate/ghdldrv/foreigns.adb b/translate/ghdldrv/foreigns.adb deleted file mode 100644 index 15e3dd0..0000000 --- a/translate/ghdldrv/foreigns.adb +++ /dev/null @@ -1,64 +0,0 @@ -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/translate/ghdldrv/foreigns.ads b/translate/ghdldrv/foreigns.ads deleted file mode 100644 index 5759ae4..0000000 --- a/translate/ghdldrv/foreigns.ads +++ /dev/null @@ -1,5 +0,0 @@ -with System; use System; - -package Foreigns is - function Find_Foreign (Name : String) return Address; -end Foreigns; diff --git a/translate/ghdldrv/ghdl_gcc.adb b/translate/ghdldrv/ghdl_gcc.adb deleted file mode 100644 index 615a8c5..0000000 --- a/translate/ghdldrv/ghdl_gcc.adb +++ /dev/null @@ -1,34 +0,0 @@ --- 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/translate/ghdldrv/ghdl_jit.adb b/translate/ghdldrv/ghdl_jit.adb deleted file mode 100644 index ba70874..0000000 --- a/translate/ghdldrv/ghdl_jit.adb +++ /dev/null @@ -1,35 +0,0 @@ --- 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/translate/ghdldrv/ghdl_simul.adb b/translate/ghdldrv/ghdl_simul.adb deleted file mode 100644 index d4d0abd..0000000 --- a/translate/ghdldrv/ghdl_simul.adb +++ /dev/null @@ -1,33 +0,0 @@ --- 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/translate/ghdldrv/ghdlcomp.adb b/translate/ghdldrv/ghdlcomp.adb deleted file mode 100644 index ba755af..0000000 --- a/translate/ghdldrv/ghdlcomp.adb +++ /dev/null @@ -1,757 +0,0 @@ --- 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/translate/ghdldrv/ghdlcomp.ads b/translate/ghdldrv/ghdlcomp.ads deleted file mode 100644 index f803ca4..0000000 --- a/translate/ghdldrv/ghdlcomp.ads +++ /dev/null @@ -1,67 +0,0 @@ --- 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/translate/ghdldrv/ghdldrv.adb b/translate/ghdldrv/ghdldrv.adb deleted file mode 100644 index be905f1..0000000 --- a/translate/ghdldrv/ghdldrv.adb +++ /dev/null @@ -1,1818 +0,0 @@ --- 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/translate/ghdldrv/ghdldrv.ads b/translate/ghdldrv/ghdldrv.ads deleted file mode 100644 index 3e37b38..0000000 --- a/translate/ghdldrv/ghdldrv.ads +++ /dev/null @@ -1,25 +0,0 @@ --- 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/translate/ghdldrv/ghdllocal.adb b/translate/ghdldrv/ghdllocal.adb deleted file mode 100644 index a1d94bd..0000000 --- a/translate/ghdldrv/ghdllocal.adb +++ /dev/null @@ -1,1415 +0,0 @@ --- 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/translate/ghdldrv/ghdllocal.ads b/translate/ghdldrv/ghdllocal.ads deleted file mode 100644 index 2c7018a..0000000 --- a/translate/ghdldrv/ghdllocal.ads +++ /dev/null @@ -1,116 +0,0 @@ --- 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/translate/ghdldrv/ghdlmain.adb b/translate/ghdldrv/ghdlmain.adb deleted file mode 100644 index 45d9615..0000000 --- a/translate/ghdldrv/ghdlmain.adb +++ /dev/null @@ -1,359 +0,0 @@ --- 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/translate/ghdldrv/ghdlmain.ads b/translate/ghdldrv/ghdlmain.ads deleted file mode 100644 index c01f1d6..0000000 --- a/translate/ghdldrv/ghdlmain.ads +++ /dev/null @@ -1,85 +0,0 @@ --- 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/translate/ghdldrv/ghdlprint.adb b/translate/ghdldrv/ghdlprint.adb deleted file mode 100644 index 45e70e1..0000000 --- a/translate/ghdldrv/ghdlprint.adb +++ /dev/null @@ -1,1757 +0,0 @@ --- 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/translate/ghdldrv/ghdlprint.ads b/translate/ghdldrv/ghdlprint.ads deleted file mode 100644 index 82c3e60..0000000 --- a/translate/ghdldrv/ghdlprint.ads +++ /dev/null @@ -1,20 +0,0 @@ --- 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/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb deleted file mode 100644 index f623721..0000000 --- a/translate/ghdldrv/ghdlrun.adb +++ /dev/null @@ -1,661 +0,0 @@ --- 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/translate/ghdldrv/ghdlrun.ads b/translate/ghdldrv/ghdlrun.ads deleted file mode 100644 index 07095bd..0000000 --- a/translate/ghdldrv/ghdlrun.ads +++ /dev/null @@ -1,20 +0,0 @@ --- 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/translate/ghdldrv/ghdlsimul.adb b/translate/ghdldrv/ghdlsimul.adb deleted file mode 100644 index 17cece7..0000000 --- a/translate/ghdldrv/ghdlsimul.adb +++ /dev/null @@ -1,209 +0,0 @@ --- 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/translate/ghdldrv/ghdlsimul.ads b/translate/ghdldrv/ghdlsimul.ads deleted file mode 100644 index 264cbf8..0000000 --- a/translate/ghdldrv/ghdlsimul.ads +++ /dev/null @@ -1,20 +0,0 @@ --- 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/translate/ghdldrv/grtlink.ads b/translate/ghdldrv/grtlink.ads deleted file mode 100644 index 4b3951e..0000000 --- a/translate/ghdldrv/grtlink.ads +++ /dev/null @@ -1,39 +0,0 @@ --- 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/translate/grt/Makefile b/translate/grt/Makefile deleted file mode 100644 index 107aef7..0000000 --- a/translate/grt/Makefile +++ /dev/null @@ -1,56 +0,0 @@ -# -*- 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/translate/grt/Makefile.inc b/translate/grt/Makefile.inc deleted file mode 100644 index ec1b0df..0000000 --- a/translate/grt/Makefile.inc +++ /dev/null @@ -1,226 +0,0 @@ -# -*- 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/translate/grt/config/Makefile b/translate/grt/config/Makefile deleted file mode 100644 index 7d5f57d..0000000 --- a/translate/grt/config/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -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/translate/grt/config/amd64.S b/translate/grt/config/amd64.S deleted file mode 100644 index 0a7f004..0000000 --- a/translate/grt/config/amd64.S +++ /dev/null @@ -1,131 +0,0 @@ -/* 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/translate/grt/config/chkstk.S b/translate/grt/config/chkstk.S deleted file mode 100644 index ab244d0..0000000 --- a/translate/grt/config/chkstk.S +++ /dev/null @@ -1,53 +0,0 @@ -/* 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/translate/grt/config/clock.c b/translate/grt/config/clock.c deleted file mode 100644 index 242af60..0000000 --- a/translate/grt/config/clock.c +++ /dev/null @@ -1,43 +0,0 @@ -/* 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/translate/grt/config/i386.S b/translate/grt/config/i386.S deleted file mode 100644 index 00d4719..0000000 --- a/translate/grt/config/i386.S +++ /dev/null @@ -1,141 +0,0 @@ -/* 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/translate/grt/config/ia64.S b/translate/grt/config/ia64.S deleted file mode 100644 index 9ce3800..0000000 --- a/translate/grt/config/ia64.S +++ /dev/null @@ -1,331 +0,0 @@ -/* 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/translate/grt/config/linux.c b/translate/grt/config/linux.c deleted file mode 100644 index 74dce09..0000000 --- a/translate/grt/config/linux.c +++ /dev/null @@ -1,361 +0,0 @@ -/* 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/translate/grt/config/ppc.S b/translate/grt/config/ppc.S deleted file mode 100644 index bedd48a..0000000 --- a/translate/grt/config/ppc.S +++ /dev/null @@ -1,334 +0,0 @@ -/* 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/translate/grt/config/pthread.c b/translate/grt/config/pthread.c deleted file mode 100644 index 189ae90..0000000 --- a/translate/grt/config/pthread.c +++ /dev/null @@ -1,239 +0,0 @@ -/* 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/translate/grt/config/sparc.S b/translate/grt/config/sparc.S deleted file mode 100644 index 0ffe412..0000000 --- a/translate/grt/config/sparc.S +++ /dev/null @@ -1,141 +0,0 @@ -/* 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/translate/grt/config/teststack.c b/translate/grt/config/teststack.c deleted file mode 100644 index 6a6966d..0000000 --- a/translate/grt/config/teststack.c +++ /dev/null @@ -1,174 +0,0 @@ -#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/translate/grt/config/times.c b/translate/grt/config/times.c deleted file mode 100644 index 9c0b4eb..0000000 --- a/translate/grt/config/times.c +++ /dev/null @@ -1,55 +0,0 @@ -/* 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/translate/grt/config/win32.c b/translate/grt/config/win32.c deleted file mode 100644 index 35322ba..0000000 --- a/translate/grt/config/win32.c +++ /dev/null @@ -1,265 +0,0 @@ -/* 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/translate/grt/config/win32thr.c b/translate/grt/config/win32thr.c deleted file mode 100644 index bcebc49..0000000 --- a/translate/grt/config/win32thr.c +++ /dev/null @@ -1,167 +0,0 @@ -/* 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/translate/grt/ghdl_main.adb b/translate/grt/ghdl_main.adb deleted file mode 100644 index ce5b67d..0000000 --- a/translate/grt/ghdl_main.adb +++ /dev/null @@ -1,61 +0,0 @@ --- 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/translate/grt/ghdl_main.ads b/translate/grt/ghdl_main.ads deleted file mode 100644 index 88d181a..0000000 --- a/translate/grt/ghdl_main.ads +++ /dev/null @@ -1,33 +0,0 @@ --- 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/translate/grt/ghwdump.c b/translate/grt/ghwdump.c deleted file mode 100644 index 4affc2b..0000000 --- a/translate/grt/ghwdump.c +++ /dev/null @@ -1,195 +0,0 @@ -/* 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/translate/grt/ghwlib.c b/translate/grt/ghwlib.c deleted file mode 100644 index 2db63d9..0000000 --- a/translate/grt/ghwlib.c +++ /dev/null @@ -1,1746 +0,0 @@ -/* 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/translate/grt/ghwlib.h b/translate/grt/ghwlib.h deleted file mode 100644 index 0138267..0000000 --- a/translate/grt/ghwlib.h +++ /dev/null @@ -1,399 +0,0 @@ -/* 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/translate/grt/grt-arch.ads b/translate/grt/grt-arch.ads deleted file mode 100644 index 5f5aa0e..0000000 --- a/translate/grt/grt-arch.ads +++ /dev/null @@ -1,2 +0,0 @@ -With Grt.Arch_None; -Package Grt.Arch renames Grt.Arch_None; diff --git a/translate/grt/grt-arch_none.adb b/translate/grt/grt-arch_none.adb deleted file mode 100644 index 14db1c7..0000000 --- a/translate/grt/grt-arch_none.adb +++ /dev/null @@ -1,7 +0,0 @@ -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/translate/grt/grt-arch_none.ads b/translate/grt/grt-arch_none.ads deleted file mode 100644 index f8ae437..0000000 --- a/translate/grt/grt-arch_none.ads +++ /dev/null @@ -1,6 +0,0 @@ -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/translate/grt/grt-astdio.adb b/translate/grt/grt-astdio.adb deleted file mode 100644 index 456d024..0000000 --- a/translate/grt/grt-astdio.adb +++ /dev/null @@ -1,231 +0,0 @@ --- 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/translate/grt/grt-astdio.ads b/translate/grt/grt-astdio.ads deleted file mode 100644 index 8e8b739..0000000 --- a/translate/grt/grt-astdio.ads +++ /dev/null @@ -1,60 +0,0 @@ --- 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/translate/grt/grt-avhpi.adb b/translate/grt/grt-avhpi.adb deleted file mode 100644 index b935fd9..0000000 --- a/translate/grt/grt-avhpi.adb +++ /dev/null @@ -1,1142 +0,0 @@ --- 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/translate/grt/grt-avhpi.ads b/translate/grt/grt-avhpi.ads deleted file mode 100644 index 1eff5a8..0000000 --- a/translate/grt/grt-avhpi.ads +++ /dev/null @@ -1,561 +0,0 @@ --- 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/translate/grt/grt-avls.adb b/translate/grt/grt-avls.adb deleted file mode 100644 index 7f13ed3..0000000 --- a/translate/grt/grt-avls.adb +++ /dev/null @@ -1,249 +0,0 @@ --- 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/translate/grt/grt-avls.ads b/translate/grt/grt-avls.ads deleted file mode 100644 index 790053c..0000000 --- a/translate/grt/grt-avls.ads +++ /dev/null @@ -1,84 +0,0 @@ --- 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/translate/grt/grt-c.ads b/translate/grt/grt-c.ads deleted file mode 100644 index 24003cf..0000000 --- a/translate/grt/grt-c.ads +++ /dev/null @@ -1,54 +0,0 @@ --- 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/translate/grt/grt-cbinding.c b/translate/grt/grt-cbinding.c deleted file mode 100644 index b95c0f0..0000000 --- a/translate/grt/grt-cbinding.c +++ /dev/null @@ -1,99 +0,0 @@ -/* 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/translate/grt/grt-cvpi.c b/translate/grt/grt-cvpi.c deleted file mode 100644 index 51edd67..0000000 --- a/translate/grt/grt-cvpi.c +++ /dev/null @@ -1,277 +0,0 @@ -/* 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/translate/grt/grt-disp.adb b/translate/grt/grt-disp.adb deleted file mode 100644 index e68b116..0000000 --- a/translate/grt/grt-disp.adb +++ /dev/null @@ -1,227 +0,0 @@ --- 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/translate/grt/grt-disp.ads b/translate/grt/grt-disp.ads deleted file mode 100644 index 6c15b37..0000000 --- a/translate/grt/grt-disp.ads +++ /dev/null @@ -1,46 +0,0 @@ --- 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/translate/grt/grt-disp_rti.adb b/translate/grt/grt-disp_rti.adb deleted file mode 100644 index 08d27da..0000000 --- a/translate/grt/grt-disp_rti.adb +++ /dev/null @@ -1,1080 +0,0 @@ --- 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/translate/grt/grt-disp_rti.ads b/translate/grt/grt-disp_rti.ads deleted file mode 100644 index 6033d20..0000000 --- a/translate/grt/grt-disp_rti.ads +++ /dev/null @@ -1,43 +0,0 @@ --- 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/translate/grt/grt-disp_signals.adb b/translate/grt/grt-disp_signals.adb deleted file mode 100644 index 424d20d..0000000 --- a/translate/grt/grt-disp_signals.adb +++ /dev/null @@ -1,524 +0,0 @@ --- 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/translate/grt/grt-disp_signals.ads b/translate/grt/grt-disp_signals.ads deleted file mode 100644 index 73bd60d..0000000 --- a/translate/grt/grt-disp_signals.ads +++ /dev/null @@ -1,48 +0,0 @@ --- 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/translate/grt/grt-disp_tree.adb b/translate/grt/grt-disp_tree.adb deleted file mode 100644 index 7d58119..0000000 --- a/translate/grt/grt-disp_tree.adb +++ /dev/null @@ -1,461 +0,0 @@ --- 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/translate/grt/grt-disp_tree.ads b/translate/grt/grt-disp_tree.ads deleted file mode 100644 index e3bc983..0000000 --- a/translate/grt/grt-disp_tree.ads +++ /dev/null @@ -1,27 +0,0 @@ --- 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/translate/grt/grt-errors.adb b/translate/grt/grt-errors.adb deleted file mode 100644 index eddea38..0000000 --- a/translate/grt/grt-errors.adb +++ /dev/null @@ -1,253 +0,0 @@ --- 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/translate/grt/grt-errors.ads b/translate/grt/grt-errors.ads deleted file mode 100644 index c797a71..0000000 --- a/translate/grt/grt-errors.ads +++ /dev/null @@ -1,84 +0,0 @@ --- 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/translate/grt/grt-files.adb b/translate/grt/grt-files.adb deleted file mode 100644 index 30d51cf..0000000 --- a/translate/grt/grt-files.adb +++ /dev/null @@ -1,452 +0,0 @@ --- 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/translate/grt/grt-files.ads b/translate/grt/grt-files.ads deleted file mode 100644 index 14f9984..0000000 --- a/translate/grt/grt-files.ads +++ /dev/null @@ -1,123 +0,0 @@ --- 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/translate/grt/grt-hooks.adb b/translate/grt/grt-hooks.adb deleted file mode 100644 index 6a77aaf..0000000 --- a/translate/grt/grt-hooks.adb +++ /dev/null @@ -1,161 +0,0 @@ --- 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/translate/grt/grt-hooks.ads b/translate/grt/grt-hooks.ads deleted file mode 100644 index 20846c7..0000000 --- a/translate/grt/grt-hooks.ads +++ /dev/null @@ -1,70 +0,0 @@ --- 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/translate/grt/grt-images.adb b/translate/grt/grt-images.adb deleted file mode 100644 index 342c98f..0000000 --- a/translate/grt/grt-images.adb +++ /dev/null @@ -1,387 +0,0 @@ --- 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/translate/grt/grt-images.ads b/translate/grt/grt-images.ads deleted file mode 100644 index cd89110..0000000 --- a/translate/grt/grt-images.ads +++ /dev/null @@ -1,110 +0,0 @@ --- 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/translate/grt/grt-lib.adb b/translate/grt/grt-lib.adb deleted file mode 100644 index d2b095c..0000000 --- a/translate/grt/grt-lib.adb +++ /dev/null @@ -1,298 +0,0 @@ --- 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/translate/grt/grt-lib.ads b/translate/grt/grt-lib.ads deleted file mode 100644 index 4dac2c8..0000000 --- a/translate/grt/grt-lib.ads +++ /dev/null @@ -1,127 +0,0 @@ --- 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/translate/grt/grt-main.adb b/translate/grt/grt-main.adb deleted file mode 100644 index 116ea7b..0000000 --- a/translate/grt/grt-main.adb +++ /dev/null @@ -1,190 +0,0 @@ --- 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/translate/grt/grt-main.ads b/translate/grt/grt-main.ads deleted file mode 100644 index 4f78477..0000000 --- a/translate/grt/grt-main.ads +++ /dev/null @@ -1,29 +0,0 @@ --- 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/translate/grt/grt-modules.adb b/translate/grt/grt-modules.adb deleted file mode 100644 index e5304f0..0000000 --- a/translate/grt/grt-modules.adb +++ /dev/null @@ -1,47 +0,0 @@ --- 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/translate/grt/grt-modules.ads b/translate/grt/grt-modules.ads deleted file mode 100644 index 23c7d6e..0000000 --- a/translate/grt/grt-modules.ads +++ /dev/null @@ -1,29 +0,0 @@ --- 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/translate/grt/grt-names.adb b/translate/grt/grt-names.adb deleted file mode 100644 index e7928f7..0000000 --- a/translate/grt/grt-names.adb +++ /dev/null @@ -1,105 +0,0 @@ --- 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/translate/grt/grt-names.ads b/translate/grt/grt-names.ads deleted file mode 100644 index e0c2842..0000000 --- a/translate/grt/grt-names.ads +++ /dev/null @@ -1,42 +0,0 @@ --- 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/translate/grt/grt-options.adb b/translate/grt/grt-options.adb deleted file mode 100644 index df1eb4e..0000000 --- a/translate/grt/grt-options.adb +++ /dev/null @@ -1,507 +0,0 @@ --- 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/translate/grt/grt-options.ads b/translate/grt/grt-options.ads deleted file mode 100644 index 88b1f50..0000000 --- a/translate/grt/grt-options.ads +++ /dev/null @@ -1,154 +0,0 @@ --- 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/translate/grt/grt-processes.adb b/translate/grt/grt-processes.adb deleted file mode 100644 index 64db682..0000000 --- a/translate/grt/grt-processes.adb +++ /dev/null @@ -1,1042 +0,0 @@ --- 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/translate/grt/grt-processes.ads b/translate/grt/grt-processes.ads deleted file mode 100644 index 22326eb..0000000 --- a/translate/grt/grt-processes.ads +++ /dev/null @@ -1,260 +0,0 @@ --- 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/translate/grt/grt-readline.ads b/translate/grt/grt-readline.ads deleted file mode 100644 index 1a30839..0000000 --- a/translate/grt/grt-readline.ads +++ /dev/null @@ -1,30 +0,0 @@ --- 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/translate/grt/grt-rtis.adb b/translate/grt/grt-rtis.adb deleted file mode 100644 index 26d9764..0000000 --- a/translate/grt/grt-rtis.adb +++ /dev/null @@ -1,45 +0,0 @@ --- 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/translate/grt/grt-rtis.ads b/translate/grt/grt-rtis.ads deleted file mode 100644 index 6bb7659..0000000 --- a/translate/grt/grt-rtis.ads +++ /dev/null @@ -1,379 +0,0 @@ --- 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/translate/grt/grt-rtis_addr.adb b/translate/grt/grt-rtis_addr.adb deleted file mode 100644 index 70a0e21..0000000 --- a/translate/grt/grt-rtis_addr.adb +++ /dev/null @@ -1,299 +0,0 @@ --- 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/translate/grt/grt-rtis_addr.ads b/translate/grt/grt-rtis_addr.ads deleted file mode 100644 index 3fa2792..0000000 --- a/translate/grt/grt-rtis_addr.ads +++ /dev/null @@ -1,110 +0,0 @@ --- 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/translate/grt/grt-rtis_binding.ads b/translate/grt/grt-rtis_binding.ads deleted file mode 100644 index 7e90eea..0000000 --- a/translate/grt/grt-rtis_binding.ads +++ /dev/null @@ -1,67 +0,0 @@ --- 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/translate/grt/grt-rtis_types.adb b/translate/grt/grt-rtis_types.adb deleted file mode 100644 index f22a309..0000000 --- a/translate/grt/grt-rtis_types.adb +++ /dev/null @@ -1,118 +0,0 @@ --- 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/translate/grt/grt-rtis_types.ads b/translate/grt/grt-rtis_types.ads deleted file mode 100644 index f64b173..0000000 --- a/translate/grt/grt-rtis_types.ads +++ /dev/null @@ -1,55 +0,0 @@ --- 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/translate/grt/grt-rtis_utils.adb b/translate/grt/grt-rtis_utils.adb deleted file mode 100644 index 0d4328e..0000000 --- a/translate/grt/grt-rtis_utils.adb +++ /dev/null @@ -1,660 +0,0 @@ --- 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/translate/grt/grt-rtis_utils.ads b/translate/grt/grt-rtis_utils.ads deleted file mode 100644 index 10c1a0f..0000000 --- a/translate/grt/grt-rtis_utils.ads +++ /dev/null @@ -1,92 +0,0 @@ --- 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/translate/grt/grt-sdf.adb b/translate/grt/grt-sdf.adb deleted file mode 100644 index 73534e3..0000000 --- a/translate/grt/grt-sdf.adb +++ /dev/null @@ -1,1389 +0,0 @@ --- 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/translate/grt/grt-sdf.ads b/translate/grt/grt-sdf.ads deleted file mode 100644 index fd05b9e..0000000 --- a/translate/grt/grt-sdf.ads +++ /dev/null @@ -1,131 +0,0 @@ --- 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/translate/grt/grt-shadow_ieee.adb b/translate/grt/grt-shadow_ieee.adb deleted file mode 100644 index 32af4be..0000000 --- a/translate/grt/grt-shadow_ieee.adb +++ /dev/null @@ -1,32 +0,0 @@ --- 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/translate/grt/grt-shadow_ieee.ads b/translate/grt/grt-shadow_ieee.ads deleted file mode 100644 index f12b479..0000000 --- a/translate/grt/grt-shadow_ieee.ads +++ /dev/null @@ -1,41 +0,0 @@ --- 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/translate/grt/grt-signals.adb b/translate/grt/grt-signals.adb deleted file mode 100644 index 9698d81..0000000 --- a/translate/grt/grt-signals.adb +++ /dev/null @@ -1,3400 +0,0 @@ --- 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/translate/grt/grt-signals.ads b/translate/grt/grt-signals.ads deleted file mode 100644 index d792f16..0000000 --- a/translate/grt/grt-signals.ads +++ /dev/null @@ -1,919 +0,0 @@ --- 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/translate/grt/grt-stack2.adb b/translate/grt/grt-stack2.adb deleted file mode 100644 index 82341d0..0000000 --- a/translate/grt/grt-stack2.adb +++ /dev/null @@ -1,205 +0,0 @@ --- 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/translate/grt/grt-stack2.ads b/translate/grt/grt-stack2.ads deleted file mode 100644 index b3de6b7..0000000 --- a/translate/grt/grt-stack2.ads +++ /dev/null @@ -1,43 +0,0 @@ --- 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/translate/grt/grt-stacks.adb b/translate/grt/grt-stacks.adb deleted file mode 100644 index adb008d..0000000 --- a/translate/grt/grt-stacks.adb +++ /dev/null @@ -1,43 +0,0 @@ --- 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/translate/grt/grt-stacks.ads b/translate/grt/grt-stacks.ads deleted file mode 100644 index dd94340..0000000 --- a/translate/grt/grt-stacks.ads +++ /dev/null @@ -1,87 +0,0 @@ --- 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/translate/grt/grt-stats.adb b/translate/grt/grt-stats.adb deleted file mode 100644 index 5bc046d..0000000 --- a/translate/grt/grt-stats.adb +++ /dev/null @@ -1,370 +0,0 @@ --- 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/translate/grt/grt-stats.ads b/translate/grt/grt-stats.ads deleted file mode 100644 index 6f60261..0000000 --- a/translate/grt/grt-stats.ads +++ /dev/null @@ -1,54 +0,0 @@ --- 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/translate/grt/grt-std_logic_1164.adb b/translate/grt/grt-std_logic_1164.adb deleted file mode 100644 index 5be308b..0000000 --- a/translate/grt/grt-std_logic_1164.adb +++ /dev/null @@ -1,146 +0,0 @@ --- 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/translate/grt/grt-std_logic_1164.ads b/translate/grt/grt-std_logic_1164.ads deleted file mode 100644 index 4d15695..0000000 --- a/translate/grt/grt-std_logic_1164.ads +++ /dev/null @@ -1,124 +0,0 @@ --- 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/translate/grt/grt-stdio.ads b/translate/grt/grt-stdio.ads deleted file mode 100644 index 229249a..0000000 --- a/translate/grt/grt-stdio.ads +++ /dev/null @@ -1,107 +0,0 @@ --- 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/translate/grt/grt-table.adb b/translate/grt/grt-table.adb deleted file mode 100644 index 36aa999..0000000 --- a/translate/grt/grt-table.adb +++ /dev/null @@ -1,120 +0,0 @@ --- 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/translate/grt/grt-table.ads b/translate/grt/grt-table.ads deleted file mode 100644 index f814eff..0000000 --- a/translate/grt/grt-table.ads +++ /dev/null @@ -1,75 +0,0 @@ --- 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/translate/grt/grt-threads.ads b/translate/grt/grt-threads.ads deleted file mode 100644 index 248f2c4..0000000 --- a/translate/grt/grt-threads.ads +++ /dev/null @@ -1,27 +0,0 @@ --- 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/translate/grt/grt-types.ads b/translate/grt/grt-types.ads deleted file mode 100644 index fed8225..0000000 --- a/translate/grt/grt-types.ads +++ /dev/null @@ -1,327 +0,0 @@ --- 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/translate/grt/grt-unithread.adb b/translate/grt/grt-unithread.adb deleted file mode 100644 index 6acb521..0000000 --- a/translate/grt/grt-unithread.adb +++ /dev/null @@ -1,106 +0,0 @@ --- 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/translate/grt/grt-unithread.ads b/translate/grt/grt-unithread.ads deleted file mode 100644 index b35b7be..0000000 --- a/translate/grt/grt-unithread.ads +++ /dev/null @@ -1,73 +0,0 @@ --- 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/translate/grt/grt-values.adb b/translate/grt/grt-values.adb deleted file mode 100644 index 3d703bc..0000000 --- a/translate/grt/grt-values.adb +++ /dev/null @@ -1,639 +0,0 @@ --- 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/translate/grt/grt-values.ads b/translate/grt/grt-values.ads deleted file mode 100644 index 8df8c3f..0000000 --- a/translate/grt/grt-values.ads +++ /dev/null @@ -1,69 +0,0 @@ --- 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/translate/grt/grt-vcd.adb b/translate/grt/grt-vcd.adb deleted file mode 100644 index d4a9ea0..0000000 --- a/translate/grt/grt-vcd.adb +++ /dev/null @@ -1,845 +0,0 @@ --- 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/translate/grt/grt-vcd.ads b/translate/grt/grt-vcd.ads deleted file mode 100644 index ed015af..0000000 --- a/translate/grt/grt-vcd.ads +++ /dev/null @@ -1,65 +0,0 @@ --- 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/translate/grt/grt-vcdz.adb b/translate/grt/grt-vcdz.adb deleted file mode 100644 index 8e1ceb6..0000000 --- a/translate/grt/grt-vcdz.adb +++ /dev/null @@ -1,116 +0,0 @@ --- 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/translate/grt/grt-vcdz.ads b/translate/grt/grt-vcdz.ads deleted file mode 100644 index aba61c2..0000000 --- a/translate/grt/grt-vcdz.ads +++ /dev/null @@ -1,28 +0,0 @@ --- 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/translate/grt/grt-vital_annotate.adb b/translate/grt/grt-vital_annotate.adb deleted file mode 100644 index 93ecb81..0000000 --- a/translate/grt/grt-vital_annotate.adb +++ /dev/null @@ -1,688 +0,0 @@ --- 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/translate/grt/grt-vital_annotate.ads b/translate/grt/grt-vital_annotate.ads deleted file mode 100644 index acf82bb..0000000 --- a/translate/grt/grt-vital_annotate.ads +++ /dev/null @@ -1,42 +0,0 @@ --- 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/translate/grt/grt-vpi.adb b/translate/grt/grt-vpi.adb deleted file mode 100644 index 9b77319..0000000 --- a/translate/grt/grt-vpi.adb +++ /dev/null @@ -1,988 +0,0 @@ --- 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/translate/grt/grt-vpi.ads b/translate/grt/grt-vpi.ads deleted file mode 100644 index 86fb073..0000000 --- a/translate/grt/grt-vpi.ads +++ /dev/null @@ -1,252 +0,0 @@ --- 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/translate/grt/grt-vstrings.adb b/translate/grt/grt-vstrings.adb deleted file mode 100644 index 30c58ab..0000000 --- a/translate/grt/grt-vstrings.adb +++ /dev/null @@ -1,422 +0,0 @@ --- 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/translate/grt/grt-vstrings.ads b/translate/grt/grt-vstrings.ads deleted file mode 100644 index 94967bb..0000000 --- a/translate/grt/grt-vstrings.ads +++ /dev/null @@ -1,143 +0,0 @@ --- 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/translate/grt/grt-waves.adb b/translate/grt/grt-waves.adb deleted file mode 100644 index 63bdb9a..0000000 --- a/translate/grt/grt-waves.adb +++ /dev/null @@ -1,1632 +0,0 @@ --- 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/translate/grt/grt-waves.ads b/translate/grt/grt-waves.ads deleted file mode 100644 index 72d7ea6..0000000 --- a/translate/grt/grt-waves.ads +++ /dev/null @@ -1,27 +0,0 @@ --- 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/translate/grt/grt-zlib.ads b/translate/grt/grt-zlib.ads deleted file mode 100644 index 9dfee36..0000000 --- a/translate/grt/grt-zlib.ads +++ /dev/null @@ -1,47 +0,0 @@ --- 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/translate/grt/grt.adc b/translate/grt/grt.adc deleted file mode 100644 index f228499..0000000 --- a/translate/grt/grt.adc +++ /dev/null @@ -1,46 +0,0 @@ --- 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/translate/grt/grt.ads b/translate/grt/grt.ads deleted file mode 100644 index 9727d04..0000000 --- a/translate/grt/grt.ads +++ /dev/null @@ -1,27 +0,0 @@ --- 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/translate/grt/grt.ver b/translate/grt/grt.ver deleted file mode 100644 index 031c207..0000000 --- a/translate/grt/grt.ver +++ /dev/null @@ -1,25 +0,0 @@ -{ - 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/translate/grt/main.adb b/translate/grt/main.adb deleted file mode 100644 index 5de3794..0000000 --- a/translate/grt/main.adb +++ /dev/null @@ -1,32 +0,0 @@ --- 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/translate/grt/main.ads b/translate/grt/main.ads deleted file mode 100644 index f7c4142..0000000 --- a/translate/grt/main.ads +++ /dev/null @@ -1,34 +0,0 @@ --- 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/translate/mcode/Makefile.in b/translate/mcode/Makefile.in deleted file mode 100644 index beb450a..0000000 --- a/translate/mcode/Makefile.in +++ /dev/null @@ -1,54 +0,0 @@ -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/translate/mcode/README b/translate/mcode/README deleted file mode 100644 index a10cd6e..0000000 --- a/translate/mcode/README +++ /dev/null @@ -1,47 +0,0 @@ -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/translate/mcode/dist.sh b/translate/mcode/dist.sh deleted file mode 100755 index cf24141..0000000 --- a/translate/mcode/dist.sh +++ /dev/null @@ -1,506 +0,0 @@ -#!/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/translate/mcode/winbuild.bat b/translate/mcode/winbuild.bat deleted file mode 100644 index 8c28268..0000000 --- a/translate/mcode/winbuild.bat +++ /dev/null @@ -1,18 +0,0 @@ -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/translate/mcode/windows/compile.bat b/translate/mcode/windows/compile.bat deleted file mode 100644 index c668ef0..0000000 --- a/translate/mcode/windows/compile.bat +++ /dev/null @@ -1,24 +0,0 @@ -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/translate/mcode/windows/complib.bat b/translate/mcode/windows/complib.bat deleted file mode 100644 index 88a43ce..0000000 --- a/translate/mcode/windows/complib.bat +++ /dev/null @@ -1,68 +0,0 @@ -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/translate/mcode/windows/default_pathes.ads b/translate/mcode/windows/default_pathes.ads deleted file mode 100644 index 51b350f..0000000 --- a/translate/mcode/windows/default_pathes.ads +++ /dev/null @@ -1,8 +0,0 @@ -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/translate/mcode/windows/ghdl.nsi b/translate/mcode/windows/ghdl.nsi deleted file mode 100644 index aa4d559..0000000 --- a/translate/mcode/windows/ghdl.nsi +++ /dev/null @@ -1,455 +0,0 @@ -; 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/translate/mcode/windows/ghdlfilter.adb b/translate/mcode/windows/ghdlfilter.adb deleted file mode 100644 index d37c2db..0000000 --- a/translate/mcode/windows/ghdlfilter.adb +++ /dev/null @@ -1,58 +0,0 @@ -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/translate/mcode/windows/ghdlversion.adb b/translate/mcode/windows/ghdlversion.adb deleted file mode 100755 index d2f1c28..0000000 --- a/translate/mcode/windows/ghdlversion.adb +++ /dev/null @@ -1,30 +0,0 @@ -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/translate/mcode/windows/grt-modules.adb b/translate/mcode/windows/grt-modules.adb deleted file mode 100644 index 35b27c3..0000000 --- a/translate/mcode/windows/grt-modules.adb +++ /dev/null @@ -1,37 +0,0 @@ --- 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/translate/mcode/windows/ortho_code-x86-flags.ads b/translate/mcode/windows/ortho_code-x86-flags.ads deleted file mode 100644 index 8915f31..0000000 --- a/translate/mcode/windows/ortho_code-x86-flags.ads +++ /dev/null @@ -1,2 +0,0 @@ -with Ortho_Code.X86.Flags_Windows; -package Ortho_Code.X86.Flags renames Ortho_Code.X86.Flags_Windows; diff --git a/translate/mcode/windows/windows_default_path.adb b/translate/mcode/windows/windows_default_path.adb deleted file mode 100644 index 23aa2f6..0000000 --- a/translate/mcode/windows/windows_default_path.adb +++ /dev/null @@ -1,45 +0,0 @@ -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/translate/mcode/windows/windows_default_path.ads b/translate/mcode/windows/windows_default_path.ads deleted file mode 100644 index 8e63034..0000000 --- a/translate/mcode/windows/windows_default_path.ads +++ /dev/null @@ -1,5 +0,0 @@ -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/translate/ortho_front.adb b/translate/ortho_front.adb deleted file mode 100644 index 56c7e61..0000000 --- a/translate/ortho_front.adb +++ /dev/null @@ -1,445 +0,0 @@ --- 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/translate/trans_analyzes.adb b/translate/trans_analyzes.adb deleted file mode 100644 index 8147e93..0000000 --- a/translate/trans_analyzes.adb +++ /dev/null @@ -1,182 +0,0 @@ --- 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/translate/trans_analyzes.ads b/translate/trans_analyzes.ads deleted file mode 100644 index ecebb75..0000000 --- a/translate/trans_analyzes.ads +++ /dev/null @@ -1,31 +0,0 @@ --- 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/translate/trans_be.adb b/translate/trans_be.adb deleted file mode 100644 index dd1b6c3..0000000 --- a/translate/trans_be.adb +++ /dev/null @@ -1,182 +0,0 @@ --- 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/translate/trans_be.ads b/translate/trans_be.ads deleted file mode 100644 index 9ff0603..0000000 --- a/translate/trans_be.ads +++ /dev/null @@ -1,21 +0,0 @@ --- 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/translate/trans_decls.ads b/translate/trans_decls.ads deleted file mode 100644 index e104c71..0000000 --- a/translate/trans_decls.ads +++ /dev/null @@ -1,257 +0,0 @@ --- 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/translate/translation.adb b/translate/translation.adb deleted file mode 100644 index 7c5fbe8..0000000 --- a/translate/translation.adb +++ /dev/null @@ -1,31355 +0,0 @@ --- 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/translate/translation.ads b/translate/translation.ads deleted file mode 100644 index e779685..0000000 --- a/translate/translation.ads +++ /dev/null @@ -1,120 +0,0 @@ --- 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; |