diff options
author | Tristan Gingold <tgingold@free.fr> | 2014-11-04 20:14:19 +0100 |
---|---|---|
committer | Tristan Gingold <tgingold@free.fr> | 2014-11-04 20:14:19 +0100 |
commit | 9c195bf5d86d67ea5eb419ccf6e48dc153e57c68 (patch) | |
tree | 575346e529b99e26382b4a06f6ff2caa0b391ab2 /translate/grt | |
parent | 184a123f91e07c927292d67462561dc84f3a920d (diff) | |
download | ghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.tar.gz ghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.tar.bz2 ghdl-9c195bf5d86d67ea5eb419ccf6e48dc153e57c68.zip |
Move sources to src/ subdirectory.
Diffstat (limited to 'translate/grt')
112 files changed, 0 insertions, 30704 deletions
diff --git a/translate/grt/Makefile b/translate/grt/Makefile deleted file mode 100644 index 107aef7bf..000000000 --- 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 ec1b0df09..000000000 --- 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 7d5f57def..000000000 --- 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 0a7f0044b..000000000 --- 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 ab244d0cd..000000000 --- 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 242af604b..000000000 --- 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 00d4719ac..000000000 --- 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 9ce3800bb..000000000 --- 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 74dce0903..000000000 --- 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 bedd48ab4..000000000 --- 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 189ae90c8..000000000 --- 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 0ffe412ed..000000000 --- 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 6a6966d6f..000000000 --- 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 9c0b4ebba..000000000 --- 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 35322ba9f..000000000 --- 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 bcebc49d5..000000000 --- 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 ce5b67d7e..000000000 --- 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 88d181a0a..000000000 --- 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 4affc2b5c..000000000 --- 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 2db63d9c9..000000000 --- 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 0138267ed..000000000 --- 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 5f5aa0e4c..000000000 --- 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 14db1c7d5..000000000 --- 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 f8ae437d6..000000000 --- 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 456d024ac..000000000 --- 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 8e8b739cc..000000000 --- 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 b935fd9a3..000000000 --- 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 1eff5a8a3..000000000 --- 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 7f13ed39a..000000000 --- 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 790053c6f..000000000 --- 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 24003cf4a..000000000 --- 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 b95c0f0a9..000000000 --- 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 51edd678f..000000000 --- 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 e68b1168b..000000000 --- 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 6c15b37c9..000000000 --- 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 08d27dacb..000000000 --- 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 6033d2011..000000000 --- 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 424d20dcf..000000000 --- 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 73bd60d06..000000000 --- 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 7d5811960..000000000 --- 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 e3bc983a7..000000000 --- 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 eddea38c1..000000000 --- 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 c797a71bd..000000000 --- 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 30d51cf43..000000000 --- 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 14f998468..000000000 --- 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 6a77aaf01..000000000 --- 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 20846c7f8..000000000 --- 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 342c98f2a..000000000 --- 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 cd8911091..000000000 --- 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 d2b095c67..000000000 --- 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 4dac2c8d2..000000000 --- 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 116ea7b2e..000000000 --- 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 4f78477f2..000000000 --- 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 e5304f04d..000000000 --- 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 23c7d6e7a..000000000 --- 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 e7928f75c..000000000 --- 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 e0c284231..000000000 --- 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 df1eb4ec8..000000000 --- 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 88b1f5084..000000000 --- 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 64db682e2..000000000 --- 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 22326eb5e..000000000 --- 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 1a3083981..000000000 --- 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 26d976459..000000000 --- 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 6bb76597e..000000000 --- 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 70a0e2118..000000000 --- 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 3fa2792af..000000000 --- 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 7e90eeafc..000000000 --- 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 f22a309bc..000000000 --- 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 f64b17324..000000000 --- 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 0d4328e7e..000000000 --- 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 10c1a0f28..000000000 --- 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 73534e3eb..000000000 --- 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 fd05b9e20..000000000 --- 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 32af4be5d..000000000 --- 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 f12b4792f..000000000 --- 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 9698d8178..000000000 --- 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 d792f1634..000000000 --- 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 82341d072..000000000 --- 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 b3de6b76d..000000000 --- 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 adb008d02..000000000 --- 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 dd9434080..000000000 --- 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 5bc046d00..000000000 --- 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 6f60261af..000000000 --- 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 5be308bd6..000000000 --- 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 4d1569553..000000000 --- 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 229249ac9..000000000 --- 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 36aa99982..000000000 --- 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 f814eff5c..000000000 --- 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 248f2c41b..000000000 --- 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 fed822554..000000000 --- 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 6acb52169..000000000 --- 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 b35b7be33..000000000 --- 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 3d703bc85..000000000 --- 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 8df8c3f63..000000000 --- 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 d4a9ea066..000000000 --- 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 ed015af80..000000000 --- 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 8e1ceb6f1..000000000 --- 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 aba61c222..000000000 --- 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 93ecb8119..000000000 --- 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 acf82bba2..000000000 --- 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 9b77319f1..000000000 --- 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 86fb07374..000000000 --- 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 30c58ab41..000000000 --- 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 94967bb0f..000000000 --- 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 63bdb9a54..000000000 --- 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 72d7ea6e1..000000000 --- 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 9dfee3665..000000000 --- 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 f2284997d..000000000 --- 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 9727d0430..000000000 --- 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 031c20761..000000000 --- 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 5de379449..000000000 --- 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 f7c414274..000000000 --- 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"); |