From 3fddf1c59fd7a8fcd260bb9e05c611bef3dd141b Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Wed, 5 Nov 2014 05:11:00 +0100 Subject: Move files and dirs from translate/ --- src/ghdldrv/Makefile | 193 ++ src/ghdldrv/default_pathes.ads.in | 39 + src/ghdldrv/foreigns.adb | 64 + src/ghdldrv/foreigns.ads | 5 + src/ghdldrv/ghdl_gcc.adb | 34 + src/ghdldrv/ghdl_jit.adb | 35 + src/ghdldrv/ghdl_simul.adb | 33 + src/ghdldrv/ghdlcomp.adb | 757 +++++ src/ghdldrv/ghdlcomp.ads | 67 + src/ghdldrv/ghdldrv.adb | 1818 +++++++++++ src/ghdldrv/ghdldrv.ads | 25 + src/ghdldrv/ghdllocal.adb | 1415 ++++++++ src/ghdldrv/ghdllocal.ads | 116 + src/ghdldrv/ghdlmain.adb | 359 +++ src/ghdldrv/ghdlmain.ads | 85 + src/ghdldrv/ghdlprint.adb | 1757 ++++++++++ src/ghdldrv/ghdlprint.ads | 20 + src/ghdldrv/ghdlrun.adb | 661 ++++ src/ghdldrv/ghdlrun.ads | 20 + src/ghdldrv/ghdlsimul.adb | 209 ++ src/ghdldrv/ghdlsimul.ads | 20 + src/ghdldrv/grtlink.ads | 39 + src/grt/Makefile | 56 + src/grt/Makefile.inc | 226 ++ src/grt/config/Makefile | 14 + src/grt/config/amd64.S | 131 + src/grt/config/chkstk.S | 53 + src/grt/config/clock.c | 43 + src/grt/config/i386.S | 141 + src/grt/config/ia64.S | 331 ++ src/grt/config/linux.c | 361 +++ src/grt/config/ppc.S | 334 ++ src/grt/config/pthread.c | 239 ++ src/grt/config/sparc.S | 141 + src/grt/config/teststack.c | 174 + src/grt/config/times.c | 55 + src/grt/config/win32.c | 265 ++ src/grt/config/win32thr.c | 167 + src/grt/ghdl_main.adb | 61 + src/grt/ghdl_main.ads | 33 + src/grt/ghwdump.c | 195 ++ src/grt/ghwlib.c | 1746 ++++++++++ src/grt/ghwlib.h | 399 +++ src/grt/grt-arch.ads | 2 + src/grt/grt-arch_none.adb | 7 + src/grt/grt-arch_none.ads | 6 + src/grt/grt-astdio.adb | 231 ++ src/grt/grt-astdio.ads | 60 + src/grt/grt-avhpi.adb | 1142 +++++++ src/grt/grt-avhpi.ads | 561 ++++ src/grt/grt-avls.adb | 249 ++ src/grt/grt-avls.ads | 84 + src/grt/grt-c.ads | 54 + src/grt/grt-cbinding.c | 99 + src/grt/grt-cvpi.c | 277 ++ src/grt/grt-disp.adb | 227 ++ src/grt/grt-disp.ads | 46 + src/grt/grt-disp_rti.adb | 1080 +++++++ src/grt/grt-disp_rti.ads | 43 + src/grt/grt-disp_signals.adb | 524 +++ src/grt/grt-disp_signals.ads | 48 + src/grt/grt-disp_tree.adb | 461 +++ src/grt/grt-disp_tree.ads | 27 + src/grt/grt-errors.adb | 253 ++ src/grt/grt-errors.ads | 84 + src/grt/grt-files.adb | 452 +++ src/grt/grt-files.ads | 123 + src/grt/grt-hooks.adb | 161 + src/grt/grt-hooks.ads | 70 + src/grt/grt-images.adb | 387 +++ src/grt/grt-images.ads | 110 + src/grt/grt-lib.adb | 298 ++ src/grt/grt-lib.ads | 127 + src/grt/grt-main.adb | 190 ++ src/grt/grt-main.ads | 29 + src/grt/grt-modules.adb | 47 + src/grt/grt-modules.ads | 29 + src/grt/grt-names.adb | 105 + src/grt/grt-names.ads | 42 + src/grt/grt-options.adb | 507 +++ src/grt/grt-options.ads | 154 + src/grt/grt-processes.adb | 1042 ++++++ src/grt/grt-processes.ads | 260 ++ src/grt/grt-readline.ads | 30 + src/grt/grt-rtis.adb | 45 + src/grt/grt-rtis.ads | 379 +++ src/grt/grt-rtis_addr.adb | 299 ++ src/grt/grt-rtis_addr.ads | 110 + src/grt/grt-rtis_binding.ads | 67 + src/grt/grt-rtis_types.adb | 118 + src/grt/grt-rtis_types.ads | 55 + src/grt/grt-rtis_utils.adb | 660 ++++ src/grt/grt-rtis_utils.ads | 92 + src/grt/grt-sdf.adb | 1389 ++++++++ src/grt/grt-sdf.ads | 131 + src/grt/grt-shadow_ieee.adb | 32 + src/grt/grt-shadow_ieee.ads | 41 + src/grt/grt-signals.adb | 3400 ++++++++++++++++++++ src/grt/grt-signals.ads | 919 ++++++ src/grt/grt-stack2.adb | 205 ++ src/grt/grt-stack2.ads | 43 + src/grt/grt-stacks.adb | 43 + src/grt/grt-stacks.ads | 87 + src/grt/grt-stats.adb | 370 +++ src/grt/grt-stats.ads | 54 + src/grt/grt-std_logic_1164.adb | 146 + src/grt/grt-std_logic_1164.ads | 124 + src/grt/grt-stdio.ads | 107 + src/grt/grt-table.adb | 120 + src/grt/grt-table.ads | 75 + src/grt/grt-threads.ads | 27 + src/grt/grt-types.ads | 327 ++ src/grt/grt-unithread.adb | 106 + src/grt/grt-unithread.ads | 73 + src/grt/grt-values.adb | 639 ++++ src/grt/grt-values.ads | 69 + src/grt/grt-vcd.adb | 845 +++++ src/grt/grt-vcd.ads | 65 + src/grt/grt-vcdz.adb | 116 + src/grt/grt-vcdz.ads | 28 + src/grt/grt-vital_annotate.adb | 688 ++++ src/grt/grt-vital_annotate.ads | 42 + src/grt/grt-vpi.adb | 988 ++++++ src/grt/grt-vpi.ads | 252 ++ src/grt/grt-vstrings.adb | 422 +++ src/grt/grt-vstrings.ads | 143 + src/grt/grt-waves.adb | 1632 ++++++++++ src/grt/grt-waves.ads | 27 + src/grt/grt-zlib.ads | 47 + src/grt/grt.adc | 46 + src/grt/grt.ads | 27 + src/grt/grt.ver | 25 + src/grt/main.adb | 32 + src/grt/main.ads | 34 + src/translate/gcc/ANNOUNCE | 21 - src/translate/gcc/INSTALL | 24 - src/translate/gcc/Make-lang.in | 190 -- src/translate/gcc/Makefile.in | 299 -- src/translate/gcc/README | 87 - src/translate/gcc/config-lang.in | 38 - src/translate/gcc/dist-common.sh | 337 -- src/translate/gcc/dist.sh | 471 --- src/translate/gcc/lang-options.h | 29 - src/translate/gcc/lang-specs.h | 28 - src/translate/ghdldrv/Makefile | 193 -- src/translate/ghdldrv/default_pathes.ads.in | 39 - src/translate/ghdldrv/foreigns.adb | 64 - src/translate/ghdldrv/foreigns.ads | 5 - src/translate/ghdldrv/ghdl_gcc.adb | 34 - src/translate/ghdldrv/ghdl_jit.adb | 35 - src/translate/ghdldrv/ghdl_simul.adb | 33 - src/translate/ghdldrv/ghdlcomp.adb | 757 ----- src/translate/ghdldrv/ghdlcomp.ads | 67 - src/translate/ghdldrv/ghdldrv.adb | 1818 ----------- src/translate/ghdldrv/ghdldrv.ads | 25 - src/translate/ghdldrv/ghdllocal.adb | 1415 -------- src/translate/ghdldrv/ghdllocal.ads | 116 - src/translate/ghdldrv/ghdlmain.adb | 359 --- src/translate/ghdldrv/ghdlmain.ads | 85 - src/translate/ghdldrv/ghdlprint.adb | 1757 ---------- src/translate/ghdldrv/ghdlprint.ads | 20 - src/translate/ghdldrv/ghdlrun.adb | 661 ---- src/translate/ghdldrv/ghdlrun.ads | 20 - src/translate/ghdldrv/ghdlsimul.adb | 209 -- src/translate/ghdldrv/ghdlsimul.ads | 20 - src/translate/ghdldrv/grtlink.ads | 39 - src/translate/grt/Makefile | 56 - src/translate/grt/Makefile.inc | 226 -- src/translate/grt/config/Makefile | 14 - src/translate/grt/config/amd64.S | 131 - src/translate/grt/config/chkstk.S | 53 - src/translate/grt/config/clock.c | 43 - src/translate/grt/config/i386.S | 141 - src/translate/grt/config/ia64.S | 331 -- src/translate/grt/config/linux.c | 361 --- src/translate/grt/config/ppc.S | 334 -- src/translate/grt/config/pthread.c | 239 -- src/translate/grt/config/sparc.S | 141 - src/translate/grt/config/teststack.c | 174 - src/translate/grt/config/times.c | 55 - src/translate/grt/config/win32.c | 265 -- src/translate/grt/config/win32thr.c | 167 - src/translate/grt/ghdl_main.adb | 61 - src/translate/grt/ghdl_main.ads | 33 - src/translate/grt/ghwdump.c | 195 -- src/translate/grt/ghwlib.c | 1746 ---------- src/translate/grt/ghwlib.h | 399 --- src/translate/grt/grt-arch.ads | 2 - src/translate/grt/grt-arch_none.adb | 7 - src/translate/grt/grt-arch_none.ads | 6 - src/translate/grt/grt-astdio.adb | 231 -- src/translate/grt/grt-astdio.ads | 60 - src/translate/grt/grt-avhpi.adb | 1142 ------- src/translate/grt/grt-avhpi.ads | 561 ---- src/translate/grt/grt-avls.adb | 249 -- src/translate/grt/grt-avls.ads | 84 - src/translate/grt/grt-c.ads | 54 - src/translate/grt/grt-cbinding.c | 99 - src/translate/grt/grt-cvpi.c | 277 -- src/translate/grt/grt-disp.adb | 227 -- src/translate/grt/grt-disp.ads | 46 - src/translate/grt/grt-disp_rti.adb | 1080 ------- src/translate/grt/grt-disp_rti.ads | 43 - src/translate/grt/grt-disp_signals.adb | 524 --- src/translate/grt/grt-disp_signals.ads | 48 - src/translate/grt/grt-disp_tree.adb | 461 --- src/translate/grt/grt-disp_tree.ads | 27 - src/translate/grt/grt-errors.adb | 253 -- src/translate/grt/grt-errors.ads | 84 - src/translate/grt/grt-files.adb | 452 --- src/translate/grt/grt-files.ads | 123 - src/translate/grt/grt-hooks.adb | 161 - src/translate/grt/grt-hooks.ads | 70 - src/translate/grt/grt-images.adb | 387 --- src/translate/grt/grt-images.ads | 110 - src/translate/grt/grt-lib.adb | 298 -- src/translate/grt/grt-lib.ads | 127 - src/translate/grt/grt-main.adb | 190 -- src/translate/grt/grt-main.ads | 29 - src/translate/grt/grt-modules.adb | 47 - src/translate/grt/grt-modules.ads | 29 - src/translate/grt/grt-names.adb | 105 - src/translate/grt/grt-names.ads | 42 - src/translate/grt/grt-options.adb | 507 --- src/translate/grt/grt-options.ads | 154 - src/translate/grt/grt-processes.adb | 1042 ------ src/translate/grt/grt-processes.ads | 260 -- src/translate/grt/grt-readline.ads | 30 - src/translate/grt/grt-rtis.adb | 45 - src/translate/grt/grt-rtis.ads | 379 --- src/translate/grt/grt-rtis_addr.adb | 299 -- src/translate/grt/grt-rtis_addr.ads | 110 - src/translate/grt/grt-rtis_binding.ads | 67 - src/translate/grt/grt-rtis_types.adb | 118 - src/translate/grt/grt-rtis_types.ads | 55 - src/translate/grt/grt-rtis_utils.adb | 660 ---- src/translate/grt/grt-rtis_utils.ads | 92 - src/translate/grt/grt-sdf.adb | 1389 -------- src/translate/grt/grt-sdf.ads | 131 - src/translate/grt/grt-shadow_ieee.adb | 32 - src/translate/grt/grt-shadow_ieee.ads | 41 - src/translate/grt/grt-signals.adb | 3400 -------------------- src/translate/grt/grt-signals.ads | 919 ------ src/translate/grt/grt-stack2.adb | 205 -- src/translate/grt/grt-stack2.ads | 43 - src/translate/grt/grt-stacks.adb | 43 - src/translate/grt/grt-stacks.ads | 87 - src/translate/grt/grt-stats.adb | 370 --- src/translate/grt/grt-stats.ads | 54 - src/translate/grt/grt-std_logic_1164.adb | 146 - src/translate/grt/grt-std_logic_1164.ads | 124 - src/translate/grt/grt-stdio.ads | 107 - src/translate/grt/grt-table.adb | 120 - src/translate/grt/grt-table.ads | 75 - src/translate/grt/grt-threads.ads | 27 - src/translate/grt/grt-types.ads | 327 -- src/translate/grt/grt-unithread.adb | 106 - src/translate/grt/grt-unithread.ads | 73 - src/translate/grt/grt-values.adb | 639 ---- src/translate/grt/grt-values.ads | 69 - src/translate/grt/grt-vcd.adb | 845 ----- src/translate/grt/grt-vcd.ads | 65 - src/translate/grt/grt-vcdz.adb | 116 - src/translate/grt/grt-vcdz.ads | 28 - src/translate/grt/grt-vital_annotate.adb | 688 ---- src/translate/grt/grt-vital_annotate.ads | 42 - src/translate/grt/grt-vpi.adb | 988 ------ src/translate/grt/grt-vpi.ads | 252 -- src/translate/grt/grt-vstrings.adb | 422 --- src/translate/grt/grt-vstrings.ads | 143 - src/translate/grt/grt-waves.adb | 1632 ---------- src/translate/grt/grt-waves.ads | 27 - src/translate/grt/grt-zlib.ads | 47 - src/translate/grt/grt.adc | 46 - src/translate/grt/grt.ads | 27 - src/translate/grt/grt.ver | 25 - src/translate/grt/main.adb | 32 - src/translate/grt/main.ads | 34 - src/translate/mcode/Makefile.in | 54 - src/translate/mcode/README | 47 - src/translate/mcode/dist.sh | 506 --- src/translate/mcode/winbuild.bat | 18 - src/translate/mcode/windows/compile.bat | 24 - src/translate/mcode/windows/complib.bat | 68 - src/translate/mcode/windows/default_pathes.ads | 8 - src/translate/mcode/windows/ghdl.nsi | 455 --- src/translate/mcode/windows/ghdlfilter.adb | 58 - src/translate/mcode/windows/ghdlversion.adb | 30 - src/translate/mcode/windows/grt-modules.adb | 37 - .../mcode/windows/ortho_code-x86-flags.ads | 2 - .../mcode/windows/windows_default_path.adb | 45 - .../mcode/windows/windows_default_path.ads | 5 - 292 files changed, 38475 insertions(+), 41356 deletions(-) create mode 100644 src/ghdldrv/Makefile create mode 100644 src/ghdldrv/default_pathes.ads.in create mode 100644 src/ghdldrv/foreigns.adb create mode 100644 src/ghdldrv/foreigns.ads create mode 100644 src/ghdldrv/ghdl_gcc.adb create mode 100644 src/ghdldrv/ghdl_jit.adb create mode 100644 src/ghdldrv/ghdl_simul.adb create mode 100644 src/ghdldrv/ghdlcomp.adb create mode 100644 src/ghdldrv/ghdlcomp.ads create mode 100644 src/ghdldrv/ghdldrv.adb create mode 100644 src/ghdldrv/ghdldrv.ads create mode 100644 src/ghdldrv/ghdllocal.adb create mode 100644 src/ghdldrv/ghdllocal.ads create mode 100644 src/ghdldrv/ghdlmain.adb create mode 100644 src/ghdldrv/ghdlmain.ads create mode 100644 src/ghdldrv/ghdlprint.adb create mode 100644 src/ghdldrv/ghdlprint.ads create mode 100644 src/ghdldrv/ghdlrun.adb create mode 100644 src/ghdldrv/ghdlrun.ads create mode 100644 src/ghdldrv/ghdlsimul.adb create mode 100644 src/ghdldrv/ghdlsimul.ads create mode 100644 src/ghdldrv/grtlink.ads create mode 100644 src/grt/Makefile create mode 100644 src/grt/Makefile.inc create mode 100644 src/grt/config/Makefile create mode 100644 src/grt/config/amd64.S create mode 100644 src/grt/config/chkstk.S create mode 100644 src/grt/config/clock.c create mode 100644 src/grt/config/i386.S create mode 100644 src/grt/config/ia64.S create mode 100644 src/grt/config/linux.c create mode 100644 src/grt/config/ppc.S create mode 100644 src/grt/config/pthread.c create mode 100644 src/grt/config/sparc.S create mode 100644 src/grt/config/teststack.c create mode 100644 src/grt/config/times.c create mode 100644 src/grt/config/win32.c create mode 100644 src/grt/config/win32thr.c create mode 100644 src/grt/ghdl_main.adb create mode 100644 src/grt/ghdl_main.ads create mode 100644 src/grt/ghwdump.c create mode 100644 src/grt/ghwlib.c create mode 100644 src/grt/ghwlib.h create mode 100644 src/grt/grt-arch.ads create mode 100644 src/grt/grt-arch_none.adb create mode 100644 src/grt/grt-arch_none.ads create mode 100644 src/grt/grt-astdio.adb create mode 100644 src/grt/grt-astdio.ads create mode 100644 src/grt/grt-avhpi.adb create mode 100644 src/grt/grt-avhpi.ads create mode 100644 src/grt/grt-avls.adb create mode 100644 src/grt/grt-avls.ads create mode 100644 src/grt/grt-c.ads create mode 100644 src/grt/grt-cbinding.c create mode 100644 src/grt/grt-cvpi.c create mode 100644 src/grt/grt-disp.adb create mode 100644 src/grt/grt-disp.ads create mode 100644 src/grt/grt-disp_rti.adb create mode 100644 src/grt/grt-disp_rti.ads create mode 100644 src/grt/grt-disp_signals.adb create mode 100644 src/grt/grt-disp_signals.ads create mode 100644 src/grt/grt-disp_tree.adb create mode 100644 src/grt/grt-disp_tree.ads create mode 100644 src/grt/grt-errors.adb create mode 100644 src/grt/grt-errors.ads create mode 100644 src/grt/grt-files.adb create mode 100644 src/grt/grt-files.ads create mode 100644 src/grt/grt-hooks.adb create mode 100644 src/grt/grt-hooks.ads create mode 100644 src/grt/grt-images.adb create mode 100644 src/grt/grt-images.ads create mode 100644 src/grt/grt-lib.adb create mode 100644 src/grt/grt-lib.ads create mode 100644 src/grt/grt-main.adb create mode 100644 src/grt/grt-main.ads create mode 100644 src/grt/grt-modules.adb create mode 100644 src/grt/grt-modules.ads create mode 100644 src/grt/grt-names.adb create mode 100644 src/grt/grt-names.ads create mode 100644 src/grt/grt-options.adb create mode 100644 src/grt/grt-options.ads create mode 100644 src/grt/grt-processes.adb create mode 100644 src/grt/grt-processes.ads create mode 100644 src/grt/grt-readline.ads create mode 100644 src/grt/grt-rtis.adb create mode 100644 src/grt/grt-rtis.ads create mode 100644 src/grt/grt-rtis_addr.adb create mode 100644 src/grt/grt-rtis_addr.ads create mode 100644 src/grt/grt-rtis_binding.ads create mode 100644 src/grt/grt-rtis_types.adb create mode 100644 src/grt/grt-rtis_types.ads create mode 100644 src/grt/grt-rtis_utils.adb create mode 100644 src/grt/grt-rtis_utils.ads create mode 100644 src/grt/grt-sdf.adb create mode 100644 src/grt/grt-sdf.ads create mode 100644 src/grt/grt-shadow_ieee.adb create mode 100644 src/grt/grt-shadow_ieee.ads create mode 100644 src/grt/grt-signals.adb create mode 100644 src/grt/grt-signals.ads create mode 100644 src/grt/grt-stack2.adb create mode 100644 src/grt/grt-stack2.ads create mode 100644 src/grt/grt-stacks.adb create mode 100644 src/grt/grt-stacks.ads create mode 100644 src/grt/grt-stats.adb create mode 100644 src/grt/grt-stats.ads create mode 100644 src/grt/grt-std_logic_1164.adb create mode 100644 src/grt/grt-std_logic_1164.ads create mode 100644 src/grt/grt-stdio.ads create mode 100644 src/grt/grt-table.adb create mode 100644 src/grt/grt-table.ads create mode 100644 src/grt/grt-threads.ads create mode 100644 src/grt/grt-types.ads create mode 100644 src/grt/grt-unithread.adb create mode 100644 src/grt/grt-unithread.ads create mode 100644 src/grt/grt-values.adb create mode 100644 src/grt/grt-values.ads create mode 100644 src/grt/grt-vcd.adb create mode 100644 src/grt/grt-vcd.ads create mode 100644 src/grt/grt-vcdz.adb create mode 100644 src/grt/grt-vcdz.ads create mode 100644 src/grt/grt-vital_annotate.adb create mode 100644 src/grt/grt-vital_annotate.ads create mode 100644 src/grt/grt-vpi.adb create mode 100644 src/grt/grt-vpi.ads create mode 100644 src/grt/grt-vstrings.adb create mode 100644 src/grt/grt-vstrings.ads create mode 100644 src/grt/grt-waves.adb create mode 100644 src/grt/grt-waves.ads create mode 100644 src/grt/grt-zlib.ads create mode 100644 src/grt/grt.adc create mode 100644 src/grt/grt.ads create mode 100644 src/grt/grt.ver create mode 100644 src/grt/main.adb create mode 100644 src/grt/main.ads delete mode 100644 src/translate/gcc/ANNOUNCE delete mode 100644 src/translate/gcc/INSTALL delete mode 100644 src/translate/gcc/Make-lang.in delete mode 100644 src/translate/gcc/Makefile.in delete mode 100644 src/translate/gcc/README delete mode 100644 src/translate/gcc/config-lang.in delete mode 100644 src/translate/gcc/dist-common.sh delete mode 100755 src/translate/gcc/dist.sh delete mode 100644 src/translate/gcc/lang-options.h delete mode 100644 src/translate/gcc/lang-specs.h delete mode 100644 src/translate/ghdldrv/Makefile delete mode 100644 src/translate/ghdldrv/default_pathes.ads.in delete mode 100644 src/translate/ghdldrv/foreigns.adb delete mode 100644 src/translate/ghdldrv/foreigns.ads delete mode 100644 src/translate/ghdldrv/ghdl_gcc.adb delete mode 100644 src/translate/ghdldrv/ghdl_jit.adb delete mode 100644 src/translate/ghdldrv/ghdl_simul.adb delete mode 100644 src/translate/ghdldrv/ghdlcomp.adb delete mode 100644 src/translate/ghdldrv/ghdlcomp.ads delete mode 100644 src/translate/ghdldrv/ghdldrv.adb delete mode 100644 src/translate/ghdldrv/ghdldrv.ads delete mode 100644 src/translate/ghdldrv/ghdllocal.adb delete mode 100644 src/translate/ghdldrv/ghdllocal.ads delete mode 100644 src/translate/ghdldrv/ghdlmain.adb delete mode 100644 src/translate/ghdldrv/ghdlmain.ads delete mode 100644 src/translate/ghdldrv/ghdlprint.adb delete mode 100644 src/translate/ghdldrv/ghdlprint.ads delete mode 100644 src/translate/ghdldrv/ghdlrun.adb delete mode 100644 src/translate/ghdldrv/ghdlrun.ads delete mode 100644 src/translate/ghdldrv/ghdlsimul.adb delete mode 100644 src/translate/ghdldrv/ghdlsimul.ads delete mode 100644 src/translate/ghdldrv/grtlink.ads delete mode 100644 src/translate/grt/Makefile delete mode 100644 src/translate/grt/Makefile.inc delete mode 100644 src/translate/grt/config/Makefile delete mode 100644 src/translate/grt/config/amd64.S delete mode 100644 src/translate/grt/config/chkstk.S delete mode 100644 src/translate/grt/config/clock.c delete mode 100644 src/translate/grt/config/i386.S delete mode 100644 src/translate/grt/config/ia64.S delete mode 100644 src/translate/grt/config/linux.c delete mode 100644 src/translate/grt/config/ppc.S delete mode 100644 src/translate/grt/config/pthread.c delete mode 100644 src/translate/grt/config/sparc.S delete mode 100644 src/translate/grt/config/teststack.c delete mode 100644 src/translate/grt/config/times.c delete mode 100644 src/translate/grt/config/win32.c delete mode 100644 src/translate/grt/config/win32thr.c delete mode 100644 src/translate/grt/ghdl_main.adb delete mode 100644 src/translate/grt/ghdl_main.ads delete mode 100644 src/translate/grt/ghwdump.c delete mode 100644 src/translate/grt/ghwlib.c delete mode 100644 src/translate/grt/ghwlib.h delete mode 100644 src/translate/grt/grt-arch.ads delete mode 100644 src/translate/grt/grt-arch_none.adb delete mode 100644 src/translate/grt/grt-arch_none.ads delete mode 100644 src/translate/grt/grt-astdio.adb delete mode 100644 src/translate/grt/grt-astdio.ads delete mode 100644 src/translate/grt/grt-avhpi.adb delete mode 100644 src/translate/grt/grt-avhpi.ads delete mode 100644 src/translate/grt/grt-avls.adb delete mode 100644 src/translate/grt/grt-avls.ads delete mode 100644 src/translate/grt/grt-c.ads delete mode 100644 src/translate/grt/grt-cbinding.c delete mode 100644 src/translate/grt/grt-cvpi.c delete mode 100644 src/translate/grt/grt-disp.adb delete mode 100644 src/translate/grt/grt-disp.ads delete mode 100644 src/translate/grt/grt-disp_rti.adb delete mode 100644 src/translate/grt/grt-disp_rti.ads delete mode 100644 src/translate/grt/grt-disp_signals.adb delete mode 100644 src/translate/grt/grt-disp_signals.ads delete mode 100644 src/translate/grt/grt-disp_tree.adb delete mode 100644 src/translate/grt/grt-disp_tree.ads delete mode 100644 src/translate/grt/grt-errors.adb delete mode 100644 src/translate/grt/grt-errors.ads delete mode 100644 src/translate/grt/grt-files.adb delete mode 100644 src/translate/grt/grt-files.ads delete mode 100644 src/translate/grt/grt-hooks.adb delete mode 100644 src/translate/grt/grt-hooks.ads delete mode 100644 src/translate/grt/grt-images.adb delete mode 100644 src/translate/grt/grt-images.ads delete mode 100644 src/translate/grt/grt-lib.adb delete mode 100644 src/translate/grt/grt-lib.ads delete mode 100644 src/translate/grt/grt-main.adb delete mode 100644 src/translate/grt/grt-main.ads delete mode 100644 src/translate/grt/grt-modules.adb delete mode 100644 src/translate/grt/grt-modules.ads delete mode 100644 src/translate/grt/grt-names.adb delete mode 100644 src/translate/grt/grt-names.ads delete mode 100644 src/translate/grt/grt-options.adb delete mode 100644 src/translate/grt/grt-options.ads delete mode 100644 src/translate/grt/grt-processes.adb delete mode 100644 src/translate/grt/grt-processes.ads delete mode 100644 src/translate/grt/grt-readline.ads delete mode 100644 src/translate/grt/grt-rtis.adb delete mode 100644 src/translate/grt/grt-rtis.ads delete mode 100644 src/translate/grt/grt-rtis_addr.adb delete mode 100644 src/translate/grt/grt-rtis_addr.ads delete mode 100644 src/translate/grt/grt-rtis_binding.ads delete mode 100644 src/translate/grt/grt-rtis_types.adb delete mode 100644 src/translate/grt/grt-rtis_types.ads delete mode 100644 src/translate/grt/grt-rtis_utils.adb delete mode 100644 src/translate/grt/grt-rtis_utils.ads delete mode 100644 src/translate/grt/grt-sdf.adb delete mode 100644 src/translate/grt/grt-sdf.ads delete mode 100644 src/translate/grt/grt-shadow_ieee.adb delete mode 100644 src/translate/grt/grt-shadow_ieee.ads delete mode 100644 src/translate/grt/grt-signals.adb delete mode 100644 src/translate/grt/grt-signals.ads delete mode 100644 src/translate/grt/grt-stack2.adb delete mode 100644 src/translate/grt/grt-stack2.ads delete mode 100644 src/translate/grt/grt-stacks.adb delete mode 100644 src/translate/grt/grt-stacks.ads delete mode 100644 src/translate/grt/grt-stats.adb delete mode 100644 src/translate/grt/grt-stats.ads delete mode 100644 src/translate/grt/grt-std_logic_1164.adb delete mode 100644 src/translate/grt/grt-std_logic_1164.ads delete mode 100644 src/translate/grt/grt-stdio.ads delete mode 100644 src/translate/grt/grt-table.adb delete mode 100644 src/translate/grt/grt-table.ads delete mode 100644 src/translate/grt/grt-threads.ads delete mode 100644 src/translate/grt/grt-types.ads delete mode 100644 src/translate/grt/grt-unithread.adb delete mode 100644 src/translate/grt/grt-unithread.ads delete mode 100644 src/translate/grt/grt-values.adb delete mode 100644 src/translate/grt/grt-values.ads delete mode 100644 src/translate/grt/grt-vcd.adb delete mode 100644 src/translate/grt/grt-vcd.ads delete mode 100644 src/translate/grt/grt-vcdz.adb delete mode 100644 src/translate/grt/grt-vcdz.ads delete mode 100644 src/translate/grt/grt-vital_annotate.adb delete mode 100644 src/translate/grt/grt-vital_annotate.ads delete mode 100644 src/translate/grt/grt-vpi.adb delete mode 100644 src/translate/grt/grt-vpi.ads delete mode 100644 src/translate/grt/grt-vstrings.adb delete mode 100644 src/translate/grt/grt-vstrings.ads delete mode 100644 src/translate/grt/grt-waves.adb delete mode 100644 src/translate/grt/grt-waves.ads delete mode 100644 src/translate/grt/grt-zlib.ads delete mode 100644 src/translate/grt/grt.adc delete mode 100644 src/translate/grt/grt.ads delete mode 100644 src/translate/grt/grt.ver delete mode 100644 src/translate/grt/main.adb delete mode 100644 src/translate/grt/main.ads delete mode 100644 src/translate/mcode/Makefile.in delete mode 100644 src/translate/mcode/README delete mode 100755 src/translate/mcode/dist.sh delete mode 100644 src/translate/mcode/winbuild.bat delete mode 100644 src/translate/mcode/windows/compile.bat delete mode 100644 src/translate/mcode/windows/complib.bat delete mode 100644 src/translate/mcode/windows/default_pathes.ads delete mode 100644 src/translate/mcode/windows/ghdl.nsi delete mode 100644 src/translate/mcode/windows/ghdlfilter.adb delete mode 100755 src/translate/mcode/windows/ghdlversion.adb delete mode 100644 src/translate/mcode/windows/grt-modules.adb delete mode 100644 src/translate/mcode/windows/ortho_code-x86-flags.ads delete mode 100644 src/translate/mcode/windows/windows_default_path.adb delete mode 100644 src/translate/mcode/windows/windows_default_path.ads (limited to 'src') diff --git a/src/ghdldrv/Makefile b/src/ghdldrv/Makefile new file mode 100644 index 000000000..ebf23c2d1 --- /dev/null +++ b/src/ghdldrv/Makefile @@ -0,0 +1,193 @@ +# -*- Makefile -*- for the GHDL drivers. +# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +# +# GHDL is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any later +# version. +# +# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING. If not, write to the Free +# Software Foundation, 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. +GNATFLAGS=-gnaty3befhkmr -gnata -gnatwael -aI../.. -aI.. -aI../../psl -aI../grt -aO.. -g -gnatf -gnat05 +GRT_FLAGS=-g +LIB_CFLAGS=-g -O2 +GNATMAKE=gnatmake +CC=gcc + +# Optimize, do not forget to use MODE=--genfast for iirs.adb. +#GNATFLAGS+=-O -gnatn +#GRT_FLAGS+=-O + +# Profiling. +#GNATFLAGS+=-pg -gnatn -O +#GRT_FLAGS+=-pg -O + +# Coverage +#GNATFLAGS+=-fprofile-arcs -ftest-coverage + +GNAT_BARGS=-bargs -E + +LLVM_CONFIG=llvm-config + +#GNAT_LARGS= -static +all: ghdl_mcode + +target=i686-pc-linux-gnu +#target=x86_64-pc-linux-gnu +#target=i686-apple-darwin +#target=x86_64-apple-darwin +#target=i386-pc-mingw32 +GRTSRCDIR=../grt +include $(GRTSRCDIR)/Makefile.inc + +ifeq ($(filter-out i%86 linux,$(arch) $(osys)),) + ORTHO_X86_FLAGS=Flags_Linux +endif +ifeq ($(filter-out i%86 darwin%,$(arch) $(osys)),) + ORTHO_X86_FLAGS=Flags_Macosx +endif +ifeq ($(filter-out i%86 mingw32%,$(arch) $(osys)),) + ORTHO_X86_FLAGS=Flags_Windows +endif +ifdef ORTHO_X86_FLAGS + ORTHO_DEPS=ortho_code-x86-flags.ads +endif + +ortho_code-x86-flags.ads: + echo "with Ortho_Code.X86.$(ORTHO_X86_FLAGS);" > $@ + echo "package Ortho_Code.X86.Flags renames Ortho_Code.X86.$(ORTHO_X86_FLAGS);" >> $@ + +ghdl_mcode: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME +ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) memsegs_c.o chkstk.o force + $(GNATMAKE) -o $@ -aI../../ortho/mcode -aI../../ortho $(GNATFLAGS) ghdl_jit.adb $(GNAT_BARGS) -largs memsegs_c.o chkstk.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) + +memsegs_c.o: ../../ortho/mcode/memsegs_c.c + $(CC) -c -g -o $@ $< + +ghdl_llvm_jit: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME +ghdl_llvm_jit: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) llvm-cbindings.o force + $(GNATMAKE) -o $@ -aI../../ortho/llvm -aI../../ortho $(GNATFLAGS) ghdl_jit.adb $(GNAT_BARGS) -largs llvm-cbindings.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) `$(LLVM_CONFIG) --ldflags --libs --system-libs` -lc++ + +llvm-cbindings.o: ../../ortho/llvm/llvm-cbindings.cpp + $(CXX) -c -m64 `$(LLVM_CONFIG) --includedir --cxxflags` -g -o $@ $< + +ghdl_simul: default_pathes.ads $(GRT_ADD_OBJS) force + $(GNATMAKE) -aI../../simulate $(GNATFLAGS) ghdl_simul $(GNAT_BARGS) -largs $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) + +ghdl_gcc: default_pathes.ads force + $(GNATMAKE) $(GNATFLAGS) ghdl_gcc $(GNAT_BARGS) -largs $(GNAT_LARGS) + +ghdl_llvm: default_pathes.ads force + $(GNATMAKE) $(GNATFLAGS) ghdl_llvm $(GNAT_BARGS) -largs $(GNAT_LARGS) + +default_pathes.ads: default_pathes.ads.in Makefile + curdir=`cd ..; pwd`; \ + sed -e "s%@COMPILER_GCC@%$$curdir/ghdl1-gcc%" \ + -e "s%@COMPILER_DEBUG@%$$curdir/ghdl1-debug%" \ + -e "s%@COMPILER_MCODE@%$$curdir/ghdl1-mcode%" \ + -e "s%@COMPILER_LLVM@%$$curdir/ghdl1-llvm%" \ + -e "s%@POST_PROCESSOR@%$$curdir/../ortho/oread/oread-gcc%" \ + -e "s%@INSTALL_PREFIX@%%" \ + -e "s%@LIB_PREFIX@%$$curdir/lib/%" < $< > $@ + +bootstrap.old: force + $(RM) ../../libraries/std-obj87.cf + $(MAKE) -C ../../libraries EXT=obj \ + ANALYSE="$(PWD)/ghdl -a -g" std-obj87.cf + $(RM) ../../libraries/std-obj93.cf + $(MAKE) -C ../../libraries EXT=obj \ + ANALYSE="$(PWD)/ghdl -a -g" std-obj93.cf + +LIB87_DIR:=../lib/v87 +LIB93_DIR:=../lib/v93 +LIB08_DIR:=../lib/v08 + +LIBSRC_DIR:=../../libraries +REL_DIR:=../.. +GHDL=ghdl +ANALYZE:=../../../ghdldrv/$(GHDL) -a $(LIB_CFLAGS) +LN=ln -s +CP=cp + +$(LIB87_DIR) $(LIB93_DIR) $(LIB08_DIR): + [ -d ../lib ] || mkdir ../lib + [ -d $@ ] || mkdir $@ + +include ../../libraries/Makefile.inc + +GHDL1=../ghdl1-gcc +$(LIB93_DIR)/std/std_standard.o: $(GHDL1) +ifeq ($(GHDL),ghdl_llvm) + $(GHDL1) --std=93 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard +else + $(GHDL1) --std=93 -quiet $(LIB_CFLAGS) -o std_standard.s \ + --compile-standard + $(CC) -c -o $@ std_standard.s + $(RM) std_standard.s +endif + +$(LIB87_DIR)/std/std_standard.o: $(GHDL1) +ifeq ($(GHDL),ghdl_llvm) + $(GHDL1) --std=87 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard +else + $(GHDL1) --std=87 -quiet $(LIB_CFLAGS) -o std_standard.s \ + --compile-standard + $(CC) -c -o $@ std_standard.s + $(RM) std_standard.s +endif + +$(LIB08_DIR)/std/std_standard.o: $(GHDL1) +ifeq ($(GHDL),ghdl_llvm) + $(GHDL1) --std=08 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard +else + $(GHDL1) --std=08 -quiet $(LIB_CFLAGS) -o std_standard.s \ + --compile-standard + $(CC) -c -o $@ std_standard.s + $(RM) std_standard.s +endif + +install.v93: std.v93 ieee.v93 synopsys.v93 mentor.v93 +install.v87: std.v87 ieee.v87 synopsys.v87 +install.v08: std.v08 ieee.v08 + +install.standard: $(LIB93_DIR)/std/std_standard.o \ + $(LIB87_DIR)/std/std_standard.o \ + $(LIB08_DIR)/std/std_standard.o + +grt.links: + cd ../lib; ln -sf $(GRTSRCDIR)/grt.lst .; ln -sf $(GRTSRCDIR)/libgrt.a .; ln -sf $(GRTSRCDIR)/grt.ver . + +install.all: install.v87 install.v93 install.v08 + +install.gcc: + $(MAKE) GHDL=ghdl_gcc install.all + $(MAKE) GHDL1=../ghdl1-gcc install.standard + +install.mcode: + $(MAKE) GHDL=ghdl_mcode install.all + +install.simul: + $(MAKE) GHDL=ghdl_simul install.all + +install.llvm: + $(MAKE) GHDL=ghdl_llvm install.all + $(MAKE) GHDL1=../ghdl1-llvm install.standard + +clean: force + $(RM) -f *.o *.ali ghdl_gcc ghdl_mcode ghdl_llvm ghdl_llvm_jit + $(RM) -f b~*.ad? *~ default_pathes.ads ghdl_simul + $(RM) -rf ../lib + +clean-c: force + $(RM) -f memsegs_c.o chkstk.o linux.o times.o grt-cbinding.o grt-cvpi.o + +force: + +.PHONY: force clean diff --git a/src/ghdldrv/default_pathes.ads.in b/src/ghdldrv/default_pathes.ads.in new file mode 100644 index 000000000..7f471a5ed --- /dev/null +++ b/src/ghdldrv/default_pathes.ads.in @@ -0,0 +1,39 @@ +-- GHDL driver pathes -*- ada -*-. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +package Default_Pathes is + + -- Accept long lines. + pragma Style_Checks ("M999"); + + Install_Prefix : constant String := + "@INSTALL_PREFIX@"; + Lib_Prefix : constant String := + "@LIB_PREFIX@"; + + Compiler_Gcc : constant String := + "@COMPILER_GCC@"; + Compiler_Mcode : constant String := + "@COMPILER_MCODE@"; + Compiler_Llvm : constant String := + "@COMPILER_LLVM@"; + Compiler_Debug : constant String := + "@COMPILER_DEBUG@"; + Post_Processor : constant String := + "@POST_PROCESSOR@"; +end Default_Pathes; diff --git a/src/ghdldrv/foreigns.adb b/src/ghdldrv/foreigns.adb new file mode 100644 index 000000000..15e3dd009 --- /dev/null +++ b/src/ghdldrv/foreigns.adb @@ -0,0 +1,64 @@ +with Interfaces.C; use Interfaces.C; + +package body Foreigns is + function Sin (Arg : double) return double; + pragma Import (C, Sin); + + function Log (Arg : double) return double; + pragma Import (C, Log); + + function Exp (Arg : double) return double; + pragma Import (C, Exp); + + function Sqrt (Arg : double) return double; + pragma Import (C, Sqrt); + + function Asin (Arg : double) return double; + pragma Import (C, Asin); + + function Acos (Arg : double) return double; + pragma Import (C, Acos); + + function Asinh (Arg : double) return double; + pragma Import (C, Asinh); + + function Acosh (Arg : double) return double; + pragma Import (C, Acosh); + + function Atanh (X : double) return double; + pragma Import (C, Atanh); + + function Atan2 (X, Y : double) return double; + pragma Import (C, Atan2); + + type String_Cacc is access constant String; + type Foreign_Record is record + Name : String_Cacc; + Addr : Address; + end record; + + + Foreign_Arr : constant array (Natural range <>) of Foreign_Record := + ( + (new String'("sin"), Sin'Address), + (new String'("log"), Log'Address), + (new String'("exp"), Exp'Address), + (new String'("sqrt"), Sqrt'Address), + (new String'("asin"), Asin'Address), + (new String'("acos"), Acos'Address), + (new String'("asinh"), Asinh'Address), + (new String'("acosh"), Acosh'Address), + (new String'("atanh"), Atanh'Address), + (new String'("atan2"), Atan2'Address) + ); + + function Find_Foreign (Name : String) return Address is + begin + for I in Foreign_Arr'Range loop + if Foreign_Arr(I).Name.all = Name then + return Foreign_Arr(I).Addr; + end if; + end loop; + return Null_Address; + end Find_Foreign; +end Foreigns; diff --git a/src/ghdldrv/foreigns.ads b/src/ghdldrv/foreigns.ads new file mode 100644 index 000000000..5759ae4f5 --- /dev/null +++ b/src/ghdldrv/foreigns.ads @@ -0,0 +1,5 @@ +with System; use System; + +package Foreigns is + function Find_Foreign (Name : String) return Address; +end Foreigns; diff --git a/src/ghdldrv/ghdl_gcc.adb b/src/ghdldrv/ghdl_gcc.adb new file mode 100644 index 000000000..615a8c5d6 --- /dev/null +++ b/src/ghdldrv/ghdl_gcc.adb @@ -0,0 +1,34 @@ +-- GHDL driver for gcc. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ghdlmain; +with Ghdllocal; +with Ghdldrv; +with Ghdlprint; + +procedure Ghdl_Gcc is +begin + -- Manual elaboration so that the order is known (because it is the order + -- used to display help). + Ghdlmain.Version_String := new String'("GCC back-end code generator"); + Ghdldrv.Compile_Kind := Ghdldrv.Compile_Gcc; + Ghdldrv.Register_Commands; + Ghdllocal.Register_Commands; + Ghdlprint.Register_Commands; + Ghdlmain.Register_Commands; + Ghdlmain.Main; +end Ghdl_Gcc; diff --git a/src/ghdldrv/ghdl_jit.adb b/src/ghdldrv/ghdl_jit.adb new file mode 100644 index 000000000..ba7087492 --- /dev/null +++ b/src/ghdldrv/ghdl_jit.adb @@ -0,0 +1,35 @@ +-- GHDL driver for jit. +-- Copyright (C) 2002-2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ghdlmain; +with Ghdllocal; +with Ghdlprint; +with Ghdlrun; +with Ortho_Jit; + +procedure Ghdl_Jit is +begin + -- Manual elaboration so that the order is known (because it is the order + -- used to display help). + Ghdlmain.Version_String := + new String'(Ortho_Jit.Get_Jit_Name & " code generator"); + Ghdlrun.Register_Commands; + Ghdllocal.Register_Commands; + Ghdlprint.Register_Commands; + Ghdlmain.Register_Commands; + Ghdlmain.Main; +end Ghdl_Jit; diff --git a/src/ghdldrv/ghdl_simul.adb b/src/ghdldrv/ghdl_simul.adb new file mode 100644 index 000000000..d4d0abd7a --- /dev/null +++ b/src/ghdldrv/ghdl_simul.adb @@ -0,0 +1,33 @@ +-- GHDL driver for simulator. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ghdlmain; +with Ghdllocal; +with Ghdlprint; +with Ghdlsimul; + +procedure Ghdl_Simul is +begin + -- Manual elaboration so that the order is known (because it is the order + -- used to display help). + Ghdlmain.Version_String := new String'("interpretation"); + Ghdlsimul.Register_Commands; + Ghdllocal.Register_Commands; + Ghdlprint.Register_Commands; + Ghdlmain.Register_Commands; + Ghdlmain.Main; +end Ghdl_Simul; diff --git a/src/ghdldrv/ghdlcomp.adb b/src/ghdldrv/ghdlcomp.adb new file mode 100644 index 000000000..ba755af8a --- /dev/null +++ b/src/ghdldrv/ghdlcomp.adb @@ -0,0 +1,757 @@ +-- GHDL driver - compile commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ghdlmain; use Ghdlmain; +with Ghdllocal; use Ghdllocal; + +with Ada.Command_Line; +with Ada.Characters.Latin_1; +with Ada.Text_IO; + +with Types; +with Iirs; use Iirs; +with Nodes_GC; +with Flags; +with Back_End; +with Sem; +with Name_Table; +with Errorout; use Errorout; +with Libraries; +with Std_Package; +with Files_Map; +with Version; +with Default_Pathes; + +package body Ghdlcomp is + + Flag_Expect_Failure : Boolean := False; + + Flag_Debug_Nodes_Leak : Boolean := False; + -- If True, detect unreferenced nodes at the end of analysis. + + -- Commands which use the mcode compiler. + type Command_Comp is abstract new Command_Lib with null record; + procedure Decode_Option (Cmd : in out Command_Comp; + Option : String; + Arg : String; + Res : out Option_Res); + procedure Disp_Long_Help (Cmd : Command_Comp); + + procedure Decode_Option (Cmd : in out Command_Comp; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "--expect-failure" then + Flag_Expect_Failure := True; + Res := Option_Ok; + elsif Option = "--debug-nodes-leak" then + Flag_Debug_Nodes_Leak := True; + Res := Option_Ok; + elsif Hooks.Decode_Option.all (Option) then + Res := Option_Ok; + else + Decode_Option (Command_Lib (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + + procedure Disp_Long_Help (Cmd : Command_Comp) + is + use Ada.Text_IO; + begin + Disp_Long_Help (Command_Lib (Cmd)); + Hooks.Disp_Long_Help.all; + Put_Line (" --expect-failure Expect analysis/elaboration failure"); + end Disp_Long_Help; + + -- Command -r + type Command_Run is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Run; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Run) return String; + + procedure Perform_Action (Cmd : in out Command_Run; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Run; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-r" or Name = "--elab-run"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Run) return String + is + pragma Unreferenced (Cmd); + begin + return "-r,--elab-run [OPTS] UNIT [ARCH] [RUNOPTS] Run UNIT"; + end Get_Short_Help; + + + procedure Perform_Action (Cmd : in out Command_Run; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Opt_Arg : Natural; + begin + begin + Hooks.Compile_Init.all (False); + + Libraries.Load_Work_Library (False); + Flags.Flag_Elaborate_With_Outdated := False; + Flags.Flag_Only_Elab_Warnings := True; + + Hooks.Compile_Elab.all ("-r", Args, Opt_Arg); + exception + when Compilation_Error => + if Flag_Expect_Failure then + return; + else + raise; + end if; + end; + Hooks.Set_Run_Options (Args (Opt_Arg .. Args'Last)); + Hooks.Run.all; + end Perform_Action; + + + -- Command -c xx -r + type Command_Compile is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Compile; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Compile) return String; + procedure Decode_Option (Cmd : in out Command_Compile; + Option : String; + Arg : String; + Res : out Option_Res); + procedure Perform_Action (Cmd : in out Command_Compile; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Compile; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-c"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Compile) return String + is + pragma Unreferenced (Cmd); + begin + return "-c [OPTS] FILEs -r UNIT [ARCH] [RUNOPTS] " + & "Compile, elaborate and run UNIT"; + end Get_Short_Help; + + procedure Decode_Option (Cmd : in out Command_Compile; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "-r" or else Option = "-e" then + Res := Option_End; + else + Decode_Option (Command_Comp (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Perform_Action (Cmd : in out Command_Compile; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Elab_Arg : Natural; + Run_Arg : Natural; + begin + begin + Hooks.Compile_Init.all (False); + + Flags.Flag_Elaborate_With_Outdated := True; + Flags.Flag_Only_Elab_Warnings := False; + + if Args'Length > 1 and then + (Args (Args'First).all = "-r" or else Args (Args'First).all = "-e") + then + -- If there is no files, then load the work library. + Libraries.Load_Work_Library (False); + -- Also, load all libraries and files, so that every design unit + -- is known. + Load_All_Libraries_And_Files; + Elab_Arg := Args'First + 1; + else + -- If there is at least one file, do not load the work library. + Libraries.Load_Work_Library (True); + Elab_Arg := Natural'Last; + for I in Args'Range loop + declare + Arg : constant String := Args (I).all; + Res : Iir_Design_File; + Design : Iir; + Next_Design : Iir; + begin + if Arg = "-r" or else Arg = "-e" then + Elab_Arg := I + 1; + exit; + else + Res := Libraries.Load_File + (Name_Table.Get_Identifier (Arg)); + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Put units into library. + Design := Get_First_Design_Unit (Res); + while not Is_Null (Design) loop + Next_Design := Get_Chain (Design); + Set_Chain (Design, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Design); + Design := Next_Design; + end loop; + end if; + end; + end loop; + if Elab_Arg = Natural'Last then + Libraries.Save_Work_Library; + return; + end if; + end if; + + Hooks.Compile_Elab.all ("-c", Args (Elab_Arg .. Args'Last), Run_Arg); + exception + when Compilation_Error => + if Flag_Expect_Failure then + return; + else + raise; + end if; + end; + if Args (Elab_Arg - 1).all = "-r" then + Hooks.Set_Run_Options (Args (Run_Arg .. Args'Last)); + Hooks.Run.all; + else + if Run_Arg <= Args'Last then + Error_Msg_Option ("options after unit are ignored"); + end if; + end if; + end Perform_Action; + + -- Command -a + type Command_Analyze is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Analyze; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Analyze) return String; + + procedure Perform_Action (Cmd : in out Command_Analyze; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Analyze; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-a"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Analyze) return String + is + pragma Unreferenced (Cmd); + begin + return "-a [OPTS] FILEs Analyze FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Analyze; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Types; + Id : Name_Id; + Design_File : Iir_Design_File; + New_Design_File : Iir_Design_File; + Unit : Iir; + Next_Unit : Iir; + begin + Setup_Libraries (True); + + Hooks.Compile_Init.all (True); + + -- Parse all files. + for I in Args'Range loop + Id := Name_Table.Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if False then + -- Speed up analysis: remove all previous designs. + -- However, this is not in the LRM... + Libraries.Purge_Design_File (Design_File); + end if; + + if Design_File /= Null_Iir then + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + Back_End.Finish_Compilation (Unit, True); + + Next_Unit := Get_Chain (Unit); + + if Errorout.Nbr_Errors = 0 then + Set_Chain (Unit, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Unit); + New_Design_File := Get_Design_File (Unit); + end if; + + Unit := Next_Unit; + end loop; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + Free_Iir (Design_File); + + -- Do late analysis checks. + Unit := Get_First_Design_Unit (New_Design_File); + while Unit /= Null_Iir loop + Sem.Sem_Analysis_Checks_List (Unit, Flags.Warn_Delayed_Checks); + Unit := Get_Chain (Unit); + end loop; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + end if; + end loop; + + if Flag_Expect_Failure then + raise Compilation_Error; + end if; + + if Flag_Debug_Nodes_Leak then + Nodes_GC.Report_Unreferenced; + end if; + + Libraries.Save_Work_Library; + + exception + when Compilation_Error => + if Flag_Expect_Failure and Errorout.Nbr_Errors /= 0 then + return; + else + raise; + end if; + end Perform_Action; + + -- Command -e + type Command_Elab is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Elab; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Elab) return String; + procedure Decode_Option (Cmd : in out Command_Elab; + Option : String; + Arg : String; + Res : out Option_Res); + + procedure Perform_Action (Cmd : in out Command_Elab; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Elab; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-e"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Elab) return String + is + pragma Unreferenced (Cmd); + begin + return "-e [OPTS] UNIT [ARCH] Elaborate UNIT"; + end Get_Short_Help; + + procedure Decode_Option (Cmd : in out Command_Elab; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "--expect-failure" then + Flag_Expect_Failure := True; + Res := Option_Ok; + elsif Option = "-o" then + if Arg'Length = 0 then + Res := Option_Arg_Req; + else + -- Silently accepted. + Res := Option_Arg; + end if; + --elsif Option'Length >= 4 and then Option (1 .. 4) = "-Wl," then + -- Res := Option_Ok; + else + Decode_Option (Command_Lib (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Perform_Action (Cmd : in out Command_Elab; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Run_Arg : Natural; + begin + Hooks.Compile_Init.all (False); + + Libraries.Load_Work_Library (False); + Flags.Flag_Elaborate_With_Outdated := False; + Flags.Flag_Only_Elab_Warnings := True; + + Hooks.Compile_Elab.all ("-e", Args, Run_Arg); + if Run_Arg <= Args'Last then + Error_Msg_Option ("options after unit are ignored"); + end if; + if Flag_Expect_Failure then + raise Compilation_Error; + end if; + exception + when Compilation_Error => + if Flag_Expect_Failure and then Errorout.Nbr_Errors > 0 then + return; + else + raise; + end if; + end Perform_Action; + + -- Command dispconfig. + type Command_Dispconfig is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Dispconfig; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Dispconfig) return String; + procedure Perform_Action (Cmd : in out Command_Dispconfig; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Dispconfig; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--dispconfig"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Dispconfig) return String + is + pragma Unreferenced (Cmd); + begin + return "--dispconfig Disp tools path"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Dispconfig; + Args : Argument_List) + is + use Ada.Text_IO; + use Libraries; + pragma Unreferenced (Cmd); + begin + if Args'Length /= 0 then + Error ("--dispconfig does not accept any argument"); + raise Errorout.Option_Error; + end if; + + Put ("command line prefix (--PREFIX): "); + if Prefix_Path = null then + Put_Line ("(not set)"); + else + Put_Line (Prefix_Path.all); + end if; + Setup_Libraries (False); + + Put ("environment prefix (GHDL_PREFIX): "); + if Prefix_Env = null then + Put_Line ("(not set)"); + else + Put_Line (Prefix_Env.all); + end if; + + Put_Line ("default prefix: " & Default_Pathes.Prefix); + Put_Line ("actual prefix: " & Prefix_Path.all); + Put_Line ("command_name: " & Ada.Command_Line.Command_Name); + Put_Line ("default library pathes:"); + for I in 2 .. Get_Nbr_Pathes loop + Put (' '); + Put_Line (Name_Table.Image (Get_Path (I))); + end loop; + end Perform_Action; + + -- Command Make. + type Command_Make is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Make; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Make) return String; + procedure Perform_Action (Cmd : in out Command_Make; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Make; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-m"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Make) return String + is + pragma Unreferenced (Cmd); + begin + return "-m [OPTS] UNIT [ARCH] Make UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Types; + + Files_List : Iir_List; + File : Iir_Design_File; + + Next_Arg : Natural; + Date : Date_Type; + Unit : Iir_Design_Unit; + begin + Extract_Elab_Unit ("-m", Args, Next_Arg); + Setup_Libraries (True); + + -- Create list of files. + Files_List := Build_Dependence (Prim_Name, Sec_Name); + + Date := Get_Date (Libraries.Work_Library); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + + if Get_Library (File) = Libraries.Work_Library then + -- Mark this file as analyzed. + Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp); + + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + if Get_Date (Unit) = Date_Analyzed + or else Get_Date (Unit) in Date_Valid + then + Date := Date + 1; + Set_Date (Unit, Date); + end if; + Unit := Get_Chain (Unit); + end loop; + end if; + end loop; + Set_Date (Libraries.Work_Library, Date); + Libraries.Save_Work_Library; + exception + when Compilation_Error => + if Flag_Expect_Failure then + return; + else + raise; + end if; + end Perform_Action; + + -- Command Gen_Makefile. + type Command_Gen_Makefile is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Gen_Makefile) return String; + procedure Perform_Action (Cmd : in out Command_Gen_Makefile; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--gen-makefile"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Gen_Makefile) return String + is + pragma Unreferenced (Cmd); + begin + return "--gen-makefile [OPTS] UNIT [ARCH] Generate a Makefile for UNIT"; + end Get_Short_Help; + + function Is_Makeable_File (File : Iir_Design_File) return Boolean is + begin + if File = Std_Package.Std_Standard_File then + return False; + end if; + return True; + end Is_Makeable_File; + + procedure Perform_Action (Cmd : in out Command_Gen_Makefile; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Types; + use Ada.Text_IO; + use Ada.Command_Line; + use Name_Table; + + HT : constant Character := Ada.Characters.Latin_1.HT; + Files_List : Iir_List; + File : Iir_Design_File; + + Lib : Iir_Library_Declaration; + Dir_Id : Name_Id; + + Next_Arg : Natural; + begin + Extract_Elab_Unit ("--gen-makefile", Args, Next_Arg); + Setup_Libraries (True); + Files_List := Build_Dependence (Prim_Name, Sec_Name); + + Put_Line ("# Makefile automatically generated by ghdl"); + Put ("# Version: "); + Put (Version.Ghdl_Release); + Put (" - "); + if Version_String /= null then + Put (Version_String.all); + end if; + New_Line; + Put_Line ("# Command used to generate this makefile:"); + Put ("# "); + Put (Command_Name); + for I in 1 .. Argument_Count loop + Put (' '); + Put (Argument (I)); + end loop; + New_Line; + + New_Line; + + Put ("GHDL="); + Put_Line (Command_Name); + + -- Extract options for command line. + Put ("GHDLFLAGS="); + for I in 2 .. Argument_Count loop + declare + Arg : constant String := Argument (I); + begin + if Arg (1) = '-' then + if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=") + or else (Arg'Length > 7 and then Arg (1 .. 7) = "--ieee=") + or else (Arg'Length > 6 and then Arg (1 .. 6) = "--std=") + or else (Arg'Length > 7 and then Arg (1 .. 7) = "--work=") + or else (Arg'Length > 2 and then Arg (1 .. 2) = "-P") + then + Put (" "); + Put (Arg); + end if; + end if; + end; + end loop; + New_Line; + + Put ("GHDLRUNFLAGS="); + for I in Next_Arg .. Args'Last loop + Put (' '); + Put (Args (I).all); + end loop; + New_Line; + New_Line; + + Put_Line ("# Default target : elaborate"); + Put_Line ("all : elab"); + New_Line; + + Put_Line ("# Elaborate target. Almost useless"); + Put_Line ("elab : force"); + Put (HT & "$(GHDL) -c $(GHDLFLAGS) -e "); + Put (Prim_Name.all); + if Sec_Name /= null then + Put (' '); + Put (Sec_Name.all); + end if; + New_Line; + New_Line; + + Put_Line ("# Run target"); + Put_Line ("run : force"); + Put (HT & "$(GHDL) -c $(GHDLFLAGS) -r "); + Put (Prim_Name.all); + if Sec_Name /= null then + Put (' '); + Put (Sec_Name.all); + end if; + Put (" $(GHDLRUNFLAGS)"); + New_Line; + New_Line; + + Put_Line ("# Targets to analyze libraries"); + Put_Line ("init: force"); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + Dir_Id := Get_Design_File_Directory (File); + if not Is_Makeable_File (File) then + -- Builtin file. + null; + elsif Dir_Id /= Files_Map.Get_Home_Directory then + -- Not locally built file. + Put (HT & "# "); + Put (Image (Dir_Id)); + Put (Image (Get_Design_File_Filename (File))); + New_Line; + else + + Put (HT & "$(GHDL) -a $(GHDLFLAGS)"); + Lib := Get_Library (File); + if Lib /= Libraries.Work_Library then + -- Overwrite some options. + Put (" --work="); + Put (Image (Get_Identifier (Lib))); + Dir_Id := Get_Library_Directory (Lib); + Put (" --workdir="); + if Dir_Id = Libraries.Local_Directory then + Put ("."); + else + Put (Image (Dir_Id)); + end if; + end if; + Put (' '); + Put (Image (Get_Design_File_Filename (File))); + New_Line; + end if; + end loop; + New_Line; + + Put_Line ("force:"); + end Perform_Action; + + procedure Register_Commands is + begin + Register_Command (new Command_Analyze); + Register_Command (new Command_Elab); + Register_Command (new Command_Run); + Register_Command (new Command_Compile); + Register_Command (new Command_Make); + Register_Command (new Command_Gen_Makefile); + Register_Command (new Command_Dispconfig); + end Register_Commands; + +end Ghdlcomp; diff --git a/src/ghdldrv/ghdlcomp.ads b/src/ghdldrv/ghdlcomp.ads new file mode 100644 index 000000000..f803ca4fa --- /dev/null +++ b/src/ghdldrv/ghdlcomp.ads @@ -0,0 +1,67 @@ +-- GHDL driver - compile commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package Ghdlcomp is + -- This procedure is called at start of commands which call + -- finish_compilation to generate code. + type Compile_Init_Acc is access procedure (Analyze_Only : Boolean); + + -- This procedure is called for elaboration. + -- CMD_NAME is the name of the command, used to report errors. + -- ARGS is the argument list, starting from the unit name to be elaborated. + -- The procedure should extract the unit. + -- OPT_ARG is the index of the first argument from ARGS to be used as + -- a run option. + type Compile_Elab_Acc is access procedure + (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural); + + -- Use ARGS as run options. + -- Should do all the work. + type Set_Run_Options_Acc is access + procedure (Args : Argument_List); + + -- Run the simulation. + -- All the parameters were set through calling Compile_Elab and + -- Set_Run_Options. + type Run_Acc is access procedure; + + -- Called when an analysis/elaboration option is decoded. + -- Return True if OPTION is known (and do the side effects). + -- No parameters are allowed. + type Decode_Option_Acc is access function (Option : String) return Boolean; + + -- Disp help for options decoded by Decode_Option. + type Disp_Long_Help_Acc is access procedure; + + -- All the hooks gathered. + -- A record is used to be sure all hooks are set. + type Hooks_Type is record + Compile_Init : Compile_Init_Acc := null; + Compile_Elab : Compile_Elab_Acc := null; + Set_Run_Options : Set_Run_Options_Acc := null; + Run : Run_Acc := null; + Decode_Option : Decode_Option_Acc := null; + Disp_Long_Help : Disp_Long_Help_Acc := null; + end record; + + Hooks : Hooks_Type; + + -- Register commands. + procedure Register_Commands; +end Ghdlcomp; diff --git a/src/ghdldrv/ghdldrv.adb b/src/ghdldrv/ghdldrv.adb new file mode 100644 index 000000000..be905f1af --- /dev/null +++ b/src/ghdldrv/ghdldrv.adb @@ -0,0 +1,1818 @@ +-- GHDL driver - commands invoking gcc. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Characters.Latin_1; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Table; +with GNAT.Dynamic_Tables; +with Libraries; +with Name_Table; use Name_Table; +with Std_Package; +with Types; use Types; +with Iirs; use Iirs; +with Files_Map; +with Flags; +with Configuration; +--with Disp_Tree; +with Default_Pathes; +with Interfaces.C_Streams; +with System; +with Ghdlmain; use Ghdlmain; +with Ghdllocal; use Ghdllocal; +with Errorout; +with Version; +with Options; + +package body Ghdldrv is + -- Name of the tools used. + Compiler_Cmd : String_Access := null; + Post_Processor_Cmd : String_Access := null; + Assembler_Cmd : constant String := "as"; + Linker_Cmd : constant String := "gcc"; + + -- Path of the tools. + Compiler_Path : String_Access; + Post_Processor_Path : String_Access; + Assembler_Path : String_Access; + Linker_Path : String_Access; + + -- Set by the '-o' option: the output filename. If the option is not + -- present, then null. + Output_File : String_Access; + + -- "-o" string. + Dash_o : constant String_Access := new String'("-o"); + + -- "-c" string. + Dash_c : constant String_Access := new String'("-c"); + + -- "-quiet" option. + Dash_Quiet : constant String_Access := new String'("-quiet"); + + -- If set, do not assmble + Flag_Asm : Boolean; + + -- If true, executed commands are displayed. + Flag_Disp_Commands : Boolean; + + -- Flag not quiet + Flag_Not_Quiet : Boolean; + + -- True if failure expected. + Flag_Expect_Failure : Boolean; + + -- Argument table for the tools. + -- Each table low bound is 1 so that the length of a table is equal to + -- the last bound. + package Argument_Table_Pkg is new GNAT.Dynamic_Tables + (Table_Component_Type => String_Access, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 4, + Table_Increment => 100); + use Argument_Table_Pkg; + + -- Arguments for tools. + Compiler_Args : Argument_Table_Pkg.Instance; + Postproc_Args : Argument_Table_Pkg.Instance; + Assembler_Args : Argument_Table_Pkg.Instance; + Linker_Args : Argument_Table_Pkg.Instance; + + -- Display the program spawned in Flag_Disp_Commands is TRUE. + -- Raise COMPILE_ERROR in case of failure. + procedure My_Spawn (Program_Name : String; Args : Argument_List) + is + Status : Integer; + begin + if Flag_Disp_Commands then + Put (Program_Name); + for I in Args'Range loop + Put (' '); + Put (Args (I).all); + end loop; + New_Line; + end if; + Status := Spawn (Program_Name, Args); + if Status = 0 then + return; + elsif Status = 1 then + Error ("compilation error"); + raise Compile_Error; + elsif Status > 127 then + Error ("executable killed by a signal"); + raise Exec_Error; + else + Error ("exec error"); + raise Exec_Error; + end if; + end My_Spawn; + + -- Compile FILE with additional argument OPTS. + procedure Do_Compile (Options : Argument_List; File : String) + is + Obj_File : String_Access; + Asm_File : String_Access; + Post_File : String_Access; + Success : Boolean; + begin + -- Create post file. + case Compile_Kind is + when Compile_Debug => + Post_File := Append_Suffix (File, Post_Suffix); + when others => + null; + end case; + + -- Create asm file. + case Compile_Kind is + when Compile_Gcc + | Compile_Debug => + Asm_File := Append_Suffix (File, Asm_Suffix); + when Compile_Llvm + | Compile_Mcode => + null; + end case; + + -- Create obj file (may not be used, but the condition isn't simple). + Obj_File := Append_Suffix (File, Get_Object_Suffix.all); + + -- Compile. + declare + P : Natural; + Nbr_Args : constant Natural := + Last (Compiler_Args) + Options'Length + 4; + Args : Argument_List (1 .. Nbr_Args); + begin + P := 0; + for I in First .. Last (Compiler_Args) loop + P := P + 1; + Args (P) := Compiler_Args.Table (I); + end loop; + for I in Options'Range loop + P := P + 1; + Args (P) := Options (I); + end loop; + + -- Add -quiet. + case Compile_Kind is + when Compile_Gcc => + if not Flag_Not_Quiet then + P := P + 1; + Args (P) := Dash_Quiet; + end if; + when Compile_Llvm => + P := P + 1; + Args (P) := Dash_c; + when Compile_Debug + | Compile_Mcode => + null; + end case; + + Args (P + 1) := Dash_o; + case Compile_Kind is + when Compile_Debug => + Args (P + 2) := Post_File; + when Compile_Gcc => + Args (P + 2) := Asm_File; + when Compile_Mcode + | Compile_Llvm => + Args (P + 2) := Obj_File; + end case; + Args (P + 3) := new String'(File); + + My_Spawn (Compiler_Path.all, Args (1 .. P + 3)); + Free (Args (P + 3)); + exception + when Compile_Error => + -- Delete temporary file in case of error. + Delete_File (Args (P + 2).all, Success); + -- FIXME: delete object file too ? + raise; + end; + + -- Post-process. + if Compile_Kind = Compile_Debug then + declare + P : Natural; + Nbr_Args : constant Natural := Last (Postproc_Args) + 4; + Args : Argument_List (1 .. Nbr_Args); + begin + P := 0; + for I in First .. Last (Postproc_Args) loop + P := P + 1; + Args (P) := Postproc_Args.Table (I); + end loop; + + if not Flag_Not_Quiet then + P := P + 1; + Args (P) := Dash_Quiet; + end if; + + Args (P + 1) := Dash_o; + Args (P + 2) := Asm_File; + Args (P + 3) := Post_File; + My_Spawn (Post_Processor_Path.all, Args (1 .. P + 3)); + end; + + Free (Post_File); + end if; + + -- Assemble. + if Compile_Kind >= Compile_Gcc then + if Flag_Expect_Failure then + Delete_File (Asm_File.all, Success); + elsif not Flag_Asm then + declare + P : Natural; + Nbr_Args : constant Natural := Last (Assembler_Args) + 4; + Args : Argument_List (1 .. Nbr_Args); + Success : Boolean; + begin + P := 0; + for I in First .. Last (Assembler_Args) loop + P := P + 1; + Args (P) := Assembler_Args.Table (I); + end loop; + + Args (P + 1) := Dash_o; + Args (P + 2) := Obj_File; + Args (P + 3) := Asm_File; + My_Spawn (Assembler_Path.all, Args (1 .. P + 3)); + Delete_File (Asm_File.all, Success); + end; + end if; + end if; + + Free (Asm_File); + Free (Obj_File); + end Do_Compile; + + package Filelist is new GNAT.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 16, + Table_Increment => 100); + + Link_Obj_Suffix : String_Access; + + -- Read a list of files from file FILENAME. + -- Lines starting with a '#' are ignored (comments) + -- Lines starting with a '>' are directory lines + -- If first character of a line is a '@', it is replaced with + -- the lib_prefix_path. + -- If TO_OBJ is true, then each file is converted to an object file name + -- (suffix is replaced by the object file extension). + procedure Add_File_List (Filename : String; To_Obj : Boolean) + is + use Interfaces.C_Streams; + use System; + use Ada.Characters.Latin_1; + + -- Replace the first '@' with the machine path. + function Substitute (Str : String) return String + is + begin + for I in Str'Range loop + if Str (I) = '@' then + return Str (Str'First .. I - 1) + & Get_Machine_Path_Prefix + & Str (I + 1 .. Str'Last); + end if; + end loop; + return Str; + end Substitute; + + Dir : String (1 .. max_path_len); + Dir_Len : Natural; + Line : String (1 .. max_path_len); + Stream : Interfaces.C_Streams.FILEs; + Mode : constant String := "rt" & Ghdllocal.Nul; + L : Natural; + File : String_Access; + begin + Line (1 .. Filename'Length) := Filename; + Line (Filename'Length + 1) := Ghdllocal.Nul; + Stream := fopen (Line'Address, Mode'Address); + if Stream = NULL_Stream then + Error ("cannot open " & Filename); + raise Compile_Error; + end if; + Dir_Len := 0; + loop + exit when fgets (Line'Address, Line'Length, Stream) = NULL_Stream; + if Line (1) /= '#' then + -- Compute string length. + L := 0; + while Line (L + 1) /= Ghdllocal.Nul loop + L := L + 1; + end loop; + + -- Remove trailing NL. + while L > 0 and then (Line (L) = LF or Line (L) = CR) loop + L := L - 1; + end loop; + + if Line (1) = '>' then + Dir_Len := L - 1; + Dir (1 .. Dir_Len) := Line (2 .. L); + else + if To_Obj then + File := new String'(Dir (1 .. Dir_Len) + & Get_Base_Name (Line (1 .. L)) + & Link_Obj_Suffix.all); + else + File := new String'(Substitute (Line (1 .. L))); + end if; + + Filelist.Increment_Last; + Filelist.Table (Filelist.Last) := File; + + Dir_Len := 0; + end if; + end if; + end loop; + if fclose (Stream) /= 0 then + Error ("cannot close " & Filename); + end if; + end Add_File_List; + + function Get_Object_Filename (File : Iir_Design_File) return String + is + Dir : Name_Id; + Name : Name_Id; + begin + Dir := Get_Library_Directory (Get_Library (File)); + Name := Get_Design_File_Filename (File); + return Image (Dir) & Get_Base_Name (Image (Name)) + & Get_Object_Suffix.all; + end Get_Object_Filename; + + Last_Stamp : Time_Stamp_Id; + Last_Stamp_File : Iir; + + function Is_File_Outdated (Design_File : Iir_Design_File) return Boolean + is + use Files_Map; + + Name : Name_Id; + + File : Source_File_Entry; + begin + -- Std.Standard is never outdated. + if Design_File = Std_Package.Std_Standard_File then + return False; + end if; + + Name := Get_Design_File_Filename (Design_File); + declare + Obj_Pathname : String := Get_Object_Filename (Design_File) & Nul; + Stamp : Time_Stamp_Id; + begin + Stamp := Get_File_Time_Stamp (Obj_Pathname'Address); + + -- If the object file does not exist, recompile the file. + if Stamp = Null_Time_Stamp then + if Flag_Verbose then + Put_Line ("no object file for " & Image (Name)); + end if; + return True; + end if; + + -- Keep the time stamp of the most recently analyzed unit. + if Last_Stamp = Null_Time_Stamp + or else Is_Gt (Stamp, Last_Stamp) + then + Last_Stamp := Stamp; + Last_Stamp_File := Design_File; + end if; + end; + + -- 2) file has been modified. + File := Load_Source_File (Get_Design_File_Directory (Design_File), + Get_Design_File_Filename (Design_File)); + if not Is_Eq (Get_File_Time_Stamp (File), + Get_File_Time_Stamp (Design_File)) + then + if Flag_Verbose then + Put_Line ("file " & Image (Get_File_Name (File)) + & " has been modified"); + end if; + return True; + end if; + + return False; + end Is_File_Outdated; + + function Is_Unit_Outdated (Unit : Iir_Design_Unit) return Boolean + is + Design_File : Iir_Design_File; + begin + -- Std.Standard is never outdated. + if Unit = Std_Package.Std_Standard_Unit then + return False; + end if; + + Design_File := Get_Design_File (Unit); + + -- 1) not yet analyzed: + if Get_Date (Unit) not in Date_Valid then + if Flag_Verbose then + Disp_Library_Unit (Get_Library_Unit (Unit)); + Put_Line (" was not analyzed"); + end if; + return True; + end if; + + -- 3) the object file does not exist. + -- Already checked. + + -- 4) one of the dependence is newer + declare + Depends : Iir_List; + El : Iir; + Dep : Iir_Design_Unit; + Stamp : Time_Stamp_Id; + Dep_File : Iir_Design_File; + begin + Depends := Get_Dependence_List (Unit); + Stamp := Get_Analysis_Time_Stamp (Design_File); + if Depends /= Null_Iir_List then + for I in Natural loop + El := Get_Nth_Element (Depends, I); + exit when El = Null_Iir; + Dep := Libraries.Find_Design_Unit (El); + if Dep = Null_Iir then + if Flag_Verbose then + Disp_Library_Unit (Unit); + Put (" depends on an unknown unit "); + Disp_Library_Unit (El); + New_Line; + end if; + return True; + end if; + Dep_File := Get_Design_File (Dep); + if Dep /= Std_Package.Std_Standard_Unit + and then Files_Map.Is_Gt (Get_Analysis_Time_Stamp (Dep_File), + Stamp) + then + if Flag_Verbose then + Disp_Library_Unit (Get_Library_Unit (Unit)); + Put (" depends on: "); + Disp_Library_Unit (Get_Library_Unit (Dep)); + Put (" (more recently analyzed)"); + New_Line; + end if; + return True; + end if; + end loop; + end if; + end; + + return False; + end Is_Unit_Outdated; + + procedure Add_Argument (Inst : in out Instance; Arg : String_Access) + is + begin + Increment_Last (Inst); + Inst.Table (Last (Inst)) := Arg; + end Add_Argument; + + -- Convert option "-Wx,OPTIONS" to arguments for tool X. + procedure Add_Arguments (Inst : in out Instance; Opt : String) is + begin + Add_Argument (Inst, new String'(Opt (Opt'First + 4 .. Opt'Last))); + end Add_Arguments; + + procedure Tool_Not_Found (Name : String) is + begin + Error ("installation problem: " & Name & " not found"); + raise Option_Error; + end Tool_Not_Found; + + -- Set the compiler command according to the configuration (and swicthes). + procedure Set_Tools_Name is + begin + -- Set tools name. + if Compiler_Cmd = null then + case Compile_Kind is + when Compile_Debug => + Compiler_Cmd := new String'(Default_Pathes.Compiler_Debug); + when Compile_Gcc => + Compiler_Cmd := new String'(Default_Pathes.Compiler_Gcc); + when Compile_Mcode => + Compiler_Cmd := new String'(Default_Pathes.Compiler_Mcode); + when Compile_Llvm => + Compiler_Cmd := new String'(Default_Pathes.Compiler_Llvm); + end case; + end if; + if Post_Processor_Cmd = null then + Post_Processor_Cmd := new String'(Default_Pathes.Post_Processor); + end if; + end Set_Tools_Name; + + function Locate_Exec_Tool (Toolname : String) return String_Access is + begin + if Is_Absolute_Path (Toolname) then + if Is_Executable_File (Toolname) then + return new String'(Toolname); + end if; + else + -- Try from install prefix + if Exec_Prefix /= null then + declare + Path : constant String := + Exec_Prefix.all & Directory_Separator & Toolname; + begin + if Is_Executable_File (Path) then + return new String'(Path); + end if; + end; + end if; + + -- Try configured prefix + declare + Path : constant String := + Default_Pathes.Install_Prefix & Directory_Separator & Toolname; + begin + if Is_Executable_File (Path) then + return new String'(Path); + end if; + end; + end if; + + -- Search the basename on path. + declare + Pos : constant Natural := Get_Basename_Pos (Toolname); + begin + if Pos = 0 then + return Locate_Exec_On_Path (Toolname); + else + return Locate_Exec_On_Path (Toolname (Pos .. Toolname'Last)); + end if; + end; + end Locate_Exec_Tool; + + procedure Locate_Tools is + begin + Compiler_Path := Locate_Exec_Tool (Compiler_Cmd.all); + if Compiler_Path = null then + Tool_Not_Found (Compiler_Cmd.all); + end if; + if Compile_Kind >= Compile_Debug then + Post_Processor_Path := Locate_Exec_Tool (Post_Processor_Cmd.all); + if Post_Processor_Path = null then + Tool_Not_Found (Post_Processor_Cmd.all); + end if; + end if; + if Compile_Kind >= Compile_Gcc then + Assembler_Path := Locate_Exec_On_Path (Assembler_Cmd); + if Assembler_Path = null and not Flag_Asm then + Tool_Not_Found (Assembler_Cmd); + end if; + end if; + Linker_Path := Locate_Exec_On_Path (Linker_Cmd); + if Linker_Path = null then + Tool_Not_Found (Linker_Cmd); + end if; + end Locate_Tools; + + procedure Setup_Compiler (Load : Boolean) + is + use Libraries; + begin + Set_Tools_Name; + Setup_Libraries (Load); + Locate_Tools; + for I in 2 .. Get_Nbr_Pathes loop + Add_Argument (Compiler_Args, + new String'("-P" & Image (Get_Path (I)))); + end loop; + end Setup_Compiler; + + type Command_Comp is abstract new Command_Lib with null record; + + -- Setup GHDL. + procedure Init (Cmd : in out Command_Comp); + + -- Handle: + -- all ghdl flags. + -- some GCC flags. + procedure Decode_Option (Cmd : in out Command_Comp; + Option : String; + Arg : String; + Res : out Option_Res); + + procedure Disp_Long_Help (Cmd : Command_Comp); + + procedure Init (Cmd : in out Command_Comp) + is + begin + -- Init options. + Flag_Not_Quiet := False; + Flag_Disp_Commands := False; + Flag_Asm := False; + Flag_Expect_Failure := False; + Output_File := null; + + -- Initialize argument tables. + Init (Compiler_Args); + Init (Postproc_Args); + Init (Assembler_Args); + Init (Linker_Args); + Init (Command_Lib (Cmd)); + end Init; + + procedure Decode_Option (Cmd : in out Command_Comp; + Option : String; + Arg : String; + Res : out Option_Res) + is + Str : String_Access; + Opt : constant String (1 .. Option'Length) := Option; + begin + Res := Option_Bad; + if Opt = "-v" and then Flag_Verbose = False then + -- Note: this is also decoded for command_lib, but we set + -- Flag_Disp_Commands too. + Flag_Verbose := True; + --Flags.Verbose := True; + Flag_Disp_Commands := True; + Res := Option_Ok; + elsif Opt'Length > 8 and then Opt (1 .. 8) = "--GHDL1=" then + Compiler_Cmd := new String'(Opt (9 .. Opt'Last)); + Res := Option_Ok; + elsif Opt = "-S" then + Flag_Asm := True; + Res := Option_Ok; + elsif Opt = "--post" then + Compile_Kind := Compile_Debug; + Res := Option_Ok; + elsif Opt = "--mcode" then + Compile_Kind := Compile_Mcode; + Res := Option_Ok; + elsif Opt = "--llvm" then + Compile_Kind := Compile_Llvm; + Res := Option_Ok; + elsif Opt = "-o" then + if Arg'Length = 0 then + Res := Option_Arg_Req; + else + Output_File := new String'(Arg); + Res := Option_Arg; + end if; + elsif Opt = "-m32" then + Add_Argument (Compiler_Args, new String'("-m32")); + Add_Argument (Assembler_Args, new String'("--32")); + Add_Argument (Linker_Args, new String'("-m32")); + Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); + elsif Opt'Length > 4 + and then Opt (2) = 'W' and then Opt (4) = ',' + then + if Opt (3) = 'c' then + Add_Arguments (Compiler_Args, Opt); + elsif Opt (3) = 'a' then + Add_Arguments (Assembler_Args, Opt); + elsif Opt (3) = 'p' then + Add_Arguments (Postproc_Args, Opt); + elsif Opt (3) = 'l' then + Add_Arguments (Linker_Args, Opt); + else + Error ("unknown tool name in '-W" & Opt (3) & ",' option"); + raise Option_Error; + end if; + Res := Option_Ok; + elsif Opt'Length >= 2 and then Opt (2) = 'g' then + -- Debugging option. + Str := new String'(Opt); + Add_Argument (Compiler_Args, Str); + Add_Argument (Linker_Args, Str); + Res := Option_Ok; + elsif Opt = "-Q" then + Flag_Not_Quiet := True; + Res := Option_Ok; + elsif Opt = "--expect-failure" then + Add_Argument (Compiler_Args, new String'(Opt)); + Flag_Expect_Failure := True; + Res := Option_Ok; + elsif Opt = "-C" then + -- Translate -C into --mb-comments, as gcc already has a definition + -- for -C. Done before Flags.Parse_Option. + Add_Argument (Compiler_Args, new String'("--mb-comments")); + Res := Option_Ok; + elsif Options.Parse_Option (Opt) then + Add_Argument (Compiler_Args, new String'(Opt)); + Res := Option_Ok; + elsif Opt'Length >= 2 + and then (Opt (2) = 'O' or Opt (2) = 'f') + then + -- Optimization option. + -- This is put after Flags.Parse_Option, since it may catch -fxxx + -- options. + Add_Argument (Compiler_Args, new String'(Opt)); + Res := Option_Ok; + else + Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); + end if; + end Decode_Option; + + procedure Disp_Long_Help (Cmd : Command_Comp) is + begin + Disp_Long_Help (Command_Lib (Cmd)); + Put_Line (" -v Be verbose"); + Put_Line (" --GHDL1=PATH Set the path of the ghdl1 compiler"); + Put_Line (" -S Do not assemble"); + Put_Line (" -o FILE Set the name of the output file"); + -- Put_Line (" -m32 Generate 32bit code on 64bit machines"); + Put_Line (" -WX,OPTION Pass OPTION to X, where X is one of"); + Put_Line (" c: compiler, a: assembler, l: linker"); + Put_Line (" -g[XX] Pass debugging option to the compiler"); + Put_Line (" -O[XX]/-f[XX] Pass optimization option to the compiler"); + Put_Line (" -Q Do not add -quiet option to compiler"); + Put_Line (" --expect-failure Expect analysis/elaboration failure"); + end Disp_Long_Help; + + -- Command dispconfig. + type Command_Dispconfig is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Dispconfig; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Dispconfig) return String; + procedure Perform_Action (Cmd : in out Command_Dispconfig; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Dispconfig; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--dispconfig" or else Name = "--disp-config"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Dispconfig) return String + is + pragma Unreferenced (Cmd); + begin + return "--disp-config Disp tools path"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Dispconfig; + Args : Argument_List) + is + use Libraries; + pragma Unreferenced (Cmd); + begin + if Args'Length /= 0 then + Error ("--dispconfig does not accept any argument"); + raise Option_Error; + end if; + + Set_Tools_Name; + Put_Line ("Pathes at configuration:"); + Put ("compiler command: "); + Put_Line (Compiler_Cmd.all); + if Compile_Kind >= Compile_Debug then + Put ("post-processor command: "); + Put_Line (Post_Processor_Cmd.all); + end if; + if Compile_Kind >= Compile_Gcc then + Put ("assembler command: "); + Put_Line (Assembler_Cmd); + end if; + Put ("linker command: "); + Put_Line (Linker_Cmd); + Put_Line ("default lib prefix: " & Default_Pathes.Lib_Prefix); + + New_Line; + + Put ("command line prefix (--PREFIX): "); + if Switch_Prefix_Path = null then + Put_Line ("(not set)"); + else + Put_Line (Switch_Prefix_Path.all); + end if; + + Put ("environment prefix (GHDL_PREFIX): "); + if Prefix_Env = null then + Put_Line ("(not set)"); + else + Put_Line (Prefix_Env.all); + end if; + + Setup_Libraries (False); + + Put ("exec prefix (from program name): "); + if Exec_Prefix = null then + Put_Line ("(not found)"); + else + Put_Line (Exec_Prefix.all); + end if; + + New_Line; + + Put_Line ("library prefix: " & Lib_Prefix_Path.all); + Put ("library directory: "); + Put_Line (Get_Machine_Path_Prefix); + Locate_Tools; + Put ("compiler path: "); + Put_Line (Compiler_Path.all); + if Compile_Kind >= Compile_Debug then + Put ("post-processor path: "); + Put_Line (Post_Processor_Path.all); + end if; + if Compile_Kind >= Compile_Gcc then + Put ("assembler path: "); + Put_Line (Assembler_Path.all); + end if; + Put ("linker path: "); + Put_Line (Linker_Path.all); + + New_Line; + + Put_Line ("default library pathes:"); + for I in 2 .. Get_Nbr_Pathes loop + Put (' '); + Put_Line (Image (Get_Path (I))); + end loop; + end Perform_Action; + + -- Command Analyze. + type Command_Analyze is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Analyze; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Analyze) return String; + procedure Perform_Action (Cmd : in out Command_Analyze; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Analyze; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-a"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Analyze) return String + is + pragma Unreferenced (Cmd); + begin + return "-a [OPTS] FILEs Analyze FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Analyze; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Nil_Opt : Argument_List (2 .. 1); + begin + if Args'Length = 0 then + Error ("no file to analyze"); + raise Option_Error; + end if; + Setup_Compiler (False); + + for I in Args'Range loop + Do_Compile (Nil_Opt, Args (I).all); + end loop; + end Perform_Action; + + -- Elaboration. + + Base_Name : String_Access; + Elab_Name : String_Access; + Filelist_Name : String_Access; + Unit_Name : String_Access; + + procedure Set_Elab_Units (Cmd_Name : String; + Args : Argument_List; + Run_Arg : out Natural) + is + begin + Extract_Elab_Unit (Cmd_Name, Args, Run_Arg); + if Sec_Name = null then + Base_Name := Prim_Name; + Unit_Name := Prim_Name; + else + Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all); + Unit_Name := new String'(Prim_Name.all & '(' & Sec_Name.all & ')'); + end if; + + Elab_Name := new String'(Elab_Prefix & Base_Name.all); + Filelist_Name := null; + + if Output_File = null then + Output_File := new String'(Base_Name.all); + end if; + end Set_Elab_Units; + + procedure Set_Elab_Units (Cmd_Name : String; Args : Argument_List) + is + Next_Arg : Natural; + begin + Set_Elab_Units (Cmd_Name, Args, Next_Arg); + if Next_Arg <= Args'Last then + Error ("too many unit names for command '" & Cmd_Name & "'"); + raise Option_Error; + end if; + end Set_Elab_Units; + + procedure Bind + is + Comp_List : Argument_List (1 .. 4); + begin + Filelist_Name := new String'(Elab_Name.all & List_Suffix); + + Comp_List (1) := new String'("--elab"); + Comp_List (2) := Unit_Name; + Comp_List (3) := new String'("-l"); + Comp_List (4) := Filelist_Name; + Do_Compile (Comp_List, Elab_Name.all); + Free (Comp_List (3)); + Free (Comp_List (1)); + end Bind; + + procedure Bind_Anaelab (Files : Argument_List) + is + Comp_List : Argument_List (1 .. Files'Length + 2); + Index : Natural; + begin + Comp_List (1) := new String'("--anaelab"); + Comp_List (2) := Unit_Name; + Index := 3; + for I in Files'Range loop + Comp_List (Index) := new String'("--ghdl-source=" & Files (I).all); + Index := Index + 1; + end loop; + Do_Compile (Comp_List, Elab_Name.all); + Free (Comp_List (1)); + for I in 3 .. Comp_List'Last loop + Free (Comp_List (I)); + end loop; + end Bind_Anaelab; + + procedure Link (Add_Std : Boolean; + Disp_Only : Boolean) + is + Last_File : Natural; + begin + Link_Obj_Suffix := Get_Object_Suffix; + + -- read files list + if Filelist_Name /= null then + Add_File_List (Filelist_Name.all, True); + end if; + Last_File := Filelist.Last; + Add_File_List (Get_Machine_Path_Prefix & "grt" & List_Suffix, False); + + -- call the linker + declare + P : Natural; + Nbr_Args : constant Natural := Last (Linker_Args) + Filelist.Last + 4; + Args : Argument_List (1 .. Nbr_Args); + Obj_File : String_Access; + Std_File : String_Access; + begin + Obj_File := Append_Suffix (Elab_Name.all, Link_Obj_Suffix.all); + P := 0; + Args (P + 1) := Dash_o; + Args (P + 2) := Output_File; + Args (P + 3) := Obj_File; + P := P + 3; + if Add_Std then + Std_File := new + String'(Get_Machine_Path_Prefix + & Get_Version_Path & Directory_Separator + & "std" & Directory_Separator + & "std_standard" & Link_Obj_Suffix.all); + P := P + 1; + Args (P) := Std_File; + else + Std_File := null; + end if; + + -- Object files of the design. + for I in Filelist.First .. Last_File loop + P := P + 1; + Args (P) := Filelist.Table (I); + end loop; + -- User added options. + for I in First .. Last (Linker_Args) loop + P := P + 1; + Args (P) := Linker_Args.Table (I); + end loop; + -- GRT files (should be the last one, since it contains an + -- optional main). + for I in Last_File + 1 .. Filelist.Last loop + P := P + 1; + Args (P) := Filelist.Table (I); + end loop; + + if Disp_Only then + for I in 3 .. P loop + Put_Line (Args (I).all); + end loop; + else + My_Spawn (Linker_Path.all, Args (1 .. P)); + end if; + + Free (Obj_File); + Free (Std_File); + end; + + for I in Filelist.First .. Filelist.Last loop + Free (Filelist.Table (I)); + end loop; + end Link; + + -- Command Elab. + type Command_Elab is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Elab; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Elab) return String; + procedure Perform_Action (Cmd : in out Command_Elab; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Elab; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-e"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Elab) return String + is + pragma Unreferenced (Cmd); + begin + return "-e [OPTS] UNIT [ARCH] Elaborate UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Elab; Args : Argument_List) + is + pragma Unreferenced (Cmd); + Success : Boolean; + pragma Unreferenced (Success); + begin + Set_Elab_Units ("-e", Args); + Setup_Compiler (False); + + Bind; + if not Flag_Expect_Failure then + Link (Add_Std => True, Disp_Only => False); + end if; + Delete_File (Filelist_Name.all, Success); + end Perform_Action; + + -- Command Run. + type Command_Run is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Run; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Run) return String; + procedure Perform_Action (Cmd : in out Command_Run; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Run; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-r"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Run) return String + is + pragma Unreferenced (Cmd); + begin + return "-r UNIT [ARCH] [OPTS] Run UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Run; Args : Argument_List) + is + pragma Unreferenced (Cmd); + Opt_Arg : Natural; + begin + Extract_Elab_Unit ("-r", Args, Opt_Arg); + if Sec_Name = null then + Base_Name := Prim_Name; + else + Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all); + end if; + if not Is_Regular_File (Base_Name.all & Nul) then + Error ("file '" & Base_Name.all & "' does not exists"); + Error ("Please elaborate your design."); + raise Exec_Error; + end if; + My_Spawn ('.' & Directory_Separator & Base_Name.all, + Args (Opt_Arg .. Args'Last)); + end Perform_Action; + + -- Command Elab_Run. + type Command_Elab_Run is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Elab_Run; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Elab_Run) return String; + procedure Perform_Action (Cmd : in out Command_Elab_Run; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Elab_Run; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--elab-run"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Elab_Run) return String + is + pragma Unreferenced (Cmd); + begin + return "--elab-run [OPTS] UNIT [ARCH] [OPTS] Elaborate and run UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Elab_Run; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Success : Boolean; + Run_Arg : Natural; + begin + Set_Elab_Units ("-elab-run", Args, Run_Arg); + Setup_Compiler (False); + + Bind; + if Flag_Expect_Failure then + Delete_File (Filelist_Name.all, Success); + else + Link (Add_Std => True, Disp_Only => False); + Delete_File (Filelist_Name.all, Success); + My_Spawn ('.' & Directory_Separator & Output_File.all, + Args (Run_Arg .. Args'Last)); + end if; + end Perform_Action; + + -- Command Bind. + type Command_Bind is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Bind; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Bind) return String; + procedure Perform_Action (Cmd : in out Command_Bind; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Bind; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--bind"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Bind) return String + is + pragma Unreferenced (Cmd); + begin + return "--bind [OPTS] UNIT [ARCH] Bind UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Bind; Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + Set_Elab_Units ("--bind", Args); + Setup_Compiler (False); + + Bind; + end Perform_Action; + + -- Command Link. + type Command_Link is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Link; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Link) return String; + procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List); + + function Decode_Command (Cmd : Command_Link; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--link"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Link) return String + is + pragma Unreferenced (Cmd); + begin + return "--link [OPTS] UNIT [ARCH] Link UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + Set_Elab_Units ("--link", Args); + Setup_Compiler (False); + + Filelist_Name := new String'(Elab_Name.all & List_Suffix); + Link (Add_Std => True, Disp_Only => False); + end Perform_Action; + + + -- Command List_Link. + type Command_List_Link is new Command_Comp with null record; + function Decode_Command (Cmd : Command_List_Link; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_List_Link) return String; + procedure Perform_Action (Cmd : in out Command_List_Link; + Args : Argument_List); + + function Decode_Command (Cmd : Command_List_Link; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--list-link"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_List_Link) return String + is + pragma Unreferenced (Cmd); + begin + return "--list-link [OPTS] UNIT [ARCH] List objects file to link UNIT"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_List_Link; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + Set_Elab_Units ("--list-link", Args); + Setup_Compiler (False); + + Filelist_Name := new String'(Elab_Name.all & List_Suffix); + Link (Add_Std => True, Disp_Only => True); + end Perform_Action; + + + -- Command analyze and elaborate + type Command_Anaelab is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Anaelab; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Anaelab) return String; + procedure Decode_Option (Cmd : in out Command_Anaelab; + Option : String; + Arg : String; + Res : out Option_Res); + + procedure Perform_Action (Cmd : in out Command_Anaelab; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Anaelab; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-c"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Anaelab) return String + is + pragma Unreferenced (Cmd); + begin + return "-c [OPTS] FILEs -e UNIT [ARCH] " + & "Generate whole code to elab UNIT from FILEs"; + end Get_Short_Help; + + procedure Decode_Option (Cmd : in out Command_Anaelab; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "-e" then + Res := Option_End; + return; + else + Decode_Option (Command_Comp (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Perform_Action (Cmd : in out Command_Anaelab; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Elab_Index : Integer; + begin + Elab_Index := -1; + for I in Args'Range loop + if Args (I).all = "-e" then + Elab_Index := I; + exit; + end if; + end loop; + if Elab_Index < 0 then + Analyze_Files (Args, True); + else + Flags.Flag_Whole_Analyze := True; + Set_Elab_Units ("-c", Args (Elab_Index + 1 .. Args'Last)); + Setup_Compiler (False); + + Bind_Anaelab (Args (Args'First .. Elab_Index - 1)); + Link (Add_Std => False, Disp_Only => False); + end if; + end Perform_Action; + + -- Command Make. + type Command_Make is new Command_Comp with record + -- Disp dependences during make. + Flag_Depend_Unit : Boolean; + + -- Force recompilation of units in work library. + Flag_Force : Boolean; + end record; + + function Decode_Command (Cmd : Command_Make; Name : String) + return Boolean; + procedure Init (Cmd : in out Command_Make); + procedure Decode_Option (Cmd : in out Command_Make; + Option : String; + Arg : String; + Res : out Option_Res); + + function Get_Short_Help (Cmd : Command_Make) return String; + procedure Disp_Long_Help (Cmd : Command_Make); + + procedure Perform_Action (Cmd : in out Command_Make; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Make; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-m"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Make) return String + is + pragma Unreferenced (Cmd); + begin + return "-m [OPTS] UNIT [ARCH] Make UNIT"; + end Get_Short_Help; + + procedure Disp_Long_Help (Cmd : Command_Make) + is + begin + Disp_Long_Help (Command_Comp (Cmd)); + Put_Line (" -f Force recompilation of work units"); + Put_Line (" -Mu Disp unit dependences (human format)"); + end Disp_Long_Help; + + procedure Init (Cmd : in out Command_Make) is + begin + Init (Command_Comp (Cmd)); + Cmd.Flag_Depend_Unit := False; + Cmd.Flag_Force := False; + end Init; + + procedure Decode_Option (Cmd : in out Command_Make; + Option : String; + Arg : String; + Res : out Option_Res) is + begin + if Option = "-Mu" then + Cmd.Flag_Depend_Unit := True; + Res := Option_Ok; + elsif Option = "-f" then + Cmd.Flag_Force := True; + Res := Option_Ok; + else + Decode_Option (Command_Comp (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List) + is + use Configuration; + + File : Iir_Design_File; + Unit : Iir; + Lib_Unit : Iir; + Lib : Iir_Library_Declaration; + In_Work : Boolean; + + Files_List : Iir_List; + + -- Set when a design file has been compiled. + Has_Compiled : Boolean; + + Need_Analyze : Boolean; + + Need_Elaboration : Boolean; + + Stamp : Time_Stamp_Id; + File_Id : Name_Id; + + Nil_Args : Argument_List (2 .. 1); + Success : Boolean; + begin + Set_Elab_Units ("-m", Args); + Setup_Compiler (True); + + -- Create list of files. + Files_List := Build_Dependence (Prim_Name, Sec_Name); + + if Cmd.Flag_Depend_Unit then + Put_Line ("Units analysis order:"); + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + Put (" "); + Disp_Library_Unit (Get_Library_Unit (Unit)); + New_Line; +-- Put (" file: "); +-- File := Get_Design_File (Unit); +-- Image (Get_Design_File_Filename (File)); +-- Put_Line (Name_Buffer (1 .. Name_Length)); + end loop; + end if; + if Cmd.Flag_Depend_Unit then + Put_Line ("File analysis order:"); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + Image (Get_Design_File_Filename (File)); + Put (" "); + Put (Name_Buffer (1 .. Name_Length)); + if Flag_Verbose then + Put_Line (":"); + declare + Dep_List : Iir_List; + Dep_File : Iir; + begin + Dep_List := Get_File_Dependence_List (File); + if Dep_List /= Null_Iir_List then + for J in Natural loop + Dep_File := Get_Nth_Element (Dep_List, J); + exit when Dep_File = Null_Iir; + Image (Get_Design_File_Filename (Dep_File)); + Put (" "); + Put_Line (Name_Buffer (1 .. Name_Length)); + end loop; + end if; + end; + else + New_Line; + end if; + end loop; + end if; + + Has_Compiled := False; + Last_Stamp := Null_Time_Stamp; + + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + + Need_Analyze := False; + if Is_File_Outdated (File) then + Need_Analyze := True; + else + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + Lib_Unit := Get_Library_Unit (Unit); + if not (Get_Kind (Lib_Unit) = Iir_Kind_Configuration_Declaration + and then Get_Identifier (Lib_Unit) = Null_Identifier) + then + if Is_Unit_Outdated (Unit) then + Need_Analyze := True; + exit; + end if; + end if; + Unit := Get_Chain (Unit); + end loop; + end if; + + Lib := Get_Library (File); + In_Work := Lib = Libraries.Work_Library; + + if Need_Analyze or else (Cmd.Flag_Force and In_Work) then + File_Id := Get_Design_File_Filename (File); + if not Flag_Verbose then + Put ("analyze "); + Put (Image (File_Id)); + --Disp_Library_Unit (Get_Library_Unit (Unit)); + New_Line; + end if; + + if In_Work then + Do_Compile (Nil_Args, Image (File_Id)); + else + declare + use Libraries; + Lib_Args : Argument_List (1 .. 2); + Prev_Workdir : Name_Id; + begin + Prev_Workdir := Work_Directory; + + -- Must be set, since used to build the object filename. + Work_Directory := Get_Library_Directory (Lib); + + -- Always overwrite --work and --workdir. + Lib_Args (1) := new String' + ("--work=" & Image (Get_Identifier (Lib))); + if Work_Directory = Libraries.Local_Directory then + Lib_Args (2) := new String'("--workdir=."); + else + Lib_Args (2) := new String' + ("--workdir=" & Image (Work_Directory)); + end if; + Do_Compile (Lib_Args, Image (File_Id)); + + Work_Directory := Prev_Workdir; + + Free (Lib_Args (1)); + Free (Lib_Args (2)); + end; + end if; + + Has_Compiled := True; + -- Set the analysis time stamp since the file has just been + -- analyzed. + Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp); + end if; + end loop; + + Need_Elaboration := False; + -- Elaboration. + -- if libgrt is more recent than the executable (FIXME). + if Has_Compiled then + if Flag_Verbose then + Put_Line ("link due to a file compilation"); + end if; + Need_Elaboration := True; + else + declare + Exec_File : String := Output_File.all & Nul; + begin + Stamp := Files_Map.Get_File_Time_Stamp (Exec_File'Address); + end; + + if Stamp = Null_Time_Stamp then + if Flag_Verbose then + Put_Line ("link due to no binary file"); + end if; + Need_Elaboration := True; + else + if Files_Map.Is_Gt (Last_Stamp, Stamp) then + -- if a file is more recent than the executable. + if Flag_Verbose then + Put ("link due to outdated binary file: "); + Put (Image (Get_Design_File_Filename (Last_Stamp_File))); + Put (" ("); + Put (Files_Map.Get_Time_Stamp_String (Last_Stamp)); + Put (" > "); + Put (Files_Map.Get_Time_Stamp_String (Stamp)); + Put (")"); + New_Line; + end if; + Need_Elaboration := True; + end if; + end if; + end if; + if Need_Elaboration then + if not Flag_Verbose then + Put ("elaborate "); + Put (Prim_Name.all); + --Disp_Library_Unit (Get_Library_Unit (Unit)); + New_Line; + end if; + Bind; + Link (Add_Std => True, Disp_Only => False); + Delete_File (Filelist_Name.all, Success); + end if; + exception + when Errorout.Compilation_Error => + if Flag_Expect_Failure then + return; + else + raise; + end if; + end Perform_Action; + + -- Command Gen_Makefile. + type Command_Gen_Makefile is new Command_Comp with null record; + function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Gen_Makefile) return String; + procedure Perform_Action (Cmd : in out Command_Gen_Makefile; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--gen-makefile"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Gen_Makefile) return String + is + pragma Unreferenced (Cmd); + begin + return "--gen-makefile [OPTS] UNIT [ARCH] Generate a Makefile for UNIT"; + end Get_Short_Help; + + function Is_Makeable_File (File : Iir_Design_File) return Boolean is + begin + if File = Std_Package.Std_Standard_File then + return False; + end if; + return True; + end Is_Makeable_File; + + procedure Perform_Action (Cmd : in out Command_Gen_Makefile; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + + HT : constant Character := Ada.Characters.Latin_1.HT; + Files_List : Iir_List; + File : Iir_Design_File; + + Lib : Iir_Library_Declaration; + Dir_Id : Name_Id; + + Dep_List : Iir_List; + Dep_File : Iir; + begin + Set_Elab_Units ("--gen-makefile", Args); + Setup_Libraries (True); + Files_List := Build_Dependence (Prim_Name, Sec_Name); + + Put_Line ("# Makefile automatically generated by ghdl"); + Put ("# Version: "); + Put (Version.Ghdl_Release); + Put (" - "); + if Version_String /= null then + Put (Version_String.all); + end if; + New_Line; + Put_Line ("# Command used to generate this makefile:"); + Put ("# "); + Put (Command_Name); + for I in 1 .. Argument_Count loop + Put (' '); + Put (Argument (I)); + end loop; + New_Line; + + New_Line; + + Put ("GHDL="); + Put_Line (Command_Name); + + -- Extract options for command line. + Put ("GHDLFLAGS="); + for I in 2 .. Argument_Count loop + declare + Arg : constant String := Argument (I); + begin + if Arg (1) = '-' then + if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=") + or else (Arg'Length > 7 and then Arg (1 .. 7) = "--ieee=") + or else (Arg'Length > 6 and then Arg (1 .. 6) = "--std=") + or else (Arg'Length > 7 and then Arg (1 .. 7) = "--work=") + or else (Arg'Length > 2 and then Arg (1 .. 2) = "-P") + then + Put (" "); + Put (Arg); + end if; + end if; + end; + end loop; + New_Line; + + New_Line; + + Put_Line ("# Default target"); + Put ("all: "); + Put_Line (Base_Name.all); + New_Line; + + Put_Line ("# Elaboration target"); + Put (Base_Name.all); + Put (":"); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + if Is_Makeable_File (File) then + Put (" "); + Put (Get_Object_Filename (File)); + end if; + end loop; + New_Line; + Put_Line (HT & "$(GHDL) -e $(GHDLFLAGS) $@"); + New_Line; + + Put_Line ("# Run target"); + Put_Line ("run: " & Base_Name.all); + Put_Line (HT & "$(GHDL) -r " & Base_Name.all & " $(GHDLRUNFLAGS)"); + New_Line; + + Put_Line ("# Targets to analyze files"); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + Dir_Id := Get_Design_File_Directory (File); + if not Is_Makeable_File (File) then + -- Builtin file. + null; + else + Put (Get_Object_Filename (File)); + Put (": "); + if Dir_Id /= Files_Map.Get_Home_Directory then + Put (Image (Dir_Id)); + Put (Image (Get_Design_File_Filename (File))); + New_Line; + + Put_Line + (HT & "@echo ""This file was not locally built ($<)"""); + Put_Line (HT & "exit 1"); + else + Put (Image (Get_Design_File_Filename (File))); + New_Line; + + Put (HT & "$(GHDL) -a $(GHDLFLAGS)"); + Lib := Get_Library (File); + if Lib /= Libraries.Work_Library then + -- Overwrite some options. + Put (" --work="); + Put (Image (Get_Identifier (Lib))); + Dir_Id := Get_Library_Directory (Lib); + Put (" --workdir="); + if Dir_Id = Libraries.Local_Directory then + Put ("."); + else + Put (Image (Dir_Id)); + end if; + end if; + Put_Line (" $<"); + end if; + end if; + end loop; + New_Line; + + Put_Line ("# Files dependences"); + for I in Natural loop + File := Get_Nth_Element (Files_List, I); + exit when File = Null_Iir; + if Is_Makeable_File (File) then + Put (Get_Object_Filename (File)); + Put (": "); + Dep_List := Get_File_Dependence_List (File); + if Dep_List /= Null_Iir_List then + for J in Natural loop + Dep_File := Get_Nth_Element (Dep_List, J); + exit when Dep_File = Null_Iir; + if Dep_File /= File and then Is_Makeable_File (Dep_File) + then + Put (" "); + Put (Get_Object_Filename (Dep_File)); + end if; + end loop; + end if; + New_Line; + end if; + end loop; + end Perform_Action; + + procedure Register_Commands is + begin + Register_Command (new Command_Analyze); + Register_Command (new Command_Elab); + Register_Command (new Command_Run); + Register_Command (new Command_Elab_Run); + Register_Command (new Command_Bind); + Register_Command (new Command_Link); + Register_Command (new Command_List_Link); + Register_Command (new Command_Anaelab); + Register_Command (new Command_Make); + Register_Command (new Command_Gen_Makefile); + Register_Command (new Command_Dispconfig); + end Register_Commands; +end Ghdldrv; diff --git a/src/ghdldrv/ghdldrv.ads b/src/ghdldrv/ghdldrv.ads new file mode 100644 index 000000000..3e37b38f1 --- /dev/null +++ b/src/ghdldrv/ghdldrv.ads @@ -0,0 +1,25 @@ +-- GHDL driver - commands invoking gcc. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Ghdldrv is + -- Compiler to use. + type Compile_Kind_Type is + (Compile_Mcode, Compile_Llvm, Compile_Gcc, Compile_Debug); + Compile_Kind : Compile_Kind_Type := Compile_Gcc; + + procedure Register_Commands; +end Ghdldrv; diff --git a/src/ghdldrv/ghdllocal.adb b/src/ghdldrv/ghdllocal.adb new file mode 100644 index 000000000..a1d94bd77 --- /dev/null +++ b/src/ghdldrv/ghdllocal.adb @@ -0,0 +1,1415 @@ +-- GHDL driver - local commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Text_IO; +with Ada.Command_Line; use Ada.Command_Line; +with GNAT.Directory_Operations; +with Types; use Types; +with Libraries; +with Std_Package; +with Flags; +with Name_Table; +with Std_Names; +with Back_End; +with Disp_Vhdl; +with Default_Pathes; +with Scanner; +with Sem; +with Canon; +with Errorout; +with Configuration; +with Files_Map; +with Post_Sems; +with Disp_Tree; +with Options; +with Iirs_Utils; use Iirs_Utils; + +package body Ghdllocal is + -- Version of the IEEE library to use. This just change pathes. + type Ieee_Lib_Kind is (Lib_Standard, Lib_None, Lib_Synopsys, Lib_Mentor); + Flag_Ieee : Ieee_Lib_Kind; + + Flag_Create_Default_Config : constant Boolean := True; + + -- If TRUE, generate 32bits code on 64bits machines. + Flag_32bit : Boolean := False; + + procedure Finish_Compilation + (Unit : Iir_Design_Unit; Main : Boolean := False) + is + use Errorout; + use Ada.Text_IO; + Config : Iir_Design_Unit; + Lib : Iir; + begin + if (Main or Flags.Dump_All) and then Flags.Dump_Parse then + Disp_Tree.Disp_Tree (Unit); + end if; + + if Flags.Verbose then + Put_Line ("semantize " & Disp_Node (Get_Library_Unit (Unit))); + end if; + + Sem.Semantic (Unit); + + if (Main or Flags.Dump_All) and then Flags.Dump_Sem then + Disp_Tree.Disp_Tree (Unit); + end if; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if (Main or Flags.List_All) and then Flags.List_Sem then + Disp_Vhdl.Disp_Vhdl (Unit); + end if; + + Post_Sems.Post_Sem_Checks (Unit); + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if Flags.Flag_Elaborate then + if Flags.Verbose then + Put_Line ("canonicalize " & Disp_Node (Get_Library_Unit (Unit))); + end if; + + Canon.Canonicalize (Unit); + + if Flag_Create_Default_Config then + Lib := Get_Library_Unit (Unit); + if Get_Kind (Lib) = Iir_Kind_Architecture_Body then + Config := Canon.Create_Default_Configuration_Declaration (Lib); + Set_Default_Configuration_Declaration (Lib, Config); + end if; + end if; + end if; + end Finish_Compilation; + + procedure Init (Cmd : in out Command_Lib) + is + pragma Unreferenced (Cmd); + begin + Options.Initialize; + Flag_Ieee := Lib_Standard; + Back_End.Finish_Compilation := Finish_Compilation'Access; + Flag_Verbose := False; + end Init; + + procedure Decode_Option (Cmd : in out Command_Lib; + Option : String; + Arg : String; + Res : out Option_Res) + is + pragma Unreferenced (Cmd); + pragma Unreferenced (Arg); + Opt : constant String (1 .. Option'Length) := Option; + begin + Res := Option_Bad; + if Opt = "-v" and then Flag_Verbose = False then + Flag_Verbose := True; + Res := Option_Ok; + elsif Opt'Length > 9 and then Opt (1 .. 9) = "--PREFIX=" then + Switch_Prefix_Path := new String'(Opt (10 .. Opt'Last)); + Res := Option_Ok; + elsif Opt = "--ieee=synopsys" then + Flag_Ieee := Lib_Synopsys; + Res := Option_Ok; + elsif Opt = "--ieee=mentor" then + Flag_Ieee := Lib_Mentor; + Res := Option_Ok; + elsif Opt = "--ieee=none" then + Flag_Ieee := Lib_None; + Res := Option_Ok; + elsif Opt = "--ieee=standard" then + Flag_Ieee := Lib_Standard; + Res := Option_Ok; + elsif Opt = "-m32" then + Flag_32bit := True; + Res := Option_Ok; + elsif Opt'Length >= 2 + and then (Opt (2) = 'g' or Opt (2) = 'O') + then + -- Silently accept -g and -O. + Res := Option_Ok; + else + if Options.Parse_Option (Opt) then + Res := Option_Ok; + end if; + end if; + end Decode_Option; + + procedure Disp_Long_Help (Cmd : Command_Lib) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + procedure P (Str : String) renames Put_Line; + begin + P ("Main options (try --options-help for details):"); + P (" --std=XX Use XX as VHDL standard (87,93c,93,00 or 02)"); + P (" --work=NAME Set the name of the WORK library"); + P (" -PDIR Add DIR in the library search path"); + P (" --workdir=DIR Specify the directory of the WORK library"); + P (" --PREFIX=DIR Specify installation prefix"); + P (" --ieee=NAME Use NAME as ieee library, where name is:"); + P (" standard: standard version (default)"); + P (" synopsys, mentor: vendor version (not advised)"); + P (" none: do not use a predefined ieee library"); + end Disp_Long_Help; + + function Is_Directory_Separator (C : Character) return Boolean is + begin + return C = '/' or else C = Directory_Separator; + end Is_Directory_Separator; + + function Get_Basename_Pos (Pathname : String) return Natural is + begin + for I in reverse Pathname'Range loop + if Is_Directory_Separator (Pathname (I)) then + return I; + end if; + end loop; + return 0; + end Get_Basename_Pos; + + procedure Set_Prefix_From_Program_Path (Prog_Path : String) + is + Dir_Pos : Natural; + begin + Dir_Pos := Get_Basename_Pos (Prog_Path); + if Dir_Pos = 0 then + -- No directory in Prog_Path. This is not expected. + return; + end if; + + declare + Pathname : String := + Normalize_Pathname (Prog_Path (Dir_Pos + 1 .. Prog_Path'Last), + Prog_Path (Prog_Path'First .. Dir_Pos - 1)); + Pos : Natural; + begin + -- Stop now in case of error. + if Pathname'Length = 0 then + return; + end if; + + -- Skip executable name + Dir_Pos := Get_Basename_Pos (Pathname); + if Dir_Pos = 0 then + return; + end if; + + -- Simplify path: + -- /./ => / + -- // => / + Pos := Dir_Pos - 1; + while Pos >= Pathname'First loop + if Is_Directory_Separator (Pathname (Pos)) then + if Is_Directory_Separator (Pathname (Pos + 1)) then + -- // => / + Pathname (Pos .. Dir_Pos - 1) := + Pathname (Pos + 1 .. Dir_Pos); + Dir_Pos := Dir_Pos - 1; + elsif Pos + 2 <= Dir_Pos + and then Pathname (Pos + 1) = '.' + and then Is_Directory_Separator (Pathname (Pos + 2)) + then + -- /./ => / + Pathname (Pos .. Dir_Pos - 2) := + Pathname (Pos + 2 .. Dir_Pos); + Dir_Pos := Dir_Pos - 2; + end if; + end if; + Pos := Pos - 1; + end loop; + + -- Simplify path: + -- /xxx/../ => / + -- This is done after the previous simplication to avoid to deal + -- with cases like /xxx//../ or /xxx/./../ + Pos := Dir_Pos - 3; + while Pos >= Pathname'First loop + if Is_Directory_Separator (Pathname (Pos)) + and then Pathname (Pos + 1) = '.' + and then Pathname (Pos + 2) = '.' + and then Is_Directory_Separator (Pathname (Pos + 3)) + then + declare + Pos2 : constant Natural := + Get_Basename_Pos (Pathname (Pathname'First .. Pos - 1)); + -- /xxxxxxxxxx/../ + -- ^ ^ + -- Pos2 Pos + Len : Natural; + begin + if Pos2 = 0 then + -- Shouldn't happen. + return; + end if; + Len := Pos + 3 - Pos2; + Pathname (Pos2 + 1 .. Dir_Pos - Len) := + Pathname (Pos + 4 .. Dir_Pos); + Dir_Pos := Dir_Pos - Len; + if Pos2 < Pathname'First + 3 then + exit; + end if; + Pos := Pos2 - 3; + end; + else + Pos := Pos - 1; + end if; + end loop; + + -- Remove last '/' + Dir_Pos := Dir_Pos - 1; + + -- Skip directory. + Dir_Pos := Get_Basename_Pos (Pathname (Pathname'First .. Dir_Pos)); + if Dir_Pos = 0 then + return; + end if; + + Exec_Prefix := new String'(Pathname (Pathname'First .. Dir_Pos - 1)); + end; + end Set_Prefix_From_Program_Path; + + -- Extract Exec_Prefix from executable name. + procedure Set_Exec_Prefix + is + use GNAT.Directory_Operations; + Prog_Path : constant String := Ada.Command_Line.Command_Name; + Exec_Path : String_Access; + begin + -- If the command name is an absolute path, deduce prefix from it. + if Is_Absolute_Path (Prog_Path) then + Set_Prefix_From_Program_Path (Prog_Path); + return; + end if; + + -- If the command name is a relative path, deduce prefix from it + -- and current path. + if Get_Basename_Pos (Prog_Path) /= 0 then + if Is_Executable_File (Prog_Path) then + Set_Prefix_From_Program_Path + (Get_Current_Dir & Directory_Separator & Prog_Path); + end if; + return; + end if; + + -- Look for program name on the path. + Exec_Path := Locate_Exec_On_Path (Prog_Path); + if Exec_Path /= null then + Set_Prefix_From_Program_Path (Exec_Path.all); + Free (Exec_Path); + end if; + end Set_Exec_Prefix; + + function Get_Version_Path return String + is + use Flags; + begin + case Vhdl_Std is + when Vhdl_87 => + return "v87"; + when Vhdl_93c + | Vhdl_93 + | Vhdl_00 + | Vhdl_02 => + return "v93"; + when Vhdl_08 => + return "v08"; + end case; + end Get_Version_Path; + + function Get_Machine_Path_Prefix return String is + begin + if Flag_32bit then + return Lib_Prefix_Path.all & "32"; + else + return Lib_Prefix_Path.all; + end if; + end Get_Machine_Path_Prefix; + + procedure Add_Library_Path (Name : String) + is + begin + Libraries.Add_Library_Path + (Get_Machine_Path_Prefix & Directory_Separator + & Get_Version_Path & Directory_Separator + & Name & Directory_Separator); + end Add_Library_Path; + + procedure Setup_Libraries (Load : Boolean) + is + begin + -- Get environment variable. + Prefix_Env := GNAT.OS_Lib.Getenv ("GHDL_PREFIX"); + if Prefix_Env = null or else Prefix_Env.all = "" then + Prefix_Env := null; + end if; + + -- Compute Exec_Prefix. + Set_Exec_Prefix; + + -- Set prefix path. + -- If not set by command line, try environment variable. + if Switch_Prefix_Path /= null then + Lib_Prefix_Path := Switch_Prefix_Path; + else + Lib_Prefix_Path := Prefix_Env; + end if; + -- Else try default path. + if Lib_Prefix_Path = null then + if Is_Absolute_Path (Default_Pathes.Lib_Prefix) then + Lib_Prefix_Path := new String'(Default_Pathes.Lib_Prefix); + else + if Exec_Prefix /= null then + Lib_Prefix_Path := new + String'(Exec_Prefix.all & Directory_Separator + & Default_Pathes.Lib_Prefix); + end if; + if Lib_Prefix_Path = null + or else not Is_Directory (Lib_Prefix_Path.all) + then + Free (Lib_Prefix_Path); + Lib_Prefix_Path := new + String'(Default_Pathes.Install_Prefix + & Directory_Separator + & Default_Pathes.Lib_Prefix); + end if; + end if; + else + -- Assume the user has set the correct path, so do not insert 32. + Flag_32bit := False; + end if; + + -- Add pathes for predefined libraries. + if not Flags.Bootstrap then + Add_Library_Path ("std"); + case Flag_Ieee is + when Lib_Standard => + Add_Library_Path ("ieee"); + when Lib_Synopsys => + Add_Library_Path ("synopsys"); + when Lib_Mentor => + Add_Library_Path ("mentor"); + when Lib_None => + null; + end case; + end if; + if Load then + Libraries.Load_Std_Library; + Libraries.Load_Work_Library; + end if; + end Setup_Libraries; + + procedure Disp_Library_Unit (Unit : Iir) + is + use Ada.Text_IO; + use Name_Table; + Id : Name_Id; + begin + Id := Get_Identifier (Unit); + case Get_Kind (Unit) is + when Iir_Kind_Entity_Declaration => + Put ("entity "); + when Iir_Kind_Architecture_Body => + Put ("architecture "); + when Iir_Kind_Configuration_Declaration => + Put ("configuration "); + when Iir_Kind_Package_Declaration => + Put ("package "); + when Iir_Kind_Package_Instantiation_Declaration => + Put ("package instance "); + when Iir_Kind_Package_Body => + Put ("package body "); + when others => + Put ("???"); + return; + end case; + Image (Id); + Put (Name_Buffer (1 .. Name_Length)); + case Get_Kind (Unit) is + when Iir_Kind_Architecture_Body => + Put (" of "); + Image (Get_Entity_Identifier_Of_Architecture (Unit)); + Put (Name_Buffer (1 .. Name_Length)); + when Iir_Kind_Configuration_Declaration => + if Id = Null_Identifier then + Put (" of entity "); + Image (Get_Entity_Identifier_Of_Architecture (Unit)); + Put (Name_Buffer (1 .. Name_Length)); + end if; + when others => + null; + end case; + end Disp_Library_Unit; + + procedure Disp_Library (Name : Name_Id) + is + use Ada.Text_IO; + use Libraries; + Lib : Iir_Library_Declaration; + File : Iir_Design_File; + Unit : Iir; + begin + if Name = Std_Names.Name_Work then + Lib := Work_Library; + elsif Name = Std_Names.Name_Std then + Lib := Std_Library; + else + Lib := Get_Library (Name, Command_Line_Location); + end if; + + -- Disp contents of files. + File := Get_Design_File_Chain (Lib); + while File /= Null_Iir loop + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + Disp_Library_Unit (Get_Library_Unit (Unit)); + New_Line; + Unit := Get_Chain (Unit); + end loop; + File := Get_Chain (File); + end loop; + end Disp_Library; + + -- Return FILENAME without the extension. + function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True) + return String + is + First : Natural; + Last : Natural; + begin + First := Filename'First; + Last := Filename'Last; + for I in Filename'Range loop + if Filename (I) = '.' then + Last := I - 1; + elsif Remove_Dir and then Filename (I) = Directory_Separator then + First := I + 1; + Last := Filename'Last; + end if; + end loop; + return Filename (First .. Last); + end Get_Base_Name; + + function Append_Suffix (File : String; Suffix : String) return String_Access + is + use Name_Table; + Basename : constant String := Get_Base_Name (File); + begin + Image (Libraries.Work_Directory); + Name_Buffer (Name_Length + 1 .. Name_Length + Basename'Length) := + Basename; + Name_Length := Name_Length + Basename'Length; + Name_Buffer (Name_Length + 1 .. Name_Length + Suffix'Length) := Suffix; + Name_Length := Name_Length + Suffix'Length; + return new String'(Name_Buffer (1 .. Name_Length)); + end Append_Suffix; + + + -- Command Dir. + type Command_Dir is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean; + function Get_Short_Help (Cmd : Command_Dir) return String; + procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List); + + function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-d" or else Name = "--dir"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Dir) return String + is + pragma Unreferenced (Cmd); + begin + return "-d or --dir Disp contents of the work library"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + if Args'Length /= 0 then + Error ("command '-d' does not accept any argument"); + raise Option_Error; + end if; + + Flags.Bootstrap := True; + -- Load word library. + Libraries.Load_Std_Library; + Libraries.Load_Work_Library; + + Disp_Library (Std_Names.Name_Work); + +-- else +-- for L in Libs'Range loop +-- Id := Get_Identifier (Libs (L).all); +-- Disp_Library (Id); +-- end loop; +-- end if; + end Perform_Action; + + -- Command Find. + type Command_Find is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Find; Name : String) return Boolean; + function Get_Short_Help (Cmd : Command_Find) return String; + procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List); + + function Decode_Command (Cmd : Command_Find; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-f"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Find) return String + is + pragma Unreferenced (Cmd); + begin + return "-f FILEs Disp units in FILES"; + end Get_Short_Help; + + -- Return TRUE is UNIT can be at the apex of a design hierarchy. + function Is_Top_Entity (Unit : Iir) return Boolean + is + begin + if Get_Kind (Unit) /= Iir_Kind_Entity_Declaration then + return False; + end if; + if Get_Port_Chain (Unit) /= Null_Iir then + return False; + end if; + if Get_Generic_Chain (Unit) /= Null_Iir then + return False; + end if; + return True; + end Is_Top_Entity; + + -- Disp contents design files FILES. + procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List) + is + pragma Unreferenced (Cmd); + + use Ada.Text_IO; + use Name_Table; + Id : Name_Id; + Design_File : Iir_Design_File; + Unit : Iir; + Lib : Iir; + Flag_Add : constant Boolean := False; + begin + Flags.Bootstrap := True; + Libraries.Load_Std_Library; + Libraries.Load_Work_Library; + + for I in Args'Range loop + Id := Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + if Design_File /= Null_Iir then + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + Lib := Get_Library_Unit (Unit); + Disp_Library_Unit (Lib); + if Is_Top_Entity (Lib) then + Put (" **"); + end if; + New_Line; + if Flag_Add then + Libraries.Add_Design_Unit_Into_Library (Unit); + end if; + Unit := Get_Chain (Unit); + end loop; + end if; + end loop; + if Flag_Add then + Libraries.Save_Work_Library; + end if; + end Perform_Action; + + -- Command Import. + type Command_Import is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Import; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Import) return String; + procedure Perform_Action (Cmd : in out Command_Import; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Import; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-i"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Import) return String + is + pragma Unreferenced (Cmd); + begin + return "-i [OPTS] FILEs Import units of FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Import; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + Id : Name_Id; + Design_File : Iir_Design_File; + Unit : Iir; + Next_Unit : Iir; + Lib : Iir; + begin + Setup_Libraries (True); + + -- Parse all files. + for I in Args'Range loop + Id := Name_Table.Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + if Design_File /= Null_Iir then + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + if Flag_Verbose then + Lib := Get_Library_Unit (Unit); + Disp_Library_Unit (Lib); + if Is_Top_Entity (Lib) then + Put (" **"); + end if; + New_Line; + end if; + Next_Unit := Get_Chain (Unit); + Set_Chain (Unit, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Unit); + Unit := Next_Unit; + end loop; + end if; + end loop; + + -- Analyze all files. + if False then + Design_File := Get_Design_File_Chain (Libraries.Work_Library); + while Design_File /= Null_Iir loop + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + case Get_Date (Unit) is + when Date_Valid + | Date_Analyzed => + null; + when Date_Parsed => + Back_End.Finish_Compilation (Unit, False); + when others => + raise Internal_Error; + end case; + Unit := Get_Chain (Unit); + end loop; + Design_File := Get_Chain (Design_File); + end loop; + end if; + + Libraries.Save_Work_Library; + exception + when Errorout.Compilation_Error => + Error ("importation has failed due to compilation error"); + raise; + end Perform_Action; + + -- Command Check_Syntax. + type Command_Check_Syntax is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Check_Syntax; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Check_Syntax) return String; + procedure Perform_Action (Cmd : in out Command_Check_Syntax; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Check_Syntax; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-s"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Check_Syntax) return String + is + pragma Unreferenced (Cmd); + begin + return "-s [OPTS] FILEs Check syntax of FILEs"; + end Get_Short_Help; + + procedure Analyze_One_File (File_Name : String) + is + use Ada.Text_IO; + Id : Name_Id; + Design_File : Iir_Design_File; + Unit : Iir; + Next_Unit : Iir; + begin + Id := Name_Table.Get_Identifier (File_Name); + if Flag_Verbose then + Put (File_Name); + Put_Line (":"); + end if; + Design_File := Libraries.Load_File (Id); + if Design_File = Null_Iir then + raise Errorout.Compilation_Error; + end if; + + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + if Flag_Verbose then + Put (' '); + Disp_Library_Unit (Get_Library_Unit (Unit)); + New_Line; + end if; + -- Sem, canon, annotate a design unit. + Back_End.Finish_Compilation (Unit, True); + + Next_Unit := Get_Chain (Unit); + if Errorout.Nbr_Errors = 0 then + Set_Chain (Unit, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Unit); + end if; + + Unit := Next_Unit; + end loop; + + if Errorout.Nbr_Errors > 0 then + raise Errorout.Compilation_Error; + end if; + end Analyze_One_File; + + procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) is + begin + Setup_Libraries (True); + + -- Parse all files. + for I in Files'Range loop + Analyze_One_File (Files (I).all); + end loop; + + if Save_Library then + Libraries.Save_Work_Library; + end if; + end Analyze_Files; + + procedure Perform_Action (Cmd : in out Command_Check_Syntax; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + Analyze_Files (Args, False); + end Perform_Action; + + -- Command --clean: remove object files. + type Command_Clean is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean; + function Get_Short_Help (Cmd : Command_Clean) return String; + procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List); + + function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--clean"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Clean) return String + is + pragma Unreferenced (Cmd); + begin + return "--clean Remove generated files"; + end Get_Short_Help; + + procedure Delete (Str : String) + is + use Ada.Text_IO; + Status : Boolean; + begin + Delete_File (Str'Address, Status); + if Flag_Verbose and Status then + Put_Line ("delete " & Str (Str'First .. Str'Last - 1)); + end if; + end Delete; + + procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Name_Table; + + procedure Delete_Asm_Obj (Str : String) is + begin + Delete (Str & Get_Object_Suffix.all & Nul); + Delete (Str & Asm_Suffix & Nul); + end Delete_Asm_Obj; + + procedure Delete_Top_Unit (Str : String) is + begin + -- Delete elaboration file + Delete_Asm_Obj (Image (Libraries.Work_Directory) & Elab_Prefix & Str); + + -- Delete file list. + Delete (Image (Libraries.Work_Directory) & Str & List_Suffix & Nul); + + -- Delete executable. + Delete (Str & Nul); + end Delete_Top_Unit; + + File : Iir_Design_File; + Design_Unit : Iir_Design_Unit; + Lib_Unit : Iir; + Str : String_Access; + begin + if Args'Length /= 0 then + Error ("command '--clean' does not accept any argument"); + raise Option_Error; + end if; + + Flags.Bootstrap := True; + -- Load libraries. + Libraries.Load_Std_Library; + Libraries.Load_Work_Library; + + File := Get_Design_File_Chain (Libraries.Work_Library); + while File /= Null_Iir loop + -- Delete compiled file. + Str := Append_Suffix (Image (Get_Design_File_Filename (File)), ""); + Delete_Asm_Obj (Str.all); + Free (Str); + + Design_Unit := Get_First_Design_Unit (File); + while Design_Unit /= Null_Iir loop + Lib_Unit := Get_Library_Unit (Design_Unit); + case Get_Kind (Lib_Unit) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Configuration_Declaration => + Delete_Top_Unit (Image (Get_Identifier (Lib_Unit))); + when Iir_Kind_Architecture_Body => + Delete_Top_Unit + (Image (Get_Entity_Identifier_Of_Architecture (Lib_Unit)) + & '-' + & Image (Get_Identifier (Lib_Unit))); + when others => + null; + end case; + Design_Unit := Get_Chain (Design_Unit); + end loop; + File := Get_Chain (File); + end loop; + end Perform_Action; + + -- Command --remove: remove object file and library file. + type Command_Remove is new Command_Clean with null record; + function Decode_Command (Cmd : Command_Remove; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Remove) return String; + procedure Perform_Action (Cmd : in out Command_Remove; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Remove; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--remove"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Remove) return String + is + pragma Unreferenced (Cmd); + begin + return "--remove Remove generated files and library file"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Remove; Args : Argument_List) + is + use Name_Table; + begin + if Args'Length /= 0 then + Error ("command '--remove' does not accept any argument"); + raise Option_Error; + end if; + Perform_Action (Command_Clean (Cmd), Args); + Delete (Image (Libraries.Work_Directory) + & Back_End.Library_To_File_Name (Libraries.Work_Library) + & Nul); + end Perform_Action; + + -- Command --copy: copy work library to current directory. + type Command_Copy is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean; + function Get_Short_Help (Cmd : Command_Copy) return String; + procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List); + + function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--copy"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Copy) return String + is + pragma Unreferenced (Cmd); + begin + return "--copy Copy work library to current directory"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Name_Table; + use Libraries; + + File : Iir_Design_File; + Dir : Name_Id; + begin + if Args'Length /= 0 then + Error ("command '--copy' does not accept any argument"); + raise Option_Error; + end if; + + Setup_Libraries (False); + Libraries.Load_Std_Library; + Dir := Work_Directory; + Work_Directory := Null_Identifier; + Libraries.Load_Work_Library; + Work_Directory := Dir; + + Dir := Get_Library_Directory (Libraries.Work_Library); + if Dir = Name_Nil or else Dir = Files_Map.Get_Home_Directory then + Error ("cannot copy library on itself (use --remove first)"); + raise Option_Error; + end if; + + File := Get_Design_File_Chain (Libraries.Work_Library); + while File /= Null_Iir loop + -- Copy object files (if any). + declare + Basename : constant String := + Get_Base_Name (Image (Get_Design_File_Filename (File))); + Src : String_Access; + Dst : String_Access; + Success : Boolean; + pragma Unreferenced (Success); + begin + Src := new String'(Image (Dir) & Basename & Get_Object_Suffix.all); + Dst := new String'(Basename & Get_Object_Suffix.all); + Copy_File (Src.all, Dst.all, Success, Overwrite, Full); + -- Be silent in case of error. + Free (Src); + Free (Dst); + end; + if Get_Design_File_Directory (File) = Name_Nil then + Set_Design_File_Directory (File, Dir); + end if; + + File := Get_Chain (File); + end loop; + Libraries.Work_Directory := Name_Nil; + Libraries.Save_Work_Library; + end Perform_Action; + + -- Command --disp-standard. + type Command_Disp_Standard is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Disp_Standard; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Disp_Standard) return String; + procedure Perform_Action (Cmd : in out Command_Disp_Standard; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Disp_Standard; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--disp-standard"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Disp_Standard) return String + is + pragma Unreferenced (Cmd); + begin + return "--disp-standard Disp std.standard in pseudo-vhdl"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Disp_Standard; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + if Args'Length /= 0 then + Error ("command '--disp-standard' does not accept any argument"); + raise Option_Error; + end if; + Flags.Bootstrap := True; + Libraries.Load_Std_Library; + Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit); + end Perform_Action; + + procedure Load_All_Libraries_And_Files + is + use Files_Map; + use Libraries; + use Errorout; + + procedure Extract_Library_Clauses (Unit : Iir_Design_Unit) + is + Lib1 : Iir_Library_Declaration; + pragma Unreferenced (Lib1); + Ctxt_Item : Iir; + begin + -- Extract library clauses. + Ctxt_Item := Get_Context_Items (Unit); + while Ctxt_Item /= Null_Iir loop + if Get_Kind (Ctxt_Item) = Iir_Kind_Library_Clause then + Lib1 := Get_Library (Get_Identifier (Ctxt_Item), + Get_Location (Ctxt_Item)); + end if; + Ctxt_Item := Get_Chain (Ctxt_Item); + end loop; + end Extract_Library_Clauses; + + Lib : Iir_Library_Declaration; + Fe : Source_File_Entry; + File, Next_File : Iir_Design_File; + Unit, Next_Unit : Iir_Design_Unit; + Design_File : Iir_Design_File; + + Old_Work : Iir_Library_Declaration; + begin + Lib := Std_Library; + Lib := Get_Chain (Lib); + Old_Work := Work_Library; + while Lib /= Null_Iir loop + -- Design units are always put in the work library. + Work_Library := Lib; + + File := Get_Design_File_Chain (Lib); + while File /= Null_Iir loop + Next_File := Get_Chain (File); + Fe := Load_Source_File (Get_Design_File_Directory (File), + Get_Design_File_Filename (File)); + if Fe = No_Source_File_Entry then + -- FIXME: should remove all the design file from the library. + null; + elsif Is_Eq (Get_File_Time_Stamp (Fe), + Get_File_Time_Stamp (File)) + then + -- File has not been modified. + -- Extract libraries. + -- Note: we can't parse it only, since we need to keep the + -- date. + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + Load_Parse_Design_Unit (Unit, Null_Iir); + Extract_Library_Clauses (Unit); + Unit := Get_Chain (Unit); + end loop; + else + -- File has been modified. + -- Parse it. + Design_File := Load_File (Fe); + + -- Exit now in case of parse error. + if Design_File = Null_Iir + or else Nbr_Errors > 0 + then + raise Compilation_Error; + end if; + + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + Extract_Library_Clauses (Unit); + + Next_Unit := Get_Chain (Unit); + Set_Chain (Unit, Null_Iir); + Add_Design_Unit_Into_Library (Unit); + Unit := Next_Unit; + end loop; + end if; + File := Next_File; + end loop; + Lib := Get_Chain (Lib); + end loop; + Work_Library := Old_Work; + end Load_All_Libraries_And_Files; + + procedure Check_No_Elab_Flag (Lib : Iir_Library_Declaration) + is + File : Iir_Design_File; + Unit : Iir_Design_Unit; + begin + File := Get_Design_File_Chain (Lib); + while File /= Null_Iir loop + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + if Get_Elab_Flag (Unit) then + raise Internal_Error; + end if; + Unit := Get_Chain (Unit); + end loop; + File := Get_Chain (File); + end loop; + end Check_No_Elab_Flag; + + function Build_Dependence (Prim : String_Access; Sec : String_Access) + return Iir_List + is + procedure Build_Dependence_List (File : Iir_Design_File; List : Iir_List) + is + El : Iir_Design_File; + Depend_List : Iir_List; + begin + if Get_Elab_Flag (File) then + return; + end if; + + Set_Elab_Flag (File, True); + Depend_List := Get_File_Dependence_List (File); + if Depend_List /= Null_Iir_List then + for I in Natural loop + El := Get_Nth_Element (Depend_List, I); + exit when El = Null_Iir; + Build_Dependence_List (El, List); + end loop; + end if; + Append_Element (List, File); + end Build_Dependence_List; + + use Configuration; + use Name_Table; + + Top : Iir; + Primary_Id : Name_Id; + Secondary_Id : Name_Id; + + File : Iir_Design_File; + Unit : Iir; + + Files_List : Iir_List; + begin + Check_No_Elab_Flag (Libraries.Work_Library); + + Primary_Id := Get_Identifier (Prim.all); + if Sec /= null then + Secondary_Id := Get_Identifier (Sec.all); + else + Secondary_Id := Null_Identifier; + end if; + + if True then + Load_All_Libraries_And_Files; + else + -- Re-parse modified files in order configure could find all design + -- units. + declare + use Files_Map; + Fe : Source_File_Entry; + Next_File : Iir_Design_File; + Design_File : Iir_Design_File; + begin + File := Get_Design_File_Chain (Libraries.Work_Library); + while File /= Null_Iir loop + Next_File := Get_Chain (File); + Fe := Load_Source_File (Get_Design_File_Directory (File), + Get_Design_File_Filename (File)); + if Fe = No_Source_File_Entry then + -- FIXME: should remove all the design file from + -- the library. + null; + else + if not Is_Eq (Get_File_Time_Stamp (Fe), + Get_File_Time_Stamp (File)) + then + -- FILE has been modified. + Design_File := Libraries.Load_File (Fe); + if Design_File /= Null_Iir then + Libraries.Add_Design_File_Into_Library (Design_File); + end if; + end if; + end if; + File := Next_File; + end loop; + end; + end if; + + Flags.Flag_Elaborate := True; + Flags.Flag_Elaborate_With_Outdated := True; + Flag_Load_All_Design_Units := True; + Flag_Build_File_Dependence := True; + + Top := Configure (Primary_Id, Secondary_Id); + if Top = Null_Iir then + --Error ("cannot find primary unit " & Prim.all); + raise Option_Error; + end if; + + -- Add unused design units. + declare + N : Natural; + begin + N := Design_Units.First; + while N <= Design_Units.Last loop + Unit := Design_Units.Table (N); + N := N + 1; + File := Get_Design_File (Unit); + if not Get_Elab_Flag (File) then + Set_Elab_Flag (File, True); + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + if not Get_Elab_Flag (Unit) then + Add_Design_Unit (Unit, Null_Iir); + end if; + Unit := Get_Chain (Unit); + end loop; + end if; + end loop; + end; + + -- Clear elab flag on design files. + for I in reverse Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + File := Get_Design_File (Unit); + Set_Elab_Flag (File, False); + end loop; + + -- Create a list of files, from the last to the first. + Files_List := Create_Iir_List; + for I in Design_Units.First .. Design_Units.Last loop + Unit := Design_Units.Table (I); + File := Get_Design_File (Unit); + Build_Dependence_List (File, Files_List); + end loop; + + return Files_List; + end Build_Dependence; + + -- Convert NAME to lower cases, unless it is an extended identifier. + function Convert_Name (Name : String_Access) return String_Access + is + use Name_Table; + + function Is_Bad_Unit_Name return Boolean is + begin + if Name_Length = 0 then + return True; + end if; + -- Don't try to handle extended identifier. + if Name_Buffer (1) = '\' then + return False; + end if; + -- Look for suspicious characters. + -- Do not try to be exhaustive as the correct check will be done + -- by convert_identifier. + for I in 1 .. Name_Length loop + case Name_Buffer (I) is + when '.' | '/' | '\' => + return True; + when others => + null; + end case; + end loop; + return False; + end Is_Bad_Unit_Name; + + function Is_A_File_Name return Boolean is + begin + -- Check .vhd + if Name_Length > 4 + and then Name_Buffer (Name_Length - 3 .. Name_Length) = ".vhd" + then + return True; + end if; + -- Check .vhdl + if Name_Length > 5 + and then Name_Buffer (Name_Length - 4 .. Name_Length) = ".vhdl" + then + return True; + end if; + -- Check ../ + if Name_Length > 3 + and then Name_Buffer (1 .. 3) = "../" + then + return True; + end if; + -- Check ..\ + if Name_Length > 3 + and then Name_Buffer (1 .. 3) = "..\" + then + return True; + end if; + -- Should try to find the file ? + return False; + end Is_A_File_Name; + begin + Name_Length := Name'Length; + Name_Buffer (1 .. Name_Length) := Name.all; + + -- Try to identifier bad names (such as file names), so that + -- friendly message can be displayed. + if Is_Bad_Unit_Name then + Errorout.Error_Msg_Option_NR ("bad unit name '" & Name.all & "'"); + if Is_A_File_Name then + Errorout.Error_Msg_Option_NR + ("(a unit name is required instead of a filename)"); + end if; + raise Option_Error; + end if; + Scanner.Convert_Identifier; + return new String'(Name_Buffer (1 .. Name_Length)); + end Convert_Name; + + procedure Extract_Elab_Unit + (Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural) + is + begin + if Args'Length = 0 then + Error ("command '" & Cmd_Name & "' required an unit name"); + raise Option_Error; + end if; + + Prim_Name := Convert_Name (Args (Args'First)); + Next_Arg := Args'First + 1; + Sec_Name := null; + + if Args'Length >= 2 then + declare + Sec : constant String_Access := Args (Next_Arg); + begin + if Sec (Sec'First) /= '-' then + Sec_Name := Convert_Name (Sec); + Next_Arg := Args'First + 2; + end if; + end; + end if; + end Extract_Elab_Unit; + + procedure Register_Commands is + begin + Register_Command (new Command_Import); + Register_Command (new Command_Check_Syntax); + Register_Command (new Command_Dir); + Register_Command (new Command_Find); + Register_Command (new Command_Clean); + Register_Command (new Command_Remove); + Register_Command (new Command_Copy); + Register_Command (new Command_Disp_Standard); + end Register_Commands; +end Ghdllocal; diff --git a/src/ghdldrv/ghdllocal.ads b/src/ghdldrv/ghdllocal.ads new file mode 100644 index 000000000..2c7018adc --- /dev/null +++ b/src/ghdldrv/ghdllocal.ads @@ -0,0 +1,116 @@ +-- GHDL driver - local commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Ghdlmain; use Ghdlmain; +with Iirs; use Iirs; + +package Ghdllocal is + type Command_Lib is abstract new Command_Type with null record; + + -- Setup GHDL. + procedure Init (Cmd : in out Command_Lib); + + -- Handle: + -- --std=xx, --work=xx, -Pxxx, --workdir=x, --ieee=x, -Px, and -v + procedure Decode_Option (Cmd : in out Command_Lib; + Option : String; + Arg : String; + Res : out Option_Res); + + -- Disp detailled help. + procedure Disp_Long_Help (Cmd : Command_Lib); + + -- Value of --PREFIX + Switch_Prefix_Path : String_Access := null; + + -- getenv ("GHDL_PREFIX"). Set by Setup_Libraries. + Prefix_Env : String_Access := null; + + -- Installation prefix (deduced from executable path). + Exec_Prefix : String_Access; + + -- Path prefix for libraries. + Lib_Prefix_Path : String_Access := null; + + -- Set with -v option. + Flag_Verbose : Boolean := False; + + -- Suffix for asm files. + Asm_Suffix : constant String := ".s"; + + -- Suffix for llvm byte-code files. + Llvm_Suffix : constant String := ".bc"; + + -- Suffix for post files. + Post_Suffix : constant String := ".on"; + + -- Suffix for list files. + List_Suffix : constant String := ".lst"; + + -- Prefix for elab files. + Elab_Prefix : constant String := "e~"; + + Nul : constant Character := Character'Val (0); + + -- Return FILENAME without the extension. + function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True) + return String; + + -- Get the position of the last directory separator or 0 if none. + function Get_Basename_Pos (Pathname : String) return Natural; + + function Append_Suffix (File : String; Suffix : String) + return String_Access; + + -- Return TRUE is UNIT can be at the apex of a design hierarchy. + function Is_Top_Entity (Unit : Iir) return Boolean; + + -- Display the name of library unit UNIT. + procedure Disp_Library_Unit (Unit : Iir); + + -- Translate vhdl version into a path element. + -- Used to search Std and IEEE libraries. + function Get_Version_Path return String; + + -- Get Prefix_Path, but with 32 added if -m32 is requested + function Get_Machine_Path_Prefix return String; + + -- Setup standard libaries path. If LOAD is true, then load them now. + procedure Setup_Libraries (Load : Boolean); + + -- Setup library, analyze FILES, and if SAVE_LIBRARY is set save the + -- work library only + procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean); + + -- Load and parse all libraries and files, starting from the work library. + -- The work library must already be loaded. + -- Raise errorout.compilation_error in case of error (parse error). + procedure Load_All_Libraries_And_Files; + + function Build_Dependence (Prim : String_Access; Sec : String_Access) + return Iir_List; + + Prim_Name : String_Access; + Sec_Name : String_Access; + + -- Set PRIM_NAME and SEC_NAME. + procedure Extract_Elab_Unit + (Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural); + + procedure Register_Commands; +end Ghdllocal; diff --git a/src/ghdldrv/ghdlmain.adb b/src/ghdldrv/ghdlmain.adb new file mode 100644 index 000000000..45d9615f9 --- /dev/null +++ b/src/ghdldrv/ghdlmain.adb @@ -0,0 +1,359 @@ +-- GHDL driver - main part. +-- Copyright (C) 2002 - 2010 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Text_IO; +with Ada.Command_Line; +with Version; +with Bug; +with Options; + +package body Ghdlmain is + procedure Init (Cmd : in out Command_Type) + is + pragma Unreferenced (Cmd); + begin + null; + end Init; + + procedure Decode_Option (Cmd : in out Command_Type; + Option : String; + Arg : String; + Res : out Option_Res) + is + pragma Unreferenced (Cmd); + pragma Unreferenced (Option); + pragma Unreferenced (Arg); + begin + Res := Option_Bad; + end Decode_Option; + + procedure Disp_Long_Help (Cmd : Command_Type) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + begin + Put_Line ("This command does not accept options."); + end Disp_Long_Help; + + First_Cmd : Command_Acc := null; + Last_Cmd : Command_Acc := null; + + procedure Register_Command (Cmd : Command_Acc) is + begin + if First_Cmd = null then + First_Cmd := Cmd; + else + Last_Cmd.Next := Cmd; + end if; + Last_Cmd := Cmd; + end Register_Command; + + -- Find the command. + function Find_Command (Action : String) return Command_Acc + is + Cmd : Command_Acc; + begin + Cmd := First_Cmd; + while Cmd /= null loop + if Decode_Command (Cmd.all, Action) then + return Cmd; + end if; + Cmd := Cmd.Next; + end loop; + return null; + end Find_Command; + + -- Command help. + type Command_Help is new Command_Type with null record; + function Decode_Command (Cmd : Command_Help; Name : String) return Boolean; + procedure Decode_Option (Cmd : in out Command_Help; + Option : String; + Arg : String; + Res : out Option_Res); + + function Get_Short_Help (Cmd : Command_Help) return String; + procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List); + + function Decode_Command (Cmd : Command_Help; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-h" or else Name = "--help"; + end Decode_Command; + + procedure Decode_Option (Cmd : in out Command_Help; + Option : String; + Arg : String; + Res : out Option_Res) + is + pragma Unreferenced (Cmd); + pragma Unreferenced (Option); + pragma Unreferenced (Arg); + begin + Res := Option_End; + end Decode_Option; + + function Get_Short_Help (Cmd : Command_Help) return String + is + pragma Unreferenced (Cmd); + begin + return "-h or --help [CMD] Disp this help or [help on CMD]"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List) + is + pragma Unreferenced (Cmd); + + use Ada.Text_IO; + use Ada.Command_Line; + C : Command_Acc; + begin + if Args'Length = 0 then + Put_Line ("usage: " & Command_Name & " COMMAND [OPTIONS] ..."); + Put_Line ("COMMAND is one of:"); + C := First_Cmd; + while C /= null loop + Put_Line (Get_Short_Help (C.all)); + C := C.Next; + end loop; + New_Line; + Put_Line ("To display the options of a GHDL program,"); + Put_Line (" run your program with the --help option."); + Put_Line ("Also see --options-help for analyzer options."); + New_Line; + Put_Line ("Please, refer to the GHDL manual for more information."); + Put_Line ("Report bugs on http://gna.org/projects/ghdl"); + elsif Args'Length = 1 then + C := Find_Command (Args (1).all); + if C = null then + Error ("Command '" & Args (1).all & "' is unknown."); + raise Option_Error; + end if; + Put_Line (Get_Short_Help (C.all)); + Disp_Long_Help (C.all); + else + Error ("Command '--help' accepts at most one argument."); + raise Option_Error; + end if; + end Perform_Action; + + -- Command options help. + type Command_Option_Help is new Command_Type with null record; + function Decode_Command (Cmd : Command_Option_Help; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Option_Help) return String; + procedure Perform_Action (Cmd : in out Command_Option_Help; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Option_Help; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--options-help"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Option_Help) return String + is + pragma Unreferenced (Cmd); + begin + return "--options-help Disp help for analyzer options"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Option_Help; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + if Args'Length /= 0 then + Error + ("warning: command '--option-help' does not accept any argument"); + end if; + Options.Disp_Options_Help; + end Perform_Action; + + -- Command Version + type Command_Version is new Command_Type with null record; + function Decode_Command (Cmd : Command_Version; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Version) return String; + procedure Perform_Action (Cmd : in out Command_Version; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Version; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-v" or Name = "--version"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Version) return String + is + pragma Unreferenced (Cmd); + begin + return "-v or --version Disp ghdl version"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Version; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + begin + Put_Line (Version.Ghdl_Release); + Put_Line (" Compiled with " & Bug.Get_Gnat_Version); + if Version_String /= null then + Put (" "); + Put (Version_String.all); + end if; + New_Line; + Put_Line ("Written by Tristan Gingold."); + New_Line; + -- Display copyright. Assume 80 cols terminal. + Put_Line ("Copyright (C) 2003 - 2014 Tristan Gingold."); + Put_Line ("GHDL is free software, covered by the " + & "GNU General Public License. There is NO"); + Put_Line ("warranty; not even for MERCHANTABILITY or" + & " FITNESS FOR A PARTICULAR PURPOSE."); + if Args'Length /= 0 then + Error ("warning: command '--version' does not accept any argument"); + end if; + end Perform_Action; + + -- Disp MSG on the standard output with the command name. + procedure Error (Msg : String) + is + use Ada.Command_Line; + use Ada.Text_IO; + begin + Put (Standard_Error, Command_Name); + Put (Standard_Error, ": "); + Put_Line (Standard_Error, Msg); + --Has_Error := True; + end Error; + + procedure Main + is + use Ada.Command_Line; + Cmd : Command_Acc; + Arg_Index : Natural; + First_Arg : Natural; + + begin + if Argument_Count = 0 then + Error ("missing command, try " & Command_Name & " --help"); + raise Option_Error; + end if; + + Cmd := Find_Command (Argument (1)); + if Cmd = null then + Error ("unknown command '" & Argument (1) & "', try --help"); + raise Option_Error; + end if; + + Init (Cmd.all); + + -- decode options. + + First_Arg := 0; + Arg_Index := 2; + while Arg_Index <= Argument_Count loop + declare + Arg : constant String := Argument (Arg_Index); + Res : Option_Res; + begin + if Arg (1) = '-' then + -- Argument is an option. + + if First_Arg > 0 then + Error ("options after file"); + raise Option_Error; + end if; + + Decode_Option (Cmd.all, Arg, "", Res); + case Res is + when Option_Bad => + Error ("unknown option '" & Arg & "' for command '" + & Argument (1) & "'"); + raise Option_Error; + when Option_Ok => + Arg_Index := Arg_Index + 1; + when Option_Arg_Req => + if Arg_Index + 1 > Argument_Count then + Error ("option '" & Arg & "' requires an argument"); + raise Option_Error; + end if; + Decode_Option + (Cmd.all, Arg, Argument (Arg_Index + 1), Res); + if Res /= Option_Arg then + raise Program_Error; + end if; + Arg_Index := Arg_Index + 2; + when Option_Arg => + raise Program_Error; + when Option_End => + First_Arg := Arg_Index; + exit; + end case; + else + First_Arg := Arg_Index; + exit; + end if; + end; + end loop; + + if First_Arg = 0 then + First_Arg := Argument_Count + 1; + end if; + + declare + Args : Argument_List (1 .. Argument_Count - First_Arg + 1); + begin + for I in Args'Range loop + Args (I) := new String'(Argument (First_Arg + I - 1)); + end loop; + Perform_Action (Cmd.all, Args); + for I in Args'Range loop + Free (Args (I)); + end loop; + end; + --if Flags.Dump_Stats then + -- Name_Table.Disp_Stats; + -- Iirs.Disp_Stats; + --end if; + Set_Exit_Status (Success); + exception + when Option_Error + | Compile_Error + | Errorout.Compilation_Error => + Set_Exit_Status (Failure); + when Exec_Error => + Set_Exit_Status (3); + when E: others => + Bug.Disp_Bug_Box (E); + Set_Exit_Status (2); + end Main; + + procedure Register_Commands is + begin + Register_Command (new Command_Help); + Register_Command (new Command_Version); + Register_Command (new Command_Option_Help); + end Register_Commands; +end Ghdlmain; + diff --git a/src/ghdldrv/ghdlmain.ads b/src/ghdldrv/ghdlmain.ads new file mode 100644 index 000000000..c01f1d63e --- /dev/null +++ b/src/ghdldrv/ghdlmain.ads @@ -0,0 +1,85 @@ +-- GHDL driver - main part. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Errorout; + +package Ghdlmain is + type Command_Type; + + type Command_Acc is access all Command_Type'Class; + + type Command_Type is abstract tagged record + Next : Command_Acc; + end record; + + -- Return TRUE iff CMD handle action ACTION. + function Decode_Command (Cmd : Command_Type; Name : String) return Boolean + is abstract; + + -- Initialize the command, before decoding actions. + procedure Init (Cmd : in out Command_Type); + + -- Option_OK: OPTION is handled. + -- Option_Bad: OPTION is unknown. + -- Option_Arg_Req: OPTION requires an argument. Must be set only when + -- ARG = "", the manager will recall Decode_Option. + -- Option_Arg: OPTION used the argument. + type Option_Res is + (Option_Bad, Option_Ok, Option_Arg, Option_Arg_Req, Option_End); + procedure Decode_Option (Cmd : in out Command_Type; + Option : String; + Arg : String; + Res : out Option_Res); + + -- Get a one-line help for the command. + function Get_Short_Help (Cmd : Command_Type) return String + is abstract; + + -- Disp detailled help. + procedure Disp_Long_Help (Cmd : Command_Type); + + -- Perform the action. + procedure Perform_Action (Cmd : in out Command_Type; Args : Argument_List) + is abstract; + + -- Register a command. + procedure Register_Command (Cmd : Command_Acc); + + -- Disp MSG on the standard output with the command name. + procedure Error (Msg : String); + + -- May be raise by perform_action if the arguments are bad. + Option_Error : exception renames Errorout.Option_Error; + + -- Action failed. + Compile_Error : exception; + + -- Exec failed: either the program was not found, or failed. + Exec_Error : exception; + + procedure Main; + + -- Additionnal one-line message displayed by the --version command, + -- if defined. + -- Used to customize. + type String_Cst_Acc is access constant String; + Version_String : String_Cst_Acc := null; + + -- Registers all commands in this package. + procedure Register_Commands; +end Ghdlmain; diff --git a/src/ghdldrv/ghdlprint.adb b/src/ghdldrv/ghdlprint.adb new file mode 100644 index 000000000..45e70e118 --- /dev/null +++ b/src/ghdldrv/ghdlprint.adb @@ -0,0 +1,1757 @@ +-- GHDL driver - print commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Characters.Latin_1; +with Ada.Text_IO; use Ada.Text_IO; +with GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Table; +with Types; use Types; +with Flags; +with Name_Table; use Name_Table; +with Files_Map; +with Libraries; +with Errorout; use Errorout; +with Iirs; use Iirs; +with Iirs_Utils; use Iirs_Utils; +with Tokens; +with Scanner; +with Parse; +with Version; +with Xrefs; +with Ghdlmain; use Ghdlmain; +with Ghdllocal; use Ghdllocal; +with Disp_Vhdl; +with Back_End; + +package body Ghdlprint is + type Html_Format_Type is (Html_2, Html_Css); + Html_Format : Html_Format_Type := Html_2; + + procedure Put_Html (C : Character) is + begin + case C is + when '>' => + Put (">"); + when '<' => + Put ("<"); + when '&' => + Put ("&"); + when others => + Put (C); + end case; + end Put_Html; + + procedure Put_Html (S : String) is + begin + for I in S'Range loop + Put_Html (S (I)); + end loop; + end Put_Html; + + package Nat_IO is new Ada.Text_IO.Integer_IO (Num => Natural); + procedure Put_Nat (N : Natural) is + begin + Nat_IO.Put (N, Width => 0); + end Put_Nat; + + type Filexref_Info_Type is record + Output : String_Acc; + Referenced : Boolean; + end record; + type Filexref_Info_Arr is array (Source_File_Entry range <>) + of Filexref_Info_Type; + type Filexref_Info_Arr_Acc is access Filexref_Info_Arr; + Filexref_Info : Filexref_Info_Arr_Acc := null; + + -- If True, at least one xref is missing. + Missing_Xref : Boolean := False; + + procedure PP_Html_File (File : Source_File_Entry) + is + use Flags; + use Scanner; + use Tokens; + use Files_Map; + use Ada.Characters.Latin_1; + + Line : Natural; + Buf : File_Buffer_Acc; + Prev_Tok : Token_Type; + + -- Current logical column number. Used to expand TABs. + Col : Natural; + + -- Position just after the last token. + Last_Tok : Source_Ptr; + + -- Position just before the current token. + Bef_Tok : Source_Ptr; + + -- Position just after the current token. + Aft_Tok : Source_Ptr; + + procedure Disp_Ln + is + N : Natural; + Str : String (1 .. 5); + begin + case Html_Format is + when Html_2 => + Put (""); + when Html_Css => + Put (""); + end case; + N := Line; + for I in reverse Str'Range loop + if N = 0 then + Str (I) := ' '; + else + Str (I) := Character'Val (48 + N mod 10); + N := N / 10; + end if; + end loop; + Put (Str); + case Html_Format is + when Html_2 => + Put (""); + when Html_Css => + Put (""); + end case; + Put (" "); + Col := 0; + end Disp_Ln; + + procedure Disp_Spaces + is + C : Character; + P : Source_Ptr; + N_Col : Natural; + begin + P := Last_Tok; + while P < Bef_Tok loop + C := Buf (P); + if C = HT then + -- Expand TABS. + N_Col := Col + 8; + N_Col := N_Col - N_Col mod 8; + while Col < N_Col loop + Put (' '); + Col := Col + 1; + end loop; + else + Put (' '); + Col := Col + 1; + end if; + P := P + 1; + end loop; + end Disp_Spaces; + + procedure Disp_Text + is + P : Source_Ptr; + begin + P := Bef_Tok; + while P < Aft_Tok loop + Put_Html (Buf (P)); + Col := Col + 1; + P := P + 1; + end loop; + end Disp_Text; + + procedure Disp_Reserved is + begin + Disp_Spaces; + case Html_Format is + when Html_2 => + Put (""); + Disp_Text; + Put (""); + when Html_Css => + Put (""); + Disp_Text; + Put (""); + end case; + end Disp_Reserved; + + procedure Disp_Href (Loc : Location_Type) + is + L_File : Source_File_Entry; + L_Pos : Source_Ptr; + begin + Location_To_File_Pos (Loc, L_File, L_Pos); + Put (" href="""); + if L_File /= File then + -- External reference. + if Filexref_Info (L_File).Output /= null then + Put (Filexref_Info (L_File).Output.all); + Put ("#"); + Put_Nat (Natural (L_Pos)); + else + -- Reference to an unused file. + Put ("index.html#f"); + Put_Nat (Natural (L_File)); + Filexref_Info (L_File).Referenced := True; + end if; + else + -- Local reference. + Put ("#"); + Put_Nat (Natural (L_Pos)); + end if; + Put (""""); + end Disp_Href; + + procedure Disp_Anchor (Loc : Location_Type) + is + L_File : Source_File_Entry; + L_Pos : Source_Ptr; + begin + Put (" name="""); + Location_To_File_Pos (Loc, L_File, L_Pos); + Put_Nat (Natural (L_Pos)); + Put (""""); + end Disp_Anchor; + + procedure Disp_Identifier + is + use Xrefs; + Ref : Xref; + Decl : Iir; + Bod : Iir; + Loc : Location_Type; + begin + Disp_Spaces; + if Flags.Flag_Xref then + Loc := File_Pos_To_Location (File, Bef_Tok); + Ref := Find (Loc); + if Ref = Bad_Xref then + Disp_Text; + Warning_Msg_Sem ("cannot find xref", Loc); + Missing_Xref := True; + return; + end if; + else + Disp_Text; + return; + end if; + case Get_Xref_Kind (Ref) is + when Xref_Decl => + Put (" + Bod := Get_Subprogram_Body (Decl); + when Iir_Kind_Package_Declaration => + Bod := Get_Package_Body (Decl); + when Iir_Kind_Type_Declaration => + Decl := Get_Type (Decl); + case Get_Kind (Decl) is + when Iir_Kind_Protected_Type_Declaration => + Bod := Get_Protected_Type_Body (Decl); + when Iir_Kind_Incomplete_Type_Definition => + Bod := Get_Type_Declarator (Decl); + when others => + Bod := Null_Iir; + end case; + when others => + Bod := Null_Iir; + end case; + if Bod /= Null_Iir then + Disp_Href (Get_Location (Bod)); + end if; + Put (">"); + Disp_Text; + Put (""); + when Xref_Ref + | Xref_End => + Decl := Get_Xref_Node (Ref); + Loc := Get_Location (Decl); + if Loc /= Location_Nil then + Put (""); + Disp_Text; + Put (""); + else + -- This may happen for overload list, in use clauses. + Disp_Text; + end if; + when Xref_Body => + Put (""); + Disp_Text; + Put (""); + end case; + end Disp_Identifier; + + procedure Disp_Attribute + is + use Xrefs; + Ref : Xref; + Decl : Iir; + Loc : Location_Type; + begin + Disp_Spaces; + if Flags.Flag_Xref then + Loc := File_Pos_To_Location (File, Bef_Tok); + Ref := Find (Loc); + else + Ref := Bad_Xref; + end if; + if Ref = Bad_Xref then + case Html_Format is + when Html_2 => + Put (""); + Disp_Text; + Put (""); + when Html_Css => + Put (""); + Disp_Text; + Put (""); + end case; + else + Decl := Get_Xref_Node (Ref); + Loc := Get_Location (Decl); + Put (""); + Disp_Text; + Put (""); + end if; + end Disp_Attribute; + begin + Scanner.Flag_Comment := True; + Scanner.Flag_Newline := True; + + Set_File (File); + Buf := Get_File_Source (File); + + Put_Line ("
");
+      Line := 1;
+      Disp_Ln;
+      Last_Tok := Source_Ptr_Org;
+      Prev_Tok := Tok_Invalid;
+      loop
+         Scan;
+         Bef_Tok := Get_Token_Position;
+         Aft_Tok := Get_Position;
+         case Current_Token is
+            when Tok_Eof =>
+               exit;
+            when Tok_Newline =>
+               New_Line;
+               Line := Line + 1;
+               Disp_Ln;
+            when Tok_Comment =>
+               Disp_Spaces;
+               case Html_Format is
+                  when Html_2 =>
+                     Put ("");
+                     Disp_Text;
+                     Put ("");
+                  when Html_Css =>
+                     Put ("");
+                     Disp_Text;
+                     Put ("");
+               end case;
+            when Tok_Access .. Tok_Elsif
+              | Tok_Entity .. Tok_With
+              | Tok_Mod .. Tok_Rem
+              | Tok_And .. Tok_Not =>
+               Disp_Reserved;
+            when Tok_End =>
+               Disp_Reserved;
+            when Tok_Semi_Colon =>
+               Disp_Spaces;
+               Disp_Text;
+            when Tok_Xnor .. Tok_Ror =>
+               Disp_Reserved;
+            when Tok_Protected =>
+               Disp_Reserved;
+            when Tok_Across .. Tok_Tolerance =>
+               Disp_Reserved;
+            when Tok_Psl_Default
+              | Tok_Psl_Clock
+              | Tok_Psl_Property
+              | Tok_Psl_Sequence
+              | Tok_Psl_Endpoint
+              | Tok_Psl_Assert
+              | Tok_Psl_Cover
+              | Tok_Psl_Boolean
+              | Tok_Psl_Const
+              | Tok_Inf
+              | Tok_Within
+              | Tok_Abort
+              | Tok_Before
+              | Tok_Always
+              | Tok_Never
+              | Tok_Eventually
+              | Tok_Next_A
+              | Tok_Next_E
+              | Tok_Next_Event
+              | Tok_Next_Event_A
+              | Tok_Next_Event_E =>
+               Disp_Spaces;
+               Disp_Text;
+            when Tok_String
+              | Tok_Bit_String
+              | Tok_Character =>
+               Disp_Spaces;
+               case Html_Format is
+                  when Html_2 =>
+                     Put ("");
+                     Disp_Text;
+                     Put ("");
+                  when Html_Css =>
+                     Put ("");
+                     Disp_Text;
+                     Put ("");
+               end case;
+            when Tok_Identifier =>
+               if Prev_Tok = Tok_Tick then
+                  Disp_Attribute;
+               else
+                  Disp_Identifier;
+               end if;
+            when Tok_Left_Paren .. Tok_Colon
+              | Tok_Comma .. Tok_Dot
+              | Tok_Equal_Equal
+              | Tok_Integer
+              | Tok_Real
+              | Tok_Equal .. Tok_Slash
+              | Tok_Invalid =>
+               Disp_Spaces;
+               Disp_Text;
+         end case;
+         Last_Tok := Aft_Tok;
+         Prev_Tok := Current_Token;
+      end loop;
+      Close_File;
+      New_Line;
+      Put_Line ("
"); + Put_Line ("
"); + end PP_Html_File; + + procedure Put_Html_Header + is + begin + Put (""); + Put_Line (" "); + case Html_Format is + when Html_2 => + null; + when Html_Css => + Put_Line (" "); + end case; + --Put_Line (""); + --Put_Line(""); + --Put_Line (""); + --Put_Line (""); + end Put_Html_Header; + + procedure Put_Css is + begin + Put_Line ("/* EM is used for reserved words */"); + Put_Line ("EM { color : red; font-style: normal }"); + New_Line; + Put_Line ("/* TT is used for comments */"); + Put_Line ("TT { color : green; font-style: normal }"); + New_Line; + Put_Line ("/* KBD is used for literals and strings */"); + Put_Line ("KBD { color : blue; font-style: normal }"); + New_Line; + Put_Line ("/* I is used for line numbers */"); + Put_Line ("I { color : gray; font-size: 50% }"); + New_Line; + Put_Line ("/* VAR is used for attributes name */"); + Put_Line ("VAR { color : orange; font-style: normal }"); + New_Line; + Put_Line ("/* A is used for identifiers. */"); + Put_Line ("A { color: blue; font-style: normal;"); + Put_Line (" text-decoration: none }"); + end Put_Css; + + procedure Put_Html_Foot + is + begin + Put_Line ("

"); + Put ("This page was generated using "); + Put (""); + Put (Version.Ghdl_Release); + Put (", a program written by"); + Put (" Tristan Gingold"); + New_Line; + Put_Line ("

"); + Put_Line (""); + Put_Line (""); + end Put_Html_Foot; + + function Create_Output_Filename (Name : String; Num : Natural) + return String_Acc + is + -- Position of the extension. 0 if none. + Ext_Pos : Natural; + + Num_Str : String := Natural'Image (Num); + begin + -- Search for the extension. + Ext_Pos := 0; + for I in reverse Name'Range loop + exit when Name (I) = Directory_Separator; + if Name (I) = '.' then + Ext_Pos := I - 1; + exit; + end if; + end loop; + if Ext_Pos = 0 then + Ext_Pos := Name'Last; + end if; + Num_Str (1) := '.'; + return new String'(Name (Name'First .. Ext_Pos) & Num_Str & ".html"); + end Create_Output_Filename; + + -- Command --chop. + type Command_Chop is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Chop; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Chop) return String; + procedure Perform_Action (Cmd : in out Command_Chop; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Chop; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--chop"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Chop) return String + is + pragma Unreferenced (Cmd); + begin + return "--chop [OPTS] FILEs Chop FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Chop; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Ada.Characters.Latin_1; + + function Build_File_Name_Length (Lib : Iir) return Natural + is + Id : constant Name_Id := Get_Identifier (Lib); + Len : Natural; + Id1 : Name_Id; + begin + Len := Get_Name_Length (Id); + case Get_Kind (Lib) is + when Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + null; + when Iir_Kind_Package_Body => + Len := Len + 1 + 4; -- add -body + when Iir_Kind_Architecture_Body => + Id1 := Get_Entity_Identifier_Of_Architecture (Lib); + Len := Len + 1 + Get_Name_Length (Id1); + when others => + Error_Kind ("build_file_name", Lib); + end case; + Len := Len + 1 + 4; -- add .vhdl + return Len; + end Build_File_Name_Length; + + procedure Build_File_Name (Lib : Iir; Res : out String) + is + Id : constant Name_Id := Get_Identifier (Lib); + P : Natural; + + procedure Append (Str : String) is + begin + Res (P + 1 .. P + Str'Length) := Str; + P := P + Str'Length; + end Append; + begin + P := Res'First - 1; + case Get_Kind (Lib) is + when Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + Image (Id); + Append (Name_Buffer (1 .. Name_Length)); + when Iir_Kind_Package_Body => + Image (Id); + Append (Name_Buffer (1 .. Name_Length)); + Append ("-body"); + when Iir_Kind_Architecture_Body => + Image (Get_Entity_Identifier_Of_Architecture (Lib)); + Append (Name_Buffer (1 .. Name_Length)); + Append ("-"); + Image (Id); + Append (Name_Buffer (1 .. Name_Length)); + when others => + raise Internal_Error; + end case; + Append (".vhdl"); + end Build_File_Name; + + -- Scan source file BUF+START until end of line. + -- Return line kind to KIND and position of next line to NEXT. + type Line_Type is (Line_Blank, Line_Comment, Line_Text); + procedure Find_Eol (Buf : File_Buffer_Acc; + Start : Source_Ptr; + Next : out Source_Ptr; + Kind : out Line_Type) + is + P : Source_Ptr; + begin + P := Start; + + Kind := Line_Blank; + + -- Skip blanks. + while Buf (P) = ' ' or Buf (P) = HT loop + P := P + 1; + end loop; + + -- Skip comment if any. + if Buf (P) = '-' and Buf (P + 1) = '-' then + Kind := Line_Comment; + P := P + 2; + elsif Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT then + Kind := Line_Text; + end if; + + -- Skip until end of line. + while Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT loop + P := P + 1; + end loop; + + if Buf (P) = CR then + P := P + 1; + if Buf (P) = LF then + P := P + 1; + end if; + elsif Buf (P) = LF then + P := P + 1; + if Buf (P) = CR then + P := P + 1; + end if; + end if; + + Next := P; + end Find_Eol; + + Id : Name_Id; + Design_File : Iir_Design_File; + Unit : Iir; + Lib : Iir; + Len : Natural; + begin + Flags.Bootstrap := True; + -- Load word library. + Libraries.Load_Std_Library; + Libraries.Load_Work_Library; + + -- First loop: parse source file, check destination file does not + -- exist. + for I in Args'Range loop + Id := Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + if Design_File = Null_Iir then + raise Compile_Error; + end if; + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + Lib := Get_Library_Unit (Unit); + Len := Build_File_Name_Length (Lib); + declare + Filename : String (1 .. Len + 1); + begin + Build_File_Name (Lib, Filename); + Filename (Len + 1) := Ghdllocal.Nul; + if Is_Regular_File (Filename) then + Error ("file '" & Filename (1 .. Len) & "' already exists"); + raise Compile_Error; + end if; + Put (Filename (1 .. Len)); + Put (" (for "); + Disp_Library_Unit (Lib); + Put (")"); + New_Line; + end; + Unit := Get_Chain (Unit); + end loop; + end loop; + + -- Second loop: do the real work. + for I in Args'Range loop + Id := Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + Unit := Get_First_Design_Unit (Design_File); + declare + use Files_Map; + + File_Entry : Source_File_Entry; + Buffer : File_Buffer_Acc; + + Start : Source_Ptr; + Lend : Source_Ptr; + First : Source_Ptr; + Next : Source_Ptr; + Kind : Line_Type; + begin + -- A design_file must have at least one design unit. + if Unit = Null_Iir then + raise Compile_Error; + end if; + + Location_To_File_Pos + (Get_Location (Unit), File_Entry, Start); + Buffer := Get_File_Source (File_Entry); + + First := Source_Ptr_Org; + if Get_Chain (Unit) /= Null_Iir then + -- If there is only one unit, then the whole file is written. + -- First last blank line. + Next := Source_Ptr_Org; + loop + Start := Next; + Find_Eol (Buffer, Start, Next, Kind); + exit when Kind = Line_Text; + if Kind = Line_Blank then + First := Next; + end if; + end loop; + + -- FIXME: write header. + end if; + + while Unit /= Null_Iir loop + Lib := Get_Library_Unit (Unit); + + Location_To_File_Pos + (Get_End_Location (Unit), File_Entry, Lend); + if Lend < First then + raise Internal_Error; + end if; + + Location_To_File_Pos + (Get_End_Location (Unit), File_Entry, Lend); + -- Find the ';'. + while Buffer (Lend) /= ';' loop + Lend := Lend + 1; + end loop; + Lend := Lend + 1; + -- Find end of line. + Find_Eol (Buffer, Lend, Next, Kind); + if Kind = Line_Text then + -- There is another unit on the same line. + Next := Lend; + -- Skip blanks. + while Buffer (Next) = ' ' or Buffer (Next) = HT loop + Next := Next + 1; + end loop; + else + -- Find first blank line. + loop + Start := Next; + Find_Eol (Buffer, Start, Next, Kind); + exit when Kind /= Line_Comment; + end loop; + if Kind = Line_Text then + -- There is not blank lines. + -- All the comments are supposed to belong to the next + -- unit. + Find_Eol (Buffer, Lend, Next, Kind); + Lend := Next; + else + Lend := Start; + end if; + end if; + + if Get_Chain (Unit) = Null_Iir then + -- Last unit. + -- Put the end of the file in it. + Lend := Get_File_Length (File_Entry); + end if; + + -- FIXME: file with only one unit. + -- FIXME: set extension. + Len := Build_File_Name_Length (Lib); + declare + Filename : String (1 .. Len + 1); + Fd : File_Descriptor; + + Wlen : Integer; + begin + Build_File_Name (Lib, Filename); + Filename (Len + 1) := Character'Val (0); + Fd := Create_File (Filename, Binary); + if Fd = Invalid_FD then + Error + ("cannot create file '" & Filename (1 .. Len) & "'"); + raise Compile_Error; + end if; + Wlen := Integer (Lend - First); + if Write (Fd, Buffer (First)'Address, Wlen) /= Wlen then + Error ("cannot write to '" & Filename (1 .. Len) & "'"); + raise Compile_Error; + end if; + Close (Fd); + end; + First := Next; + + Unit := Get_Chain (Unit); + end loop; + end; + end loop; + end Perform_Action; + + -- Command --lines. + type Command_Lines is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Lines; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Lines) return String; + procedure Perform_Action (Cmd : in out Command_Lines; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Lines; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--lines"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Lines) return String + is + pragma Unreferenced (Cmd); + begin + return "--lines FILEs Precede line with its number"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Lines; Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Scanner; + use Tokens; + use Files_Map; + use Ada.Characters.Latin_1; + + Id : Name_Id; + Fe : Source_File_Entry; + Local_Id : Name_Id; + Line : Natural; + File : Source_File_Entry; + Buf : File_Buffer_Acc; + Ptr : Source_Ptr; + Eptr : Source_Ptr; + C : Character; + N : Natural; + Log : Natural; + Str : String (1 .. 10); + begin + Local_Id := Get_Identifier (""); + for I in Args'Range loop + -- Load the file. + Id := Get_Identifier (Args (I).all); + Fe := Files_Map.Load_Source_File (Local_Id, Id); + if Fe = No_Source_File_Entry then + Error ("cannot open file " & Args (I).all); + raise Compile_Error; + end if; + Set_File (Fe); + + -- Scan the content, to compute the number of lines. + loop + Scan; + exit when Current_Token = Tok_Eof; + end loop; + File := Get_Current_Source_File; + Line := Get_Current_Line; + Close_File; + + -- Compute log10 of line. + N := Line; + Log := 0; + loop + N := N / 10; + Log := Log + 1; + exit when N = 0; + end loop; + + -- Disp file name. + Put (Args (I).all); + Put (':'); + New_Line; + + Buf := Get_File_Source (File); + for J in 1 .. Line loop + Ptr := Line_To_Position (File, J); + exit when Ptr = Source_Ptr_Bad; + exit when Buf (Ptr) = Files_Map.EOT; + + -- Disp line number. + N := J; + for K in reverse 1 .. Log loop + if N = 0 then + Str (K) := ' '; + else + Str (K) := Character'Val (48 + N mod 10); + N := N / 10; + end if; + end loop; + Put (Str (1 .. Log)); + Put (": "); + + -- Search for end of line (or end of file). + Eptr := Ptr; + loop + C := Buf (Eptr); + exit when C = Files_Map.EOT or C = LF or C = CR; + Eptr := Eptr + 1; + end loop; + + -- Disp line. + if Eptr > Ptr then + -- Avoid constraint error on conversion of nul array. + Put (String (Buf (Ptr .. Eptr - 1))); + end if; + New_Line; + end loop; + end loop; + end Perform_Action; + + -- Command Reprint. + type Command_Reprint is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Reprint; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Reprint) return String; + procedure Perform_Action (Cmd : in out Command_Reprint; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Reprint; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--reprint"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Reprint) return String + is + pragma Unreferenced (Cmd); + begin + return "--reprint [OPTS] FILEs Redisplay FILEs"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Reprint; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + Design_File : Iir_Design_File; + Unit : Iir; + + Id : Name_Id; + Next_Unit : Iir; + begin + Setup_Libraries (True); + Parse.Flag_Parse_Parenthesis := True; + + -- Parse all files. + for I in Args'Range loop + Id := Name_Table.Get_Identifier (Args (I).all); + Design_File := Libraries.Load_File (Id); + if Design_File = Null_Iir then + raise Errorout.Compilation_Error; + end if; + + Unit := Get_First_Design_Unit (Design_File); + while Unit /= Null_Iir loop + -- Analyze the design unit. + Back_End.Finish_Compilation (Unit, True); + + Next_Unit := Get_Chain (Unit); + if Errorout.Nbr_Errors = 0 then + Disp_Vhdl.Disp_Vhdl (Unit); + Set_Chain (Unit, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Unit); + end if; + + Unit := Next_Unit; + end loop; + + if Errorout.Nbr_Errors > 0 then + raise Errorout.Compilation_Error; + end if; + end loop; + end Perform_Action; + + -- Command compare tokens. + type Command_Compare_Tokens is new Command_Lib with null record; + function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Compare_Tokens) return String; + procedure Perform_Action (Cmd : in out Command_Compare_Tokens; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--compare-tokens"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Compare_Tokens) return String + is + pragma Unreferenced (Cmd); + begin + return "--compare-tokens [OPTS] REF FILEs Compare FILEs with REF"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Compare_Tokens; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Tokens; + use Scanner; + + package Ref_Tokens is new GNAT.Table + (Table_Component_Type => Token_Type, + Table_Index_Type => Integer, + Table_Low_Bound => 0, + Table_Initial => 1024, + Table_Increment => 100); + + Id : Name_Id; + Fe : Source_File_Entry; + Local_Id : Name_Id; + Tok_Idx : Natural; + begin + if Args'Length < 1 then + Error ("missing ref file"); + raise Compile_Error; + end if; + + Local_Id := Get_Identifier (""); + + for I in Args'Range loop + -- Load the file. + Id := Get_Identifier (Args (I).all); + Fe := Files_Map.Load_Source_File (Local_Id, Id); + if Fe = No_Source_File_Entry then + Error ("cannot open file " & Args (I).all); + raise Compile_Error; + end if; + Set_File (Fe); + + if I = Args'First then + -- Scan ref file + loop + Scan; + Ref_Tokens.Append (Current_Token); + exit when Current_Token = Tok_Eof; + end loop; + else + -- Scane file + Tok_Idx := Ref_Tokens.First; + loop + Scan; + if Ref_Tokens.Table (Tok_Idx) /= Current_Token then + Error_Msg_Parse ("token mismatch"); + exit; + end if; + case Current_Token is + when Tok_Eof => + exit; + when others => + null; + end case; + Tok_Idx := Tok_Idx + 1; + end loop; + end if; + Close_File; + end loop; + + Ref_Tokens.Free; + + if Nbr_Errors /= 0 then + raise Compilation_Error; + end if; + end Perform_Action; + + -- Command html. + type Command_Html is abstract new Command_Lib with null record; + + procedure Decode_Option (Cmd : in out Command_Html; + Option : String; + Arg : String; + Res : out Option_Res); + + procedure Disp_Long_Help (Cmd : Command_Html); + + procedure Decode_Option (Cmd : in out Command_Html; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "--format=css" then + Html_Format := Html_Css; + Res := Option_Ok; + elsif Option = "--format=html2" then + Html_Format := Html_2; + Res := Option_Ok; + else + Decode_Option (Command_Lib (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Disp_Long_Help (Cmd : Command_Html) is + begin + Disp_Long_Help (Command_Lib (Cmd)); + Put_Line ("--format=html2 Use FONT attributes"); + Put_Line ("--format=css Use ghdl.css file"); + end Disp_Long_Help; + + -- Command --pp-html. + type Command_PP_Html is new Command_Html with null record; + function Decode_Command (Cmd : Command_PP_Html; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_PP_Html) return String; + procedure Perform_Action (Cmd : in out Command_PP_Html; + Files : Argument_List); + + function Decode_Command (Cmd : Command_PP_Html; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--pp-html"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_PP_Html) return String + is + pragma Unreferenced (Cmd); + begin + return "--pp-html FILEs Pretty-print FILEs in HTML"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_PP_Html; + Files : Argument_List) + is + pragma Unreferenced (Cmd); + use Scanner; + use Tokens; + use Files_Map; + use Ada.Characters.Latin_1; + + Id : Name_Id; + Fe : Source_File_Entry; + Local_Id : Name_Id; + begin + Local_Id := Get_Identifier (""); + Put_Html_Header; + Put_Line (" "); + for I in Files'Range loop + Put (" "); + Put_Line (Files (I).all); + end loop; + Put_Line (" "); + Put_Line (""); + New_Line; + Put_Line (""); + + for I in Files'Range loop + Id := Get_Identifier (Files (I).all); + Fe := Files_Map.Load_Source_File (Local_Id, Id); + if Fe = No_Source_File_Entry then + Error ("cannot open file " & Files (I).all); + raise Compile_Error; + end if; + Put ("

"); + Put (Files (I).all); + Put ("

"); + New_Line; + + PP_Html_File (Fe); + end loop; + Put_Html_Foot; + end Perform_Action; + + -- Command --xref-html. + type Command_Xref_Html is new Command_Html with record + Output_Dir : String_Access := null; + Check_Missing : Boolean := False; + end record; + + function Decode_Command (Cmd : Command_Xref_Html; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Xref_Html) return String; + procedure Decode_Option (Cmd : in out Command_Xref_Html; + Option : String; + Arg : String; + Res : out Option_Res); + procedure Disp_Long_Help (Cmd : Command_Xref_Html); + + procedure Perform_Action (Cmd : in out Command_Xref_Html; + Files_Name : Argument_List); + + function Decode_Command (Cmd : Command_Xref_Html; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--xref-html"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Xref_Html) return String + is + pragma Unreferenced (Cmd); + begin + return "--xref-html FILEs Display FILEs in HTML with xrefs"; + end Get_Short_Help; + + procedure Decode_Option (Cmd : in out Command_Xref_Html; + Option : String; + Arg : String; + Res : out Option_Res) + is + begin + if Option = "-o" then + if Arg = "" then + Res := Option_Arg_Req; + else + Cmd.Output_Dir := new String'(Arg); + Res := Option_Arg; + end if; + elsif Option = "--check-missing" then + Cmd.Check_Missing := True; + Res := Option_Ok; + else + Decode_Option (Command_Html (Cmd), Option, Arg, Res); + end if; + end Decode_Option; + + procedure Disp_Long_Help (Cmd : Command_Xref_Html) is + begin + Disp_Long_Help (Command_Html (Cmd)); + Put_Line ("-o DIR Put generated files into DIR (def: html/)"); + Put_Line ("--check-missing Fail if a reference is missing"); + New_Line; + Put_Line ("When format is css, the CSS file 'ghdl.css' " + & "is never overwritten."); + end Disp_Long_Help; + + procedure Analyze_Design_File_Units (File : Iir_Design_File) + is + Unit : Iir_Design_Unit; + begin + Unit := Get_First_Design_Unit (File); + while Unit /= Null_Iir loop + case Get_Date_State (Unit) is + when Date_Extern + | Date_Disk => + raise Internal_Error; + when Date_Parse => + Libraries.Load_Design_Unit (Unit, Null_Iir); + when Date_Analyze => + null; + end case; + Unit := Get_Chain (Unit); + end loop; + end Analyze_Design_File_Units; + + procedure Perform_Action + (Cmd : in out Command_Xref_Html; Files_Name : Argument_List) + is + use GNAT.Directory_Operations; + + Id : Name_Id; + File : Source_File_Entry; + + type File_Data is record + Fe : Source_File_Entry; + Design_File : Iir; + Output : String_Acc; + end record; + type File_Data_Array is array (Files_Name'Range) of File_Data; + + Files : File_Data_Array; + Output : File_Type; + begin + Xrefs.Init; + Flags.Flag_Xref := True; + + -- Load work library. + Setup_Libraries (True); + + if Cmd.Output_Dir = null then + Cmd.Output_Dir := new String'("html"); + elsif Cmd.Output_Dir.all = "-" then + Cmd.Output_Dir := null; + end if; + + -- Try to create the directory. + if Cmd.Output_Dir /= null + and then not Is_Directory (Cmd.Output_Dir.all) + then + declare + begin + Make_Dir (Cmd.Output_Dir.all); + exception + when Directory_Error => + Error ("cannot create directory " & Cmd.Output_Dir.all); + return; + end; + end if; + + -- Parse all files. + for I in Files'Range loop + Id := Get_Identifier (Files_Name (I).all); + File := Files_Map.Load_Source_File (Libraries.Local_Directory, Id); + if File = No_Source_File_Entry then + Error ("cannot open " & Image (Id)); + return; + end if; + Files (I).Fe := File; + Files (I).Design_File := Libraries.Load_File (File); + if Files (I).Design_File = Null_Iir then + return; + end if; + Files (I).Output := Create_Output_Filename + (Base_Name (Files_Name (I).all), I); + if Is_Regular_File (Files (I).Output.all) then + -- Prevent overwrite. + null; + end if; + -- Put units in library. + Libraries.Add_Design_File_Into_Library (Files (I).Design_File); + end loop; + + -- Analyze all files. + for I in Files'Range loop + Analyze_Design_File_Units (Files (I).Design_File); + end loop; + + Xrefs.Sort_By_Location; + + if False then + for I in 1 .. Xrefs.Get_Last_Xref loop + declare + use Xrefs; + + procedure Put_Loc (L : Location_Type) + is + use Files_Map; + + L_File : Source_File_Entry; + L_Pos : Source_Ptr; + begin + Files_Map.Location_To_File_Pos (L, L_File, L_Pos); + Put_Nat (Natural (L_File)); + --Image (Get_File_Name (L_File)); + --Put (Name_Buffer (1 .. Name_Length)); + Put (":"); + Put_Nat (Natural (L_Pos)); + end Put_Loc; + begin + Put_Loc (Get_Xref_Location (I)); + case Get_Xref_Kind (I) is + when Xref_Decl => + Put (" decl "); + Put (Image (Get_Identifier (Get_Xref_Node (I)))); + when Xref_Ref => + Put (" use "); + Put_Loc (Get_Location (Get_Xref_Node (I))); + when Xref_End => + Put (" end "); + when Xref_Body => + Put (" body "); + end case; + New_Line; + end; + end loop; + end if; + + -- Create filexref_info. + Filexref_Info := new Filexref_Info_Arr + (No_Source_File_Entry .. Files_Map.Get_Last_Source_File_Entry); + Filexref_Info.all := (others => (Output => null, + Referenced => False)); + for I in Files'Range loop + Filexref_Info (Files (I).Fe).Output := Files (I).Output; + end loop; + + for I in Files'Range loop + if Cmd.Output_Dir /= null then + Create (Output, Out_File, + Cmd.Output_Dir.all & Directory_Separator + & Files (I).Output.all); + + Set_Output (Output); + end if; + + Put_Html_Header; + Put_Line (" "); + Put_Html (Files_Name (I).all); + Put (""); + Put_Line (""); + New_Line; + Put_Line (""); + + Put ("

"); + Put_Html (Files_Name (I).all); + Put ("

"); + New_Line; + + PP_Html_File (Files (I).Fe); + Put_Html_Foot; + + if Cmd.Output_Dir /= null then + Close (Output); + end if; + end loop; + + -- Create indexes. + if Cmd.Output_Dir /= null then + Create (Output, Out_File, + Cmd.Output_Dir.all & Directory_Separator & "index.html"); + Set_Output (Output); + + Put_Html_Header; + Put_Line (" Xrefs indexes"); + Put_Line (""); + New_Line; + Put_Line (""); + Put_Line ("

list of files:"); + Put_Line ("

"); + Put_Line ("
"); + + -- TODO: list of design units. + + Put_Line ("

list of files referenced but not available:"); + Put_Line ("

"); + Put_Html_Foot; + + Close (Output); + end if; + + if Html_Format = Html_Css + and then Cmd.Output_Dir /= null + then + declare + Css_Filename : constant String := + Cmd.Output_Dir.all & Directory_Separator & "ghdl.css"; + begin + if not Is_Regular_File (Css_Filename & Nul) then + Create (Output, Out_File, Css_Filename); + Set_Output (Output); + Put_Css; + Close (Output); + end if; + end; + end if; + + if Missing_Xref and Cmd.Check_Missing then + Error ("missing xrefs"); + raise Compile_Error; + end if; + exception + when Compilation_Error => + Error ("xrefs has failed due to compilation error"); + end Perform_Action; + + + -- Command --xref + type Command_Xref is new Command_Lib with null record; + + function Decode_Command (Cmd : Command_Xref; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Xref) return String; + + procedure Perform_Action (Cmd : in out Command_Xref; + Files_Name : Argument_List); + + function Decode_Command (Cmd : Command_Xref; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--xref"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Xref) return String + is + pragma Unreferenced (Cmd); + begin + return "--xref FILEs Generate xrefs"; + end Get_Short_Help; + + procedure Perform_Action + (Cmd : in out Command_Xref; Files_Name : Argument_List) + is + pragma Unreferenced (Cmd); + + use Files_Map; + + Id : Name_Id; + File : Source_File_Entry; + + type File_Data is record + Fe : Source_File_Entry; + Design_File : Iir; + end record; + type File_Data_Array is array (Files_Name'Range) of File_Data; + + Files : File_Data_Array; + begin + -- Load work library. + Setup_Libraries (True); + + Xrefs.Init; + Flags.Flag_Xref := True; + + -- Parse all files. + for I in Files'Range loop + Id := Get_Identifier (Files_Name (I).all); + File := Load_Source_File (Libraries.Local_Directory, Id); + if File = No_Source_File_Entry then + Error ("cannot open " & Image (Id)); + return; + end if; + Files (I).Fe := File; + Files (I).Design_File := Libraries.Load_File (File); + if Files (I).Design_File = Null_Iir then + return; + end if; + -- Put units in library. + -- Note: design_units stay while design_file get empty. + Libraries.Add_Design_File_Into_Library (Files (I).Design_File); + end loop; + + -- Analyze all files. + for I in Files'Range loop + Analyze_Design_File_Units (Files (I).Design_File); + end loop; + + Xrefs.Fix_End_Xrefs; + Xrefs.Sort_By_Node_Location; + + for F in Files'Range loop + + Put ("GHDL-XREF V0"); + + declare + use Xrefs; + + Cur_Decl : Iir; + Cur_File : Source_File_Entry; + + procedure Emit_Loc (Loc : Location_Type; C : Character) + is + L_File : Source_File_Entry; + L_Pos : Source_Ptr; + L_Line : Natural; + L_Off : Natural; + begin + Location_To_Coord (Loc, L_File, L_Pos, L_Line, L_Off); + --Put_Nat (Natural (L_File)); + --Put (':'); + Put_Nat (L_Line); + Put (C); + Put_Nat (L_Off); + end Emit_Loc; + + procedure Emit_Decl (N : Iir) + is + Loc : Location_Type; + Loc_File : Source_File_Entry; + Loc_Pos : Source_Ptr; + C : Character; + Dir : Name_Id; + begin + New_Line; + Cur_Decl := N; + Loc := Get_Location (N); + Location_To_File_Pos (Loc, Loc_File, Loc_Pos); + if Loc_File /= Cur_File then + Cur_File := Loc_File; + Put ("XFILE: "); + Dir := Get_Source_File_Directory (Cur_File); + if Dir /= Null_Identifier then + Image (Dir); + Put (Name_Buffer (1 .. Name_Length)); + end if; + Image (Get_File_Name (Cur_File)); + Put (Name_Buffer (1 .. Name_Length)); + New_Line; + end if; + + -- Letters: + -- b d fgh jk no qr uvwxyz + -- D H JK MNO QR U WXYZ + case Get_Kind (N) is + when Iir_Kind_Type_Declaration => + C := 'T'; + when Iir_Kind_Subtype_Declaration => + C := 't'; + when Iir_Kind_Entity_Declaration => + C := 'E'; + when Iir_Kind_Architecture_Body => + C := 'A'; + when Iir_Kind_Library_Declaration => + C := 'L'; + when Iir_Kind_Package_Declaration => + C := 'P'; + when Iir_Kind_Package_Body => + C := 'B'; + when Iir_Kind_Function_Declaration => + C := 'F'; + when Iir_Kind_Procedure_Declaration => + C := 'p'; + when Iir_Kind_Interface_Signal_Declaration => + C := 's'; + when Iir_Kind_Signal_Declaration => + C := 'S'; + when Iir_Kind_Interface_Constant_Declaration => + C := 'c'; + when Iir_Kind_Constant_Declaration => + C := 'C'; + when Iir_Kind_Variable_Declaration => + C := 'V'; + when Iir_Kind_Element_Declaration => + C := 'e'; + when Iir_Kind_Iterator_Declaration => + C := 'i'; + when Iir_Kind_Attribute_Declaration => + C := 'a'; + when Iir_Kind_Enumeration_Literal => + C := 'l'; + when Iir_Kind_Component_Declaration => + C := 'm'; + when Iir_Kind_Component_Instantiation_Statement => + C := 'I'; + when Iir_Kind_Generate_Statement => + C := 'G'; + when others => + C := '?'; + end case; + Emit_Loc (Loc, C); + --Disp_Tree.Disp_Iir_Address (N); + Put (' '); + case Get_Kind (N) is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + null; + when others => + Image (Get_Identifier (N)); + Put (Name_Buffer (1 .. Name_Length)); + end case; + end Emit_Decl; + + procedure Emit_Ref (R : Xref; T : Character) + is + N : Iir; + begin + N := Get_Xref_Node (R); + if N /= Cur_Decl then + Emit_Decl (N); + end if; + Put (' '); + Emit_Loc (Get_Xref_Location (R), T); + end Emit_Ref; + + Loc : Location_Type; + Loc_File : Source_File_Entry; + Loc_Pos : Source_Ptr; + begin + Cur_Decl := Null_Iir; + Cur_File := No_Source_File_Entry; + + for I in First_Xref .. Get_Last_Xref loop + Loc := Get_Xref_Location (I); + Location_To_File_Pos (Loc, Loc_File, Loc_Pos); + if Loc_File = Files (F).Fe then + -- This is a local location. + case Get_Xref_Kind (I) is + when Xref_Decl => + Emit_Decl (Get_Xref_Node (I)); + when Xref_End => + Emit_Ref (I, 'e'); + when Xref_Ref => + Emit_Ref (I, 'r'); + when Xref_Body => + Emit_Ref (I, 'b'); + end case; + end if; + end loop; + New_Line; + end; + end loop; + exception + when Compilation_Error => + Error ("xrefs has failed due to compilation error"); + end Perform_Action; + + procedure Register_Commands is + begin + Register_Command (new Command_Chop); + Register_Command (new Command_Lines); + Register_Command (new Command_Reprint); + Register_Command (new Command_Compare_Tokens); + Register_Command (new Command_PP_Html); + Register_Command (new Command_Xref_Html); + Register_Command (new Command_Xref); + end Register_Commands; +end Ghdlprint; diff --git a/src/ghdldrv/ghdlprint.ads b/src/ghdldrv/ghdlprint.ads new file mode 100644 index 000000000..82c3e6072 --- /dev/null +++ b/src/ghdldrv/ghdlprint.ads @@ -0,0 +1,20 @@ +-- GHDL driver - print commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Ghdlprint is + procedure Register_Commands; +end Ghdlprint; diff --git a/src/ghdldrv/ghdlrun.adb b/src/ghdldrv/ghdlrun.adb new file mode 100644 index 000000000..f6237214e --- /dev/null +++ b/src/ghdldrv/ghdlrun.adb @@ -0,0 +1,661 @@ +-- GHDL driver - JIT commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Interfaces.C; + +with Ghdlmain; use Ghdlmain; +with Ghdllocal; use Ghdllocal; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with Ada.Unchecked_Conversion; +with Ada.Command_Line; +with Ada.Text_IO; + +with Ortho_Jit; +with Ortho_Nodes; use Ortho_Nodes; +with Interfaces; +with System; use System; +with Trans_Decls; +with Iirs; use Iirs; +with Flags; +with Errorout; use Errorout; +with Libraries; +with Canon; +with Trans_Be; +with Translation; +with Ieee.Std_Logic_1164; + +with Lists; +with Str_Table; +with Nodes; +with Files_Map; +with Name_Table; + +with Grt.Main; +with Grt.Modules; +with Grt.Lib; +with Grt.Processes; +with Grt.Rtis; +with Grt.Files; +with Grt.Signals; +with Grt.Options; +with Grt.Types; +with Grt.Images; +with Grt.Values; +with Grt.Names; +with Grt.Std_Logic_1164; + +with Ghdlcomp; +with Foreigns; +with Grtlink; + +package body Ghdlrun is + procedure Foreign_Hook (Decl : Iir; + Info : Translation.Foreign_Info_Type; + Ortho : O_Dnode); + + procedure Compile_Init (Analyze_Only : Boolean) is + begin + if Analyze_Only then + return; + end if; + + Translation.Foreign_Hook := Foreign_Hook'Access; + + -- FIXME: add a flag to force unnesting. + -- Translation.Flag_Unnest_Subprograms := True; + + -- The design is always analyzed in whole. + Flags.Flag_Whole_Analyze := True; + + Setup_Libraries (False); + Libraries.Load_Std_Library; + + Ortho_Jit.Init; + + Translation.Initialize; + Canon.Canon_Flag_Add_Labels := True; + end Compile_Init; + + procedure Compile_Elab + (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural) + is + begin + Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg); + if Sec_Name = null then + Sec_Name := new String'(""); + end if; + + Flags.Flag_Elaborate := True; + Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True); + + if Errorout.Nbr_Errors > 0 then + -- This may happen (bad entity for example). + raise Compilation_Error; + end if; + end Compile_Elab; + + -- Set options. + -- This is a little bit over-kill: from C to Ada and then again to C... + procedure Set_Run_Options (Args : Argument_List) + is + use Interfaces.C; + use Grt.Options; + use Grt.Types; + + function Malloc (Size : size_t) return Argv_Type; + pragma Import (C, Malloc); + + function Strdup (Str : String) return Ghdl_C_String; + pragma Import (C, Strdup); +-- is +-- T : Grt.Types.String_Access; +-- begin +-- T := new String'(Str & Ghdllocal.Nul); +-- return To_Ghdl_C_String (T.all'Address); +-- end Strdup; + begin + Argc := 1 + Args'Length; + Argv := Malloc + (size_t (Argc * (Ghdl_C_String'Size / System.Storage_Unit))); + Argv (0) := Strdup (Ada.Command_Line.Command_Name & Ghdllocal.Nul); + Progname := Argv (0); + for I in Args'Range loop + Argv (1 + I - Args'First) := Strdup (Args (I).all & Ghdllocal.Nul); + end loop; + end Set_Run_Options; + + procedure Ghdl_Elaborate; + pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE"); + + type Elaborate_Acc is access procedure; + pragma Convention (C, Elaborate_Acc); + Elaborate_Proc : Elaborate_Acc := null; + + procedure Ghdl_Elaborate is + begin + --Ada.Text_IO.Put_Line (Standard_Error, "ghdl_elaborate"); + Elaborate_Proc.all; + end Ghdl_Elaborate; + + procedure Def (Decl : O_Dnode; Addr : Address) + renames Ortho_Jit.Set_Address; + + procedure Foreign_Hook (Decl : Iir; + Info : Translation.Foreign_Info_Type; + Ortho : O_Dnode) + is + use Translation; + Res : Address; + begin + case Info.Kind is + when Foreign_Vhpidirect => + declare + Name : constant String := + Name_Table.Name_Buffer (Info.Subprg_First + .. Info.Subprg_Last); + begin + Res := Foreigns.Find_Foreign (Name); + if Res /= Null_Address then + Def (Ortho, Res); + else + Error_Msg_Sem ("unknown foreign VHPIDIRECT '" & Name & "'", + Decl); + end if; + end; + when Foreign_Intrinsic => + Name_Table.Image (Get_Identifier (Decl)); + declare + Name : constant String := + Name_Table.Name_Buffer (1 .. Name_Table.Name_Length); + begin + if Name = "untruncated_text_read" then + Def (Ortho, Grt.Files.Ghdl_Untruncated_Text_Read'Address); + elsif Name = "control_simulation" then + Def (Ortho, Grt.Lib.Ghdl_Control_Simulation'Address); + elsif Name = "get_resolution_limit" then + Def (Ortho, Grt.Lib.Ghdl_Get_Resolution_Limit'Address); + else + Error_Msg_Sem ("unknown foreign intrinsic '" & Name & "'", + Decl); + end if; + end; + when Foreign_Unknown => + null; + end case; + end Foreign_Hook; + + procedure Run + is + use Interfaces; + --use Ortho_Code.Binary; + + function Conv is new Ada.Unchecked_Conversion + (Source => Address, Target => Elaborate_Acc); + Err : Boolean; + Decl : O_Dnode; + begin + if Flag_Verbose then + Ada.Text_IO.Put_Line ("Linking in memory"); + end if; + + Def (Trans_Decls.Ghdl_Memcpy, + Grt.Lib.Ghdl_Memcpy'Address); + Def (Trans_Decls.Ghdl_Bound_Check_Failed_L1, + Grt.Lib.Ghdl_Bound_Check_Failed_L1'Address); + Def (Trans_Decls.Ghdl_Malloc0, + Grt.Lib.Ghdl_Malloc0'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_To_Boolean_Array, + Grt.Lib.Ghdl_Std_Ulogic_To_Boolean_Array'Address); + + Def (Trans_Decls.Ghdl_Report, + Grt.Lib.Ghdl_Report'Address); + Def (Trans_Decls.Ghdl_Assert_Failed, + Grt.Lib.Ghdl_Assert_Failed'Address); + Def (Trans_Decls.Ghdl_Ieee_Assert_Failed, + Grt.Lib.Ghdl_Ieee_Assert_Failed'Address); + Def (Trans_Decls.Ghdl_Psl_Assert_Failed, + Grt.Lib.Ghdl_Psl_Assert_Failed'Address); + Def (Trans_Decls.Ghdl_Psl_Cover, + Grt.Lib.Ghdl_Psl_Cover'Address); + Def (Trans_Decls.Ghdl_Psl_Cover_Failed, + Grt.Lib.Ghdl_Psl_Cover_Failed'Address); + Def (Trans_Decls.Ghdl_Program_Error, + Grt.Lib.Ghdl_Program_Error'Address); + Def (Trans_Decls.Ghdl_Malloc, + Grt.Lib.Ghdl_Malloc'Address); + Def (Trans_Decls.Ghdl_Deallocate, + Grt.Lib.Ghdl_Deallocate'Address); + Def (Trans_Decls.Ghdl_Real_Exp, + Grt.Lib.Ghdl_Real_Exp'Address); + Def (Trans_Decls.Ghdl_Integer_Exp, + Grt.Lib.Ghdl_Integer_Exp'Address); + + Def (Trans_Decls.Ghdl_Sensitized_Process_Register, + Grt.Processes.Ghdl_Sensitized_Process_Register'Address); + Def (Trans_Decls.Ghdl_Process_Register, + Grt.Processes.Ghdl_Process_Register'Address); + Def (Trans_Decls.Ghdl_Postponed_Sensitized_Process_Register, + Grt.Processes.Ghdl_Postponed_Sensitized_Process_Register'Address); + Def (Trans_Decls.Ghdl_Postponed_Process_Register, + Grt.Processes.Ghdl_Postponed_Process_Register'Address); + Def (Trans_Decls.Ghdl_Finalize_Register, + Grt.Processes.Ghdl_Finalize_Register'Address); + + Def (Trans_Decls.Ghdl_Stack2_Allocate, + Grt.Processes.Ghdl_Stack2_Allocate'Address); + Def (Trans_Decls.Ghdl_Stack2_Mark, + Grt.Processes.Ghdl_Stack2_Mark'Address); + Def (Trans_Decls.Ghdl_Stack2_Release, + Grt.Processes.Ghdl_Stack2_Release'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Exit, + Grt.Processes.Ghdl_Process_Wait_Exit'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Suspend, + Grt.Processes.Ghdl_Process_Wait_Suspend'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Timeout, + Grt.Processes.Ghdl_Process_Wait_Timeout'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Set_Timeout, + Grt.Processes.Ghdl_Process_Wait_Set_Timeout'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Add_Sensitivity, + Grt.Processes.Ghdl_Process_Wait_Add_Sensitivity'Address); + Def (Trans_Decls.Ghdl_Process_Wait_Close, + Grt.Processes.Ghdl_Process_Wait_Close'Address); + + Def (Trans_Decls.Ghdl_Process_Add_Sensitivity, + Grt.Processes.Ghdl_Process_Add_Sensitivity'Address); + + Def (Trans_Decls.Ghdl_Now, + Grt.Types.Current_Time'Address); + + Def (Trans_Decls.Ghdl_Process_Add_Driver, + Grt.Signals.Ghdl_Process_Add_Driver'Address); + Def (Trans_Decls.Ghdl_Signal_Add_Direct_Driver, + Grt.Signals.Ghdl_Signal_Add_Direct_Driver'Address); + + Def (Trans_Decls.Ghdl_Signal_Add_Source, + Grt.Signals.Ghdl_Signal_Add_Source'Address); + Def (Trans_Decls.Ghdl_Signal_In_Conversion, + Grt.Signals.Ghdl_Signal_In_Conversion'Address); + Def (Trans_Decls.Ghdl_Signal_Out_Conversion, + Grt.Signals.Ghdl_Signal_Out_Conversion'Address); + Def (Trans_Decls.Ghdl_Signal_Effective_Value, + Grt.Signals.Ghdl_Signal_Effective_Value'Address); + Def (Trans_Decls.Ghdl_Signal_Create_Resolution, + Grt.Signals.Ghdl_Signal_Create_Resolution'Address); + + Def (Trans_Decls.Ghdl_Signal_Disconnect, + Grt.Signals.Ghdl_Signal_Disconnect'Address); + Def (Trans_Decls.Ghdl_Signal_Set_Disconnect, + Grt.Signals.Ghdl_Signal_Set_Disconnect'Address); + Def (Trans_Decls.Ghdl_Signal_Merge_Rti, + Grt.Signals.Ghdl_Signal_Merge_Rti'Address); + Def (Trans_Decls.Ghdl_Signal_Name_Rti, + Grt.Signals.Ghdl_Signal_Name_Rti'Address); + Def (Trans_Decls.Ghdl_Signal_Read_Port, + Grt.Signals.Ghdl_Signal_Read_Port'Address); + Def (Trans_Decls.Ghdl_Signal_Read_Driver, + Grt.Signals.Ghdl_Signal_Read_Driver'Address); + + Def (Trans_Decls.Ghdl_Signal_Driving, + Grt.Signals.Ghdl_Signal_Driving'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_B1, + Grt.Signals.Ghdl_Signal_Driving_Value_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_E8, + Grt.Signals.Ghdl_Signal_Driving_Value_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_E32, + Grt.Signals.Ghdl_Signal_Driving_Value_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_I32, + Grt.Signals.Ghdl_Signal_Driving_Value_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_I64, + Grt.Signals.Ghdl_Signal_Driving_Value_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Driving_Value_F64, + Grt.Signals.Ghdl_Signal_Driving_Value_F64'Address); + + Def (Trans_Decls.Ghdl_Signal_Create_Guard, + Grt.Signals.Ghdl_Signal_Create_Guard'Address); + Def (Trans_Decls.Ghdl_Signal_Guard_Dependence, + Grt.Signals.Ghdl_Signal_Guard_Dependence'Address); + + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_Error, + Grt.Signals.Ghdl_Signal_Simple_Assign_Error'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_Error, + Grt.Signals.Ghdl_Signal_Start_Assign_Error'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_Error, + Grt.Signals.Ghdl_Signal_Next_Assign_Error'Address); + + Def (Trans_Decls.Ghdl_Signal_Start_Assign_Null, + Grt.Signals.Ghdl_Signal_Start_Assign_Null'Address); + + Def (Trans_Decls.Ghdl_Signal_Direct_Assign, + Grt.Signals.Ghdl_Signal_Direct_Assign'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_B1, + Grt.Signals.Ghdl_Create_Signal_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Init_B1, + Grt.Signals.Ghdl_Signal_Init_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_B1, + Grt.Signals.Ghdl_Signal_Simple_Assign_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_B1, + Grt.Signals.Ghdl_Signal_Start_Assign_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_B1, + Grt.Signals.Ghdl_Signal_Next_Assign_B1'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_B1, + Grt.Signals.Ghdl_Signal_Associate_B1'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_E8, + Grt.Signals.Ghdl_Create_Signal_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Init_E8, + Grt.Signals.Ghdl_Signal_Init_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E8, + Grt.Signals.Ghdl_Signal_Simple_Assign_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_E8, + Grt.Signals.Ghdl_Signal_Start_Assign_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_E8, + Grt.Signals.Ghdl_Signal_Next_Assign_E8'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_E8, + Grt.Signals.Ghdl_Signal_Associate_E8'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_E32, + Grt.Signals.Ghdl_Create_Signal_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Init_E32, + Grt.Signals.Ghdl_Signal_Init_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E32, + Grt.Signals.Ghdl_Signal_Simple_Assign_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_E32, + Grt.Signals.Ghdl_Signal_Start_Assign_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_E32, + Grt.Signals.Ghdl_Signal_Next_Assign_E32'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_E32, + Grt.Signals.Ghdl_Signal_Associate_E32'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_I32, + Grt.Signals.Ghdl_Create_Signal_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Init_I32, + Grt.Signals.Ghdl_Signal_Init_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I32, + Grt.Signals.Ghdl_Signal_Simple_Assign_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_I32, + Grt.Signals.Ghdl_Signal_Start_Assign_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_I32, + Grt.Signals.Ghdl_Signal_Next_Assign_I32'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_I32, + Grt.Signals.Ghdl_Signal_Associate_I32'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_I64, + Grt.Signals.Ghdl_Create_Signal_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Init_I64, + Grt.Signals.Ghdl_Signal_Init_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I64, + Grt.Signals.Ghdl_Signal_Simple_Assign_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_I64, + Grt.Signals.Ghdl_Signal_Start_Assign_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_I64, + Grt.Signals.Ghdl_Signal_Next_Assign_I64'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_I64, + Grt.Signals.Ghdl_Signal_Associate_I64'Address); + + Def (Trans_Decls.Ghdl_Create_Signal_F64, + Grt.Signals.Ghdl_Create_Signal_F64'Address); + Def (Trans_Decls.Ghdl_Signal_Init_F64, + Grt.Signals.Ghdl_Signal_Init_F64'Address); + Def (Trans_Decls.Ghdl_Signal_Simple_Assign_F64, + Grt.Signals.Ghdl_Signal_Simple_Assign_F64'Address); + Def (Trans_Decls.Ghdl_Signal_Start_Assign_F64, + Grt.Signals.Ghdl_Signal_Start_Assign_F64'Address); + Def (Trans_Decls.Ghdl_Signal_Next_Assign_F64, + Grt.Signals.Ghdl_Signal_Next_Assign_F64'Address); + Def (Trans_Decls.Ghdl_Signal_Associate_F64, + Grt.Signals.Ghdl_Signal_Associate_F64'Address); + + Def (Trans_Decls.Ghdl_Signal_Attribute_Register_Prefix, + Grt.Signals.Ghdl_Signal_Attribute_Register_Prefix'Address); + Def (Trans_Decls.Ghdl_Create_Stable_Signal, + Grt.Signals.Ghdl_Create_Stable_Signal'Address); + Def (Trans_Decls.Ghdl_Create_Quiet_Signal, + Grt.Signals.Ghdl_Create_Quiet_Signal'Address); + Def (Trans_Decls.Ghdl_Create_Transaction_Signal, + Grt.Signals.Ghdl_Create_Transaction_Signal'Address); + Def (Trans_Decls.Ghdl_Create_Delayed_Signal, + Grt.Signals.Ghdl_Create_Delayed_Signal'Address); + + Def (Trans_Decls.Ghdl_Rti_Add_Package, + Grt.Rtis.Ghdl_Rti_Add_Package'Address); + Def (Trans_Decls.Ghdl_Rti_Add_Top, + Grt.Rtis.Ghdl_Rti_Add_Top'Address); + + Def (Trans_Decls.Ghdl_Protected_Enter, + Grt.Processes.Ghdl_Protected_Enter'Address); + Def (Trans_Decls.Ghdl_Protected_Leave, + Grt.Processes.Ghdl_Protected_Leave'Address); + Def (Trans_Decls.Ghdl_Protected_Init, + Grt.Processes.Ghdl_Protected_Init'Address); + Def (Trans_Decls.Ghdl_Protected_Fini, + Grt.Processes.Ghdl_Protected_Fini'Address); + + Def (Trans_Decls.Ghdl_Text_File_Elaborate, + Grt.Files.Ghdl_Text_File_Elaborate'Address); + Def (Trans_Decls.Ghdl_Text_File_Finalize, + Grt.Files.Ghdl_Text_File_Finalize'Address); + Def (Trans_Decls.Ghdl_Text_File_Open, + Grt.Files.Ghdl_Text_File_Open'Address); + Def (Trans_Decls.Ghdl_Text_File_Open_Status, + Grt.Files.Ghdl_Text_File_Open_Status'Address); + Def (Trans_Decls.Ghdl_Text_Write, + Grt.Files.Ghdl_Text_Write'Address); + Def (Trans_Decls.Ghdl_Text_Read_Length, + Grt.Files.Ghdl_Text_Read_Length'Address); + Def (Trans_Decls.Ghdl_Text_File_Close, + Grt.Files.Ghdl_Text_File_Close'Address); + + Def (Trans_Decls.Ghdl_File_Elaborate, + Grt.Files.Ghdl_File_Elaborate'Address); + Def (Trans_Decls.Ghdl_File_Finalize, + Grt.Files.Ghdl_File_Finalize'Address); + Def (Trans_Decls.Ghdl_File_Open, + Grt.Files.Ghdl_File_Open'Address); + Def (Trans_Decls.Ghdl_File_Open_Status, + Grt.Files.Ghdl_File_Open_Status'Address); + Def (Trans_Decls.Ghdl_File_Close, + Grt.Files.Ghdl_File_Close'Address); + Def (Trans_Decls.Ghdl_File_Flush, + Grt.Files.Ghdl_File_Flush'Address); + Def (Trans_Decls.Ghdl_Write_Scalar, + Grt.Files.Ghdl_Write_Scalar'Address); + Def (Trans_Decls.Ghdl_Read_Scalar, + Grt.Files.Ghdl_Read_Scalar'Address); + + Def (Trans_Decls.Ghdl_File_Endfile, + Grt.Files.Ghdl_File_Endfile'Address); + + Def (Trans_Decls.Ghdl_Image_B1, + Grt.Images.Ghdl_Image_B1'Address); + Def (Trans_Decls.Ghdl_Image_E8, + Grt.Images.Ghdl_Image_E8'Address); + Def (Trans_Decls.Ghdl_Image_E32, + Grt.Images.Ghdl_Image_E32'Address); + Def (Trans_Decls.Ghdl_Image_I32, + Grt.Images.Ghdl_Image_I32'Address); + Def (Trans_Decls.Ghdl_Image_F64, + Grt.Images.Ghdl_Image_F64'Address); + Def (Trans_Decls.Ghdl_Image_P64, + Grt.Images.Ghdl_Image_P64'Address); + Def (Trans_Decls.Ghdl_Image_P32, + Grt.Images.Ghdl_Image_P32'Address); + + Def (Trans_Decls.Ghdl_Value_B1, + Grt.Values.Ghdl_Value_B1'Address); + Def (Trans_Decls.Ghdl_Value_E8, + Grt.Values.Ghdl_Value_E8'Address); + Def (Trans_Decls.Ghdl_Value_E32, + Grt.Values.Ghdl_Value_E32'Address); + Def (Trans_Decls.Ghdl_Value_I32, + Grt.Values.Ghdl_Value_I32'Address); + Def (Trans_Decls.Ghdl_Value_F64, + Grt.Values.Ghdl_Value_F64'Address); + Def (Trans_Decls.Ghdl_Value_P32, + Grt.Values.Ghdl_Value_P32'Address); + Def (Trans_Decls.Ghdl_Value_P64, + Grt.Values.Ghdl_Value_P64'Address); + + Def (Trans_Decls.Ghdl_Get_Path_Name, + Grt.Names.Ghdl_Get_Path_Name'Address); + Def (Trans_Decls.Ghdl_Get_Instance_Name, + Grt.Names.Ghdl_Get_Instance_Name'Address); + + Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Eq, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Eq'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Ne, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Ne'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Lt, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Lt'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Le, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Le'Address); + + Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Eq, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Eq'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Ne, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Ne'Address); + + Def (Trans_Decls.Ghdl_To_String_I32, + Grt.Images.Ghdl_To_String_I32'Address); + Def (Trans_Decls.Ghdl_To_String_F64, + Grt.Images.Ghdl_To_String_F64'Address); + Def (Trans_Decls.Ghdl_To_String_F64_Digits, + Grt.Images.Ghdl_To_String_F64_Digits'Address); + Def (Trans_Decls.Ghdl_To_String_F64_Format, + Grt.Images.Ghdl_To_String_F64_Format'Address); + Def (Trans_Decls.Ghdl_To_String_B1, + Grt.Images.Ghdl_To_String_B1'Address); + Def (Trans_Decls.Ghdl_To_String_E8, + Grt.Images.Ghdl_To_String_E8'Address); + Def (Trans_Decls.Ghdl_To_String_E32, + Grt.Images.Ghdl_To_String_E32'Address); + Def (Trans_Decls.Ghdl_To_String_Char, + Grt.Images.Ghdl_To_String_Char'Address); + Def (Trans_Decls.Ghdl_To_String_P32, + Grt.Images.Ghdl_To_String_P32'Address); + Def (Trans_Decls.Ghdl_To_String_P64, + Grt.Images.Ghdl_To_String_P64'Address); + Def (Trans_Decls.Ghdl_Time_To_String_Unit, + Grt.Images.Ghdl_Time_To_String_Unit'Address); + Def (Trans_Decls.Ghdl_BV_To_Ostring, + Grt.Images.Ghdl_BV_To_Ostring'Address); + Def (Trans_Decls.Ghdl_BV_To_Hstring, + Grt.Images.Ghdl_BV_To_Hstring'Address); + Def (Trans_Decls.Ghdl_Array_Char_To_String_B1, + Grt.Images.Ghdl_Array_Char_To_String_B1'Address); + Def (Trans_Decls.Ghdl_Array_Char_To_String_E8, + Grt.Images.Ghdl_Array_Char_To_String_E8'Address); + Def (Trans_Decls.Ghdl_Array_Char_To_String_E32, + Grt.Images.Ghdl_Array_Char_To_String_E32'Address); + + Ortho_Jit.Link (Err); + if Err then + raise Compile_Error; + end if; + + Grtlink.Std_Standard_Boolean_RTI_Ptr := + Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Boolean_Rti); + Grtlink.Std_Standard_Bit_RTI_Ptr := + Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Bit_Rti); + if Ieee.Std_Logic_1164.Resolved /= Null_Iir then + Decl := Translation.Get_Resolv_Ortho_Decl + (Ieee.Std_Logic_1164.Resolved); + if Decl /= O_Dnode_Null then + Grtlink.Ieee_Std_Logic_1164_Resolved_Resolv_Ptr := + Ortho_Jit.Get_Address (Decl); + end if; + end if; + + Grtlink.Flag_String := Flags.Flag_String; + + Elaborate_Proc := + Conv (Ortho_Jit.Get_Address (Trans_Decls.Ghdl_Elaborate)); + + Ortho_Jit.Finish; + + Translation.Finalize; + Lists.Initialize; + Str_Table.Initialize; + Nodes.Initialize; + Files_Map.Initialize; + Name_Table.Initialize; + + if Flag_Verbose then + Ada.Text_IO.Put_Line ("Starting simulation"); + end if; + + Grt.Main.Run; + --V := Ghdl_Main (1, Gnat_Argv); + end Run; + + + -- Command run help. + type Command_Run_Help is new Command_Type with null record; + function Decode_Command (Cmd : Command_Run_Help; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Run_Help) return String; + procedure Perform_Action (Cmd : in out Command_Run_Help; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Run_Help; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--run-help"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Run_Help) return String + is + pragma Unreferenced (Cmd); + begin + return "--run-help Disp help for RUNOPTS options"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Run_Help; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + begin + if Args'Length /= 0 then + Error + ("warning: command '--run-help' does not accept any argument"); + end if; + Put_Line ("These options can only be placed at [RUNOPTS]"); + -- Register modules, since they add commands. + Grt.Modules.Register_Modules; + -- Bypass usual help header. + Grt.Options.Argc := 0; + Grt.Options.Help; + end Perform_Action; + + procedure Register_Commands + is + begin + Ghdlcomp.Hooks := (Compile_Init'Access, + Compile_Elab'Access, + Set_Run_Options'Access, + Run'Access, + Ortho_Jit.Decode_Option'Access, + Ortho_Jit.Disp_Help'Access); + Ghdlcomp.Register_Commands; + Register_Command (new Command_Run_Help); + Trans_Be.Register_Translation_Back_End; + end Register_Commands; +end Ghdlrun; diff --git a/src/ghdldrv/ghdlrun.ads b/src/ghdldrv/ghdlrun.ads new file mode 100644 index 000000000..07095bd5d --- /dev/null +++ b/src/ghdldrv/ghdlrun.ads @@ -0,0 +1,20 @@ +-- GHDL driver - JIT commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Ghdlrun is + procedure Register_Commands; +end Ghdlrun; diff --git a/src/ghdldrv/ghdlsimul.adb b/src/ghdldrv/ghdlsimul.adb new file mode 100644 index 000000000..17cece726 --- /dev/null +++ b/src/ghdldrv/ghdlsimul.adb @@ -0,0 +1,209 @@ +-- GHDL driver - simulator commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Text_IO; +with Ada.Command_Line; + +with Ghdllocal; use Ghdllocal; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with Types; +with Iirs; use Iirs; +with Flags; +with Back_End; +with Name_Table; +with Errorout; use Errorout; +with Std_Package; +with Libraries; +with Canon; +with Configuration; +with Iirs_Utils; +with Annotations; +with Elaboration; +with Sim_Be; +with Simulation; +with Execution; + +with Ghdlcomp; + +with Grt.Vpi; +pragma Unreferenced (Grt.Vpi); +with Grt.Types; +with Grt.Options; +with Grtlink; + +package body Ghdlsimul is + + -- FIXME: reuse simulation.top_config + Top_Conf : Iir; + + procedure Compile_Init (Analyze_Only : Boolean) is + begin + if Analyze_Only then + return; + end if; + + -- Initialize. + Back_End.Finish_Compilation := Sim_Be.Finish_Compilation'Access; + Back_End.Sem_Foreign := null; + + Setup_Libraries (False); + Libraries.Load_Std_Library; + + -- Here, time_base can be set. + Annotations.Annotate (Std_Package.Std_Standard_Unit); + + Canon.Canon_Flag_Add_Labels := True; + Canon.Canon_Flag_Sequentials_Stmts := True; + Canon.Canon_Flag_Expressions := True; + Canon.Canon_Flag_All_Sensitivity := True; + end Compile_Init; + + procedure Compile_Elab + (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural) + is + use Name_Table; + use Types; + + First_Id : Name_Id; + Sec_Id : Name_Id; + begin + Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg); + + Flags.Flag_Elaborate := True; + -- Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True); + + if Errorout.Nbr_Errors > 0 then + -- This may happen (bad entity for example). + raise Compilation_Error; + end if; + + First_Id := Get_Identifier (Prim_Name.all); + if Sec_Name = null then + Sec_Id := Null_Identifier; + else + Sec_Id := Get_Identifier (Sec_Name.all); + end if; + Top_Conf := Configuration.Configure (First_Id, Sec_Id); + if Top_Conf = Null_Iir then + raise Compilation_Error; + end if; + + -- Check (and possibly abandon) if entity can be at the top of the + -- hierarchy. + declare + Conf_Unit : constant Iir := Get_Library_Unit (Top_Conf); + Arch : constant Iir := + Get_Block_Specification (Get_Block_Configuration (Conf_Unit)); + Entity : constant Iir := Iirs_Utils.Get_Entity (Arch); + begin + Configuration.Check_Entity_Declaration_Top (Entity); + if Nbr_Errors > 0 then + raise Compilation_Error; + end if; + end; + end Compile_Elab; + + -- Set options. + procedure Set_Run_Options (Args : Argument_List) + is + use Grt.Options; + use Types; + Arg : String_Access; + Status : Decode_Option_Status; + Argv0 : String_Acc; + begin + -- Set progname (used for grt error messages) + Argv0 := new String'(Ada.Command_Line.Command_Name & ASCII.Nul); + Grt.Options.Progname := Grt.Types.To_Ghdl_C_String (Argv0.all'Address); + + for I in Args'Range loop + Arg := Args (I); + if Arg.all = "--disp-tree" then + Simulation.Disp_Tree := True; + elsif Arg.all = "--expect-failure" then + Decode_Option (Arg.all, Status); + pragma Assert (Status = Decode_Option_Ok); + elsif Arg.all = "--trace-elab" then + Elaboration.Trace_Elaboration := True; + elsif Arg.all = "--trace-drivers" then + Elaboration.Trace_Drivers := True; + elsif Arg.all = "--trace-annotation" then + Annotations.Trace_Annotation := True; + elsif Arg.all = "--trace-simu" then + Simulation.Trace_Simulation := True; + elsif Arg.all = "--trace-stmt" then + Execution.Trace_Statements := True; + elsif Arg.all = "--stats" then + Simulation.Disp_Stats := True; + elsif Arg.all = "-i" then + Simulation.Flag_Interractive := True; + else + Decode_Option (Arg.all, Status); + case Status is + when Decode_Option_Last => + exit; + when Decode_Option_Help => + -- FIXME: is that correct ? + exit; + when Decode_Option_Ok => + null; + end case; + -- Ghdlmain.Error ("unknown run options '" & Arg.all & "'"); + -- raise Option_Error; + end if; + end loop; + end Set_Run_Options; + + procedure Run is + begin + Grtlink.Flag_String := Flags.Flag_String; + + Simulation.Simulation_Entity (Top_Conf); + end Run; + + function Decode_Option (Option : String) return Boolean + is + begin + if Option = "--debug" then + Simulation.Flag_Debugger := True; + else + return False; + end if; + return True; + end Decode_Option; + + procedure Disp_Long_Help + is + use Ada.Text_IO; + begin + Put_Line (" --debug Run with debugger"); + end Disp_Long_Help; + + procedure Register_Commands + is + begin + Ghdlcomp.Hooks := (Compile_Init'Access, + Compile_Elab'Access, + Set_Run_Options'Access, + Run'Access, + Decode_Option'Access, + Disp_Long_Help'Access); + Ghdlcomp.Register_Commands; + end Register_Commands; +end Ghdlsimul; diff --git a/src/ghdldrv/ghdlsimul.ads b/src/ghdldrv/ghdlsimul.ads new file mode 100644 index 000000000..264cbf8c6 --- /dev/null +++ b/src/ghdldrv/ghdlsimul.ads @@ -0,0 +1,20 @@ +-- GHDL driver - simulator commands. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +package Ghdlsimul is + procedure Register_Commands; +end Ghdlsimul; diff --git a/src/ghdldrv/grtlink.ads b/src/ghdldrv/grtlink.ads new file mode 100644 index 000000000..4b3951e78 --- /dev/null +++ b/src/ghdldrv/grtlink.ads @@ -0,0 +1,39 @@ +-- GHDL driver - shared variables with grt. +-- Copyright (C) 2011 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with System; use System; + +package Grtlink is + + Flag_String : String (1 .. 5); + pragma Export (C, Flag_String, "__ghdl_flag_string"); + + Std_Standard_Bit_RTI_Ptr : Address := Null_Address; + + Std_Standard_Boolean_RTI_Ptr : Address := Null_Address; + + pragma Export (C, Std_Standard_Bit_RTI_Ptr, + "std__standard__bit__RTI_ptr"); + + pragma Export (C, Std_Standard_Boolean_RTI_Ptr, + "std__standard__boolean__RTI_ptr"); + + Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address := Null_Address; + pragma Export (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr, + "ieee__std_logic_1164__resolved_RESOLV_ptr"); + +end Grtlink; diff --git a/src/grt/Makefile b/src/grt/Makefile new file mode 100644 index 000000000..107aef7bf --- /dev/null +++ b/src/grt/Makefile @@ -0,0 +1,56 @@ +# -*- Makefile -*- for the GHDL Run Time library. +# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +# +# GHDL is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any later +# version. +# +# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING. If not, write to the Free +# Software Foundation, 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. +GRT_FLAGS=-g -O +GRT_ADAFLAGS=-gnatn + +ADAC=gcc +CC=gcc +GNATFLAGS=$(CFLAGS) -gnatf -gnaty3befhkmr -gnatwlu +GHDL1=../ghdl1-gcc +GRTSRCDIR=. +GRT_RANLIB=ranlib + +INSTALL=install +INSTALL_DATA=$(INSTALL) -m 644 + +prefix=/usr/local +exec_prefix=$(prefix) +libdir=$(exec_prefix)/lib +grt_libdir=$(libdir) + +target:=$(shell $(CC) -dumpmachine) + +all: grt-all +install: grt-install +clean: grt-clean + $(RM) *~ + +show_target: + echo "Target is $(target)" + +include Makefile.inc + + +GRT_CFLAGS=$(GRT_FLAGS) -Wall +ghwdump: ghwdump.o ghwlib.o + $(CC) $(GRT_CFLAGS) -o $@ ghwdump.o ghwlib.o + +ghwlib.o: ghwlib.c ghwlib.h + $(CC) -c $(GRT_CFLAGS) -o $@ $< +ghwdump.o: ghwdump.c ghwlib.h + $(CC) -c $(GRT_CFLAGS) -o $@ $< diff --git a/src/grt/Makefile.inc b/src/grt/Makefile.inc new file mode 100644 index 000000000..ec1b0df09 --- /dev/null +++ b/src/grt/Makefile.inc @@ -0,0 +1,226 @@ +# -*- Makefile -*- for the GHDL Run Time library. +# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +# +# GHDL is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any later +# version. +# +# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING. If not, write to the Free +# Software Foundation, 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. + +# Variables used: +# AR: ar command +# RM +# CC +# ADAC: the GNAT compiler +# GHDL1: the ghdl compiler +# GRT_RANLIB: the ranlib tool for the grt library. +# grt_libdir: the place to put grt. +# GRTSRCDIR: the source directory of grt. +# target: GCC target +# GRT_FLAGS: common (Ada + C + asm) compilation flags. +# GRT_ADAFLAGS: compilation flags for Ada + +# Convert the target variable into a space separated list of architecture, +# manufacturer, and operating system and assign each of those to its own +# variable. + +target1:=$(subst -gnu,,$(target)) +targ:=$(subst -, ,$(target1)) +arch:=$(word 1,$(targ)) +ifeq ($(words $(targ)),2) + osys:=$(word 2,$(targ)) +else + osys:=$(word 3,$(targ)) +endif + +GRT_ELF_OPTS:=-Wl,--version-script=@/grt.ver -Wl,--export-dynamic + +# Set target files. +ifeq ($(filter-out i%86 linux,$(arch) $(osys)),) + GRT_TARGET_OBJS=i386.o linux.o times.o + GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) +endif +ifeq ($(filter-out x86_64 linux,$(arch) $(osys)),) + GRT_TARGET_OBJS=amd64.o linux.o times.o + GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) +endif +ifeq ($(filter-out i%86 freebsd%,$(arch) $(osys)),) + GRT_TARGET_OBJS=i386.o linux.o times.o + GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS) + ADAC=ada +endif +ifeq ($(filter-out x86_64 freebsd%,$(arch) $(osys)),) + GRT_TARGET_OBJS=amd64.o linux.o times.o + GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS) + ADAC=ada +endif +ifeq ($(filter-out i%86 darwin%,$(arch) $(osys)),) + GRT_TARGET_OBJS=i386.o linux.o times.o + GRT_EXTRA_LIB= +endif +ifeq ($(filter-out x86_64 darwin%,$(arch) $(osys)),) + GRT_TARGET_OBJS=amd64.o linux.o times.o + GRT_EXTRA_LIB= +endif +ifeq ($(filter-out sparc solaris%,$(arch) $(osys)),) + GRT_TARGET_OBJS=sparc.o linux.o times.o + GRT_EXTRA_LIB=-ldl -lm +endif +ifeq ($(filter-out powerpc linux%,$(arch) $(osys)),) + GRT_TARGET_OBJS=ppc.o linux.o times.o + GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) +endif +ifeq ($(filter-out ia64 linux,$(arch) $(osys)),) + GRT_TARGET_OBJS=ia64.o linux.o times.o + GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) +endif +ifeq ($(filter-out i%86 mingw32,$(arch) $(osys)),) + GRT_TARGET_OBJS=win32.o clock.o +endif +# Doesn't work for unknown reasons. +#ifeq ($(filter-out i%86 cygwin,$(arch) $(osys)),) +# GRT_TARGET_OBJS=win32.o clock.o +#endif +# Fall-back: use a generic implementation based on pthreads. +ifndef GRT_TARGET_OBJS + GRT_TARGET_OBJS=pthread.o times.o + GRT_EXTRA_LIB=-lpthread -ldl -lm +endif + +# Additionnal object files (C or asm files). +GRT_ADD_OBJS:=$(GRT_TARGET_OBJS) grt-cbinding.o grt-cvpi.o + +#GRT_USE_PTHREADS=y +ifeq ($(GRT_USE_PTHREADS),y) + GRT_CFLAGS+=-DUSE_THREADS + GRT_ADD_OBJS+=grt-cthreads.o + GRT_EXTRA_LIB+=-lpthread +endif + +GRT_ARCH?=None + +# Configuration pragmas. +GRT_PRAGMA_FLAG=-gnatec$(GRTSRCDIR)/grt.adc -gnat05 + +# Rule to compile an Ada file. +GRT_ADACOMPILE=$(ADAC) -c $(GRT_FLAGS) $(GRT_PRAGMA_FLAG) -o $@ $< + +grt-all: libgrt.a grt.lst + +libgrt.a: $(GRT_ADD_OBJS) run-bind.o main.o grt-files # grt-arch.ads + $(RM) -f $@ + $(AR) rcv $@ `sed -e "/^-/d" < grt-files` $(GRT_ADD_OBJS) \ + run-bind.o main.o + $(GRT_RANLIB) $@ + +run-bind.adb: grt-force + gnatmake -c $(GNATFLAGS) -aI$(GRTSRCDIR) $(GRT_PRAGMA_FLAG) \ + ghdl_main $(GRT_ADAFLAGS) -cargs $(GRT_FLAGS) + gnatbind -Lgrt_ -o run-bind.adb -n ghdl_main.ali + +#system.ads: +# sed -e "/Configurable_Run_Time/s/False/True/" \ +# -e "/Suppress_Standard_Library/s/False/True/" \ +# < `$(ADAC) -print-file-name=adainclude/system.ads` > $@ + +run-bind.o: run-bind.adb + $(GRT_ADACOMPILE) + +main.o: $(GRTSRCDIR)/main.adb + $(GRT_ADACOMPILE) + +i386.o: $(GRTSRCDIR)/config/i386.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +chkstk.o: $(GRTSRCDIR)/config/chkstk.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +sparc.o: $(GRTSRCDIR)/config/sparc.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +ppc.o: $(GRTSRCDIR)/config/ppc.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +ia64.o: $(GRTSRCDIR)/config/ia64.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +amd64.o: $(GRTSRCDIR)/config/amd64.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + +linux.o: $(GRTSRCDIR)/config/linux.c + $(CC) -c $(GRT_FLAGS) $(GRT_CFLAGS) -o $@ $< + +win32.o: $(GRTSRCDIR)/config/win32.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +win32thr.o: $(GRTSRCDIR)/config/win32thr.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +pthread.o: $(GRTSRCDIR)/config/pthread.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +times.o : $(GRTSRCDIR)/config/times.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +clock.o : $(GRTSRCDIR)/config/clock.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-cbinding.o: $(GRTSRCDIR)/grt-cbinding.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-cvpi.o: $(GRTSRCDIR)/grt-cvpi.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-cthreads.o: $(GRTSRCDIR)/grt-cthreads.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-disp-config: + @echo "target: $(target)" + @echo "targ: $(targ)" + @echo "arch: $(arch)" + @echo "osys: $(osys)" + +grt-files: run-bind.adb + sed -e "1,/-- *BEGIN/d" -e "/-- *END/,\$$d" \ + -e "s/ -- //" < $< > $@ + +grt-arch.ads: + echo "With Grt.Arch_$(GRT_ARCH);" > $@ + echo "Package Grt.Arch renames Grt.Arch_$(GRT_ARCH);" >> $@ + +# Remove local files (they are now in the libgrt library). +# Also, remove the -shared option, in order not to build a shared library +# instead of an executable. +# Also remove -lgnat and its associated -L flags. This appears to be required +# with GNAT GPL 2005. +grt-files.in: grt-files + sed -e "\!^./!d" -e "/-shared/d" -e "/-static/d" -e "/-lgnat/d" \ + -e "\X-L/Xd" < $< > $@ + +grt.lst: grt-files.in + echo "@/libgrt.a" > $@ +ifdef GRT_EXTRA_LIB + for i in $(GRT_EXTRA_LIB); do echo $$i >> $@; done +endif + cat $< >> $@ + +grt-install: libgrt.a grt.lst + $(INSTALL_DATA) libgrt.a $(DESTDIR)$(grt_libdir)/libgrt.a + $(INSTALL_DATA) grt.lst $(DESTDIR)$(grt_libdir)/grt.lst + +grt-force: + +grt-clean: grt-force + $(RM) *.o *.ali run-bind.adb run-bind.ads *.a std_standard.s + $(RM) grt-files grt-files.in grt.lst + +.PHONY: grt-all grt-force grt-clean grt-install diff --git a/src/grt/config/Makefile b/src/grt/config/Makefile new file mode 100644 index 000000000..7d5f57def --- /dev/null +++ b/src/grt/config/Makefile @@ -0,0 +1,14 @@ +CFLAGS=-Wall -g + +#ARCH_OBJS=i386.o linux.o +ARCH_OBJS=ppc.o linux.o + +teststack: teststack.o $(ARCH_OBJS) + $(CC) -o $@ $< $(ARCH_OBJS) + +ppc.o: ppc.S + $(CC) -c -o $@ -g $< + +clean: + $(RM) -f *.o *~ teststack + diff --git a/src/grt/config/amd64.S b/src/grt/config/amd64.S new file mode 100644 index 000000000..0a7f0044b --- /dev/null +++ b/src/grt/config/amd64.S @@ -0,0 +1,131 @@ +/* GRT stack implementation for amd64 (x86_64) + Copyright (C) 2005 - 2014 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "amd64.S" + +#ifdef __ELF__ +#define ENTRY(func) .align 4; .globl func; .type func,@function; func: +#define END(func) .size func, . - func +#define NAME(name) name +#elif __APPLE__ +#define ENTRY(func) .align 4; .globl _##func; _##func: +#define END(func) +#define NAME(name) _##name +#else +#define ENTRY(func) .align 4; func: +#define END(func) +#define NAME(name) name +#endif + .text + + /* Function called to loop on the process. */ +ENTRY(grt_stack_loop) + mov 0(%rsp),%rdi + call *8(%rsp) + jmp NAME(grt_stack_loop) +END(grt_stack_loop) + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; + Args: FUNC (RDI), ARG (RSI) + */ +ENTRY(grt_stack_create) + /* Standard prologue. */ + pushq %rbp + movq %rsp,%rbp + /* Save args. */ + sub $0x10,%rsp + mov %rdi,-8(%rbp) + mov %rsi,-16(%rbp) + + /* Allocate the stack, and exit in case of failure */ + callq NAME(grt_stack_allocate) + test %rax,%rax + je .Ldone + + /* Note: %RAX contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + /* The function to be executed. */ + mov -8(%rbp), %rdi + mov %rdi, -8(%rax) + /* The argument. */ + mov -16(%rbp), %rsi + mov %rsi, -16(%rax) + /* The return function. Must be 8 mod 16. */ +#if __APPLE__ + movq _grt_stack_loop@GOTPCREL(%rip), %rsi + movq %rsi, -24(%rax) +#else + movq $grt_stack_loop, -24(%rax) +#endif + /* The context. */ + mov %rbp, -32(%rax) + mov %rbx, -40(%rax) + mov %r12, -48(%rax) + mov %r13, -56(%rax) + mov %r14, -64(%rax) + mov %r15, -72(%rax) + + /* Save the new stack pointer to the stack context. */ + lea -72(%rax), %rsi + mov %rsi, (%rax) + +.Ldone: + leave + ret +END(grt_stack_create) + + + + /* Arguments: TO (RDI), FROM (RSI) [VAL (RDX)] + Both are pointers to a stack_context. */ +ENTRY(grt_stack_switch) + /* Save call-used registers. */ + pushq %rbp + pushq %rbx + pushq %r12 + pushq %r13 + pushq %r14 + pushq %r15 + /* Save the current stack. */ + movq %rsp, (%rsi) + /* Stack switch. */ + movq (%rdi), %rsp + /* Restore call-used registers. */ + popq %r15 + popq %r14 + popq %r13 + popq %r12 + popq %rbx + popq %rbp + /* Return val. */ + movq %rdx, %rax + /* Run. */ + ret +END(grt_stack_switch) + + .ident "Written by T.Gingold" diff --git a/src/grt/config/chkstk.S b/src/grt/config/chkstk.S new file mode 100644 index 000000000..ab244d0cd --- /dev/null +++ b/src/grt/config/chkstk.S @@ -0,0 +1,53 @@ +/* GRT stack implementation for x86. + Copyright (C) 2002 - 2014 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "chkstk.S" + .version "01.01" + + .text + +#ifdef __APPLE__ +#define __chkstk ___chkstk +#endif + + /* Function called to loop on the process. */ + .align 4 +#ifdef __ELF__ + .type __chkstk,@function +#endif + .globl __chkstk +__chkstk: + testl %eax,%eax + je 0f + subl $4,%eax /* 4 bytes already used by call. */ + subl %eax,%esp + jmp *(%esp,%eax) +0: + ret +#ifdef __ELF__ + .size __chkstk, . - __chkstk +#endif + + .ident "Written by T.Gingold" diff --git a/src/grt/config/clock.c b/src/grt/config/clock.c new file mode 100644 index 000000000..242af604b --- /dev/null +++ b/src/grt/config/clock.c @@ -0,0 +1,43 @@ +/* GRT C bindings for time. + Copyright (C) 2002 - 2014 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ +#include + +int +grt_get_clk_tck (void) +{ + return CLOCKS_PER_SEC; +} + +void +grt_get_times (int *wall, int *user, int *sys) +{ + clock_t res; + + *wall = clock (); + *user = 0; + *sys = 0; +} + diff --git a/src/grt/config/i386.S b/src/grt/config/i386.S new file mode 100644 index 000000000..00d4719ac --- /dev/null +++ b/src/grt/config/i386.S @@ -0,0 +1,141 @@ +/* GRT stack implementation for x86. + Copyright (C) 2002 - 2014 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "i386.S" + .version "01.01" + + .text + +#ifdef __ELF__ +#define ENTRY(func) .align 4; .globl func; .type func,@function; func: +#define END(func) .size func, . - func +#define NAME(name) name +#elif __APPLE__ +#define ENTRY(func) .align 4; .globl _##func; _##func: +#define END(func) +#define NAME(name) _##name +#else +#define ENTRY(func) .align 4; func: +#define END(func) +#define NAME(name) name +#endif + + /* Function called to loop on the process. */ +ENTRY(grt_stack_loop) + call *4(%esp) + jmp NAME(grt_stack_loop) +END(grt_stack_loop) + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; + */ +ENTRY(grt_stack_create) + /* Standard prologue. */ + pushl %ebp + movl %esp,%ebp + /* Keep aligned (call + pushl + 8 = 16 bytes). */ + subl $8,%esp + + /* Allocate the stack, and exit in case of failure */ + call NAME(grt_stack_allocate) + testl %eax,%eax + je .Ldone + + /* Note: %EAX contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + /* The function to be executed. */ + movl 8(%ebp), %ecx + movl %ecx, -4(%eax) + /* The argument. */ + movl 12(%ebp), %ecx + movl %ecx, -8(%eax) + /* The return function. */ +#if __APPLE__ + call ___x86.get_pc_thunk.cx +L1$pb: + movl L_grt_stack_loop$non_lazy_ptr-L1$pb(%ecx), %ecx + movl %ecx,-12(%eax) +#else + movl $NAME(grt_stack_loop), -12(%eax) +#endif + /* The context. */ + movl %ebx, -16(%eax) + movl %esi, -20(%eax) + movl %edi, -24(%eax) + movl %ebp, -28(%eax) + + /* Save the new stack pointer to the stack context. */ + leal -28(%eax), %ecx + movl %ecx, (%eax) + +.Ldone: + leave + ret +END(grt_stack_create) + + + /* Arguments: TO, FROM + Both are pointers to a stack_context. */ +ENTRY(grt_stack_switch) + /* TO -> ECX. */ + movl 4(%esp), %ecx + /* FROM -> EDX. */ + movl 8(%esp), %edx + /* Save call-used registers. */ + pushl %ebx + pushl %esi + pushl %edi + pushl %ebp + /* Save the current stack. */ + movl %esp, (%edx) + /* Stack switch. */ + movl (%ecx), %esp + /* Restore call-used registers. */ + popl %ebp + popl %edi + popl %esi + popl %ebx + /* Run. */ + ret +END(grt_stack_switch) + + +#if __APPLE__ + .section __TEXT,__textcoal_nt,coalesced,pure_instructions + .weak_definition ___x86.get_pc_thunk.cx + .private_extern ___x86.get_pc_thunk.cx +___x86.get_pc_thunk.cx: + movl (%esp), %ecx + ret + + .section __IMPORT,__pointers,non_lazy_symbol_pointers +L_grt_stack_loop$non_lazy_ptr: + .indirect_symbol _grt_stack_loop + .long 0 +#endif + + .ident "Written by T.Gingold" diff --git a/src/grt/config/ia64.S b/src/grt/config/ia64.S new file mode 100644 index 000000000..9ce3800bb --- /dev/null +++ b/src/grt/config/ia64.S @@ -0,0 +1,331 @@ +/* GRT stack implementation for ia64. + Copyright (C) 2002 - 2014 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "ia64.S" + .pred.safe_across_calls p1-p5,p16-p63 + + .text + .align 16 + .proc grt_stack_loop +grt_stack_loop: + alloc r32 = ar.pfs, 0, 1, 1, 0 + .body + ;; +1: mov r33 = r4 + br.call.sptk.many b0 = b1 + ;; + br 1b + .endp + + frame_size = 480 + + .global grt_stack_switch# + .proc grt_stack_switch# + /* r32: struct stack_context *TO, r33: struct stack_context *FROM. */ + // Registers to be saved: + // ar.rsc, ar.bsp, ar.pfs, ar.lc, ar.rnat [5] + // gp, r4-r7 (+ Nat) [6] + // f2-f5, f16-f31 [20] + // p1-p5, p16-p63 [1] ??? + // b1-b5 [5] + // f2-f5, f16-f31 [20*16] +grt_stack_switch: + .prologue 2, 2 + .vframe r2 + { + alloc r31=ar.pfs, 2, 0, 0, 0 + mov r14 = ar.rsc + adds r12 = -frame_size, r12 + .body + ;; + } + // Save ar.rsc, ar.bsp, ar.pfs + { + st8 [r12] = r14 // sp + 0 <- ar.rsc + mov r15 = ar.bsp + adds r22 = (5*8), r12 + ;; + } + { + st8.spill [r22] = r1, 8 // sp + 40 <- r1 + ;; + st8.spill [r22] = r4, 8 // sp + 48 <- r4 + adds r20 = 8, r12 + ;; + } + st8 [r20] = r15, 8 // sp + 8 <- ar.bsp + st8.spill [r22] = r5, 8 // sp + 56 <- r5 + mov r15 = ar.lc + ;; + { + st8 [r20] = r31, 8 // sp + 16 <- ar.pfs + // Flush dirty registers to the backing store + flushrs + mov r14 = b0 + ;; + } + { + st8 [r20] = r15, 8 // sp + 24 <- ar.lc + // Set the RSE in enforced lazy mode. + mov ar.rsc = 0 + ;; + } + { + // Save sp. + st8 [r33] = r12 + mov r15 = ar.rnat + mov r16 = b1 + ;; + } + { + st8.spill [r22] = r6, 8 // sp + 64 <- r6 + st8 [r20] = r15, 64 // sp + 32 <- ar.rnat + ;; + } + { + st8.spill [r22] = r7, 16 // sp + 72 <- r7 + st8 [r20] = r14, 8 // sp + 96 <- b0 + mov r15 = b2 + ;; + } + { + mov r17 = ar.unat + ;; + st8 [r22] = r17, 24 // sp + 88 <- ar.unat + mov r14 = b3 + ;; + } + { + st8 [r20] = r16, 16 // sp + 104 <- b1 + st8 [r22] = r15, 16 // sp + 112 <- b2 + mov r17 = b4 + ;; + } + { + st8 [r20] = r14, 16 // sp + 120 <- b3 + st8 [r22] = r17, 16 // sp + 128 <- b4 + mov r15 = b5 + ;; + } + { + // Read new sp. + ld8 r21 = [r32] + ;; + st8 [r20] = r15, 24 // sp + 136 <- b5 + mov r14 = pr + ;; + } + ;; + st8 [r22] = r14, 32 // sp + 144 <- pr + stf.spill [r20] = f2, 32 // sp + 160 <- f2 + ;; + stf.spill [r22] = f3, 32 // sp + 176 <- f3 + stf.spill [r20] = f4, 32 // sp + 192 <- f4 + ;; + stf.spill [r22] = f5, 32 // sp + 208 <- f5 + stf.spill [r20] = f16, 32 // sp + 224 <- f16 + ;; + stf.spill [r22] = f17, 32 // sp + 240 <- f17 + stf.spill [r20] = f18, 32 // sp + 256 <- f18 + ;; + stf.spill [r22] = f19, 32 // sp + 272 <- f19 + stf.spill [r20] = f20, 32 // sp + 288 <- f20 + ;; + stf.spill [r22] = f21, 32 // sp + 304 <- f21 + stf.spill [r20] = f22, 32 // sp + 320 <- f22 + ;; + stf.spill [r22] = f23, 32 // sp + 336 <- f23 + stf.spill [r20] = f24, 32 // sp + 352 <- f24 + ;; + stf.spill [r22] = f25, 32 // sp + 368 <- f25 + stf.spill [r20] = f26, 32 // sp + 384 <- f26 + ;; + stf.spill [r22] = f27, 32 // sp + 400 <- f27 + stf.spill [r20] = f28, 32 // sp + 416 <- f28 + ;; + stf.spill [r22] = f29, 32 // sp + 432 <- f29 + stf.spill [r20] = f30, 32 // sp + 448 <- f30 + ;; + { + stf.spill [r22] = f31, 32 // sp + 464 <- f31 + invala + adds r20 = 8, r21 + ;; + } + ld8 r14 = [r21], 88 // sp + 0 (ar.rsc) + ld8 r16 = [r20], 8 // sp + 8 (ar.bsp) + ;; + ld8 r15 = [r21], -56 // sp + 88 (ar.unat) + ;; + ld8 r18 = [r20], 8 // sp + 16 (ar.pfs) + mov ar.unat = r15 + ld8 r17 = [r21], 8 // sp + 32 (ar.rnat) + ;; + ld8 r15 = [r20], 72 // sp + 24 (ar.lc) + ld8.fill r1 = [r21], 8 // sp + 40 (r1) + mov ar.bspstore = r16 + ;; + ld8.fill r4 = [r21], 8 // sp + 48 (r4) + mov ar.pfs = r18 + mov ar.rnat = r17 + ;; + mov ar.rsc = r14 + mov ar.lc = r15 + ld8 r17 = [r20], 8 // sp + 96 (b0) + ;; + { + ld8.fill r5 = [r21], 8 // sp + 56 (r5) + ld8 r14 = [r20], 8 // sp + 104 (b1) + mov b0 = r17 + ;; + } + { + ld8.fill r6 = [r21], 8 // sp + 64 (r6) + ld8 r15 = [r20], 8 // sp + 112 (b2) + mov b1 = r14 + ;; + } + ld8.fill r7 = [r21], 64 // sp + 72 (r7) + ld8 r14 = [r20], 8 // sp + 120 (b3) + mov b2 = r15 + ;; + ld8 r15 = [r20], 16 // sp + 128 (b4) + ld8 r16 = [r21], 40 // sp + 136 (b5) + mov b3 = r14 + ;; + { + ld8 r14 = [r20], 16 // sp + 144 (pr) + ;; + ldf.fill f2 = [r20], 32 // sp + 160 (f2) + mov b4 = r15 + ;; + } + ldf.fill f3 = [r21], 32 // sp + 176 (f3) + ldf.fill f4 = [r20], 32 // sp + 192 (f4) + mov b5 = r16 + ;; + ldf.fill f5 = [r21], 32 // sp + 208 (f5) + ldf.fill f16 = [r20], 32 // sp + 224 (f16) + mov pr = r14, -1 + ;; + ldf.fill f17 = [r21], 32 // sp + 240 (f17) + ldf.fill f18 = [r20], 32 // sp + 256 (f18) + ;; + ldf.fill f19 = [r21], 32 // sp + 272 (f19) + ldf.fill f20 = [r20], 32 // sp + 288 (f20) + ;; + ldf.fill f21 = [r21], 32 // sp + 304 (f21) + ldf.fill f22 = [r20], 32 // sp + 320 (f22) + ;; + ldf.fill f23 = [r21], 32 // sp + 336 (f23) + ldf.fill f24 = [r20], 32 // sp + 352 (f24) + ;; + ldf.fill f25 = [r21], 32 // sp + 368 (f25) + ldf.fill f26 = [r20], 32 // sp + 384 (f26) + ;; + ldf.fill f27 = [r21], 32 // sp + 400 (f27) + ldf.fill f28 = [r20], 32 // sp + 416 (f28) + ;; + ldf.fill f29 = [r21], 32 // sp + 432 (f29) + ldf.fill f30 = [r20], 32 // sp + 448 (f30) + ;; + ldf.fill f31 = [r21], 32 // sp + 464 (f31) + mov r12 = r20 + br.ret.sptk.many b0 + ;; + .endp grt_stack_switch# + + .align 16 + // r32: func, r33: arg + .global grt_stack_create# + .proc grt_stack_create# +grt_stack_create: + .prologue 14, 34 + .save ar.pfs, r35 + alloc r35 = ar.pfs, 2, 3, 0, 0 + .save rp, r34 + // Compute backing store. + movl r14 = stack_max_size + ;; + .body + { + ld4 r36 = [r14] // r14: bsp + mov r34 = b0 + br.call.sptk.many b0 = grt_stack_allocate# + ;; + } + { + ld8 r22 = [r32], 8 // read ip (-> b1) + ;; + ld8 r23 = [r32] // read r1 from func + adds r21 = -(frame_size + 16) + 32, r8 + ;; + } + { + st8 [r21] = r0, -32 // sp + 32 (ar.rnat = 0) + ;; + st8 [r8] = r21 // Save cur_sp + mov r18 = 0x0f // ar.rsc: LE, PL=3, Eager + ;; + } + { + st8 [r21] = r18, 40 // sp + 0 (ar.rsc) + ;; + st8 [r21] = r23, 64 // sp + 40 (r1 = func.r1) + mov b0 = r34 + ;; + } + { + st8 [r21] = r22, -96 // sp + 104 (b1 = func.ip) + movl r15 = grt_stack_loop + ;; + } + sub r14 = r8, r36 // Backing store base + ;; + adds r14 = 16, r14 // Add sizeof (stack_context) + adds r20 = 40, r21 + ;; + { + st8 [r21] = r14, 88 // sp + 8 (ar.bsp) + ;; + st8 [r21] = r15, -80 // sp + 96 (b0 = grt_stack_loop) + mov r16 = (0 << 7) | 1 // CFM: sol=0, sof=1 + ;; + } + { + st8 [r21] = r16, 8 // sp + 16 (ar.pfs) + ;; + st8 [r21] = r0, 24 // sp + 24 (ar.lc) + mov ar.pfs = r35 + ;; + } + { + st8 [r20] = r0, 8 // sp + 32 (ar.rnat) + st8 [r21] = r33 // sp + 48 (r4 = arg) + br.ret.sptk.many b0 + ;; + } + .endp grt_stack_create# + .ident "GCC: (GNU) 4.0.2" diff --git a/src/grt/config/linux.c b/src/grt/config/linux.c new file mode 100644 index 000000000..74dce0903 --- /dev/null +++ b/src/grt/config/linux.c @@ -0,0 +1,361 @@ +/* GRT stacks implementation for linux and other *nix. + Copyright (C) 2002 - 2014 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +//#include + +#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 +static int run_env_en; +static jmp_buf run_env; + +void +__ghdl_maybe_return_via_longjump (int val) +{ + if (run_env_en) + longjmp (run_env, val); +} + +int +__ghdl_run_through_longjump (int (*func)(void)) +{ + int res; + + run_env_en = 1; + res = setjmp (run_env); + if (res == 0) + res = (*func)(); + run_env_en = 0; + return res; +} + diff --git a/src/grt/config/ppc.S b/src/grt/config/ppc.S new file mode 100644 index 000000000..bedd48ab4 --- /dev/null +++ b/src/grt/config/ppc.S @@ -0,0 +1,334 @@ +/* GRT stack implementation for ppc. + Copyright (C) 2005 - 2014 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "ppc.S" + + .section ".text" + +#define OFF 240 + +#define GREG(x) x +#define FREG(x) x + +#define r0 GREG(0) +#define r1 GREG(1) +#define r2 GREG(2) +#define r3 GREG(3) +#define r4 GREG(4) +#define r5 GREG(5) +#define r6 GREG(6) +#define r7 GREG(7) +#define r8 GREG(8) +#define r9 GREG(9) +#define r10 GREG(10) +#define r11 GREG(11) +#define r12 GREG(12) +#define r13 GREG(13) +#define r14 GREG(14) +#define r15 GREG(15) +#define r16 GREG(16) +#define r17 GREG(17) +#define r18 GREG(18) +#define r19 GREG(19) +#define r20 GREG(20) +#define r21 GREG(21) +#define r22 GREG(22) +#define r23 GREG(23) +#define r24 GREG(24) +#define r25 GREG(25) +#define r26 GREG(26) +#define r27 GREG(27) +#define r28 GREG(28) +#define r29 GREG(29) +#define r30 GREG(30) +#define r31 GREG(31) + +#define f0 FREG(0) +#define f1 FREG(1) +#define f2 FREG(2) +#define f3 FREG(3) +#define f4 FREG(4) +#define f5 FREG(5) +#define f6 FREG(6) +#define f7 FREG(7) +#define f8 FREG(8) +#define f9 FREG(9) +#define f10 FREG(10) +#define f11 FREG(11) +#define f12 FREG(12) +#define f13 FREG(13) +#define f14 FREG(14) +#define f15 FREG(15) +#define f16 FREG(16) +#define f17 FREG(17) +#define f18 FREG(18) +#define f19 FREG(19) +#define f20 FREG(20) +#define f21 FREG(21) +#define f22 FREG(22) +#define f23 FREG(23) +#define f24 FREG(24) +#define f25 FREG(25) +#define f26 FREG(26) +#define f27 FREG(27) +#define f28 FREG(28) +#define f29 FREG(29) +#define f30 FREG(30) +#define f31 FREG(31) + + /* Stack structure is: + +4 : cur_length \ Stack + +0 : cur_sp / Context + -4 : arg + -8 : func + + -12: pad + -16: pad + -20: LR save word + -24: Back chain + + -28: fp/gp saved registers. + -4 : return address + -8 : process function to be executed + -12: function argument + ... + -72: %sp + */ + + /* Function called to loop on the process. */ + .align 4 + .type grt_stack_loop,@function +grt_stack_loop: + /* Get function. */ + lwz r0,16(r1) + /* Get argument. */ + lwz r3,20(r1) + mtlr r0 + blrl + b grt_stack_loop + .size grt_stack_loop, . - grt_stack_loop + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; */ + .align 4 + .global grt_stack_create + .type grt_stack_create,@function +grt_stack_create: + /* Standard prologue. */ + stwu r1,-32(r1) + mflr r0 + stw r0,36(r1) + + /* Save arguments. */ + stw r3,24(r1) + stw r4,28(r1) + + /* Allocate the stack, and exit in case of failure */ + bl grt_stack_allocate + cmpwi 0,r3,0 + beq- .Ldone + + /* Note: r3 contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + /* Align the stack. */ + addi r5,r3,-24 + + /* Save the parameters. */ + lwz r6,24(r1) + stw r6,16(r5) + lwz r7,28(r1) + stw r7,20(r5) + + /* The return function. */ + lis r4,grt_stack_loop@ha + la r4,grt_stack_loop@l(r4) + stw r4,4(r5) + /* Back-Chain. */ + addi r4,r1,32 + stw r4,0(r5) + + /* Save register. + They should be considered as garbage. */ + addi r4,r5,-OFF + + stfd f31,(OFF - 8)(r4) + stfd f30,(OFF - 16)(r4) + stfd f29,(OFF - 24)(r4) + stfd f28,(OFF - 32)(r4) + stfd f27,(OFF - 40)(r4) + stfd f26,(OFF - 48)(r4) + stfd f25,(OFF - 56)(r4) + stfd f24,(OFF - 64)(r4) + stfd f23,(OFF - 72)(r4) + stfd f22,(OFF - 80)(r4) + stfd f21,(OFF - 88)(r4) + stfd f20,(OFF - 96)(r4) + stfd f19,(OFF - 104)(r4) + stfd f18,(OFF - 112)(r4) + stfd f17,(OFF - 120)(r4) + stfd f16,(OFF - 128)(r4) + stfd f15,(OFF - 136)(r4) + stfd f14,(OFF - 144)(r4) + stw r31,(OFF - 148)(r4) + stw r30,(OFF - 152)(r4) + stw r29,(OFF - 156)(r4) + stw r28,(OFF - 160)(r4) + stw r27,(OFF - 164)(r4) + stw r26,(OFF - 168)(r4) + stw r25,(OFF - 172)(r4) + stw r24,(OFF - 176)(r4) + stw r23,(OFF - 180)(r4) + stw r22,(OFF - 184)(r4) + stw r21,(OFF - 188)(r4) + stw r20,(OFF - 192)(r4) + stw r19,(OFF - 196)(r4) + stw r18,(OFF - 200)(r4) + stw r17,(OFF - 204)(r4) + stw r16,(OFF - 208)(r4) + stw r15,(OFF - 212)(r4) + stw r14,(OFF - 216)(r4) + mfcr r0 + stw r0, (OFF - 220)(r4) + + /* Save stack pointer. */ + stw r4, 0(r3) + +.Ldone: + lwz r0,36(r1) + mtlr r0 + addi r1,r1,32 + blr + .size grt_stack_create,. - grt_stack_create + + + .align 4 + .global grt_stack_switch + /* Arguments: TO, FROM. + Both are pointers to a stack_context. */ + .type grt_stack_switch,@function +grt_stack_switch: + /* Standard prologue, save return address. */ + stwu r1,(-OFF)(r1) + mflr r0 + stw r0,(OFF + 4)(r1) + + /* Save r14-r31, f14-f31, CR + This is 18 words + 18 double words, ie 216 bytes. */ + /* Maybe use the savefpr function ? */ + stfd f31,(OFF - 8)(r1) + stfd f30,(OFF - 16)(r1) + stfd f29,(OFF - 24)(r1) + stfd f28,(OFF - 32)(r1) + stfd f27,(OFF - 40)(r1) + stfd f26,(OFF - 48)(r1) + stfd f25,(OFF - 56)(r1) + stfd f24,(OFF - 64)(r1) + stfd f23,(OFF - 72)(r1) + stfd f22,(OFF - 80)(r1) + stfd f21,(OFF - 88)(r1) + stfd f20,(OFF - 96)(r1) + stfd f19,(OFF - 104)(r1) + stfd f18,(OFF - 112)(r1) + stfd f17,(OFF - 120)(r1) + stfd f16,(OFF - 128)(r1) + stfd f15,(OFF - 136)(r1) + stfd f14,(OFF - 144)(r1) + stw r31,(OFF - 148)(r1) + stw r30,(OFF - 152)(r1) + stw r29,(OFF - 156)(r1) + stw r28,(OFF - 160)(r1) + stw r27,(OFF - 164)(r1) + stw r26,(OFF - 168)(r1) + stw r25,(OFF - 172)(r1) + stw r24,(OFF - 176)(r1) + stw r23,(OFF - 180)(r1) + stw r22,(OFF - 184)(r1) + stw r21,(OFF - 188)(r1) + stw r20,(OFF - 192)(r1) + stw r19,(OFF - 196)(r1) + stw r18,(OFF - 200)(r1) + stw r17,(OFF - 204)(r1) + stw r16,(OFF - 208)(r1) + stw r15,(OFF - 212)(r1) + stw r14,(OFF - 216)(r1) + mfcr r0 + stw r0, (OFF - 220)(r1) + + /* Save stack pointer. */ + stw r1, 0(r4) + + /* Load stack pointer. */ + lwz r1, 0(r3) + + + lfd f31,(OFF - 8)(r1) + lfd f30,(OFF - 16)(r1) + lfd f29,(OFF - 24)(r1) + lfd f28,(OFF - 32)(r1) + lfd f27,(OFF - 40)(r1) + lfd f26,(OFF - 48)(r1) + lfd f25,(OFF - 56)(r1) + lfd f24,(OFF - 64)(r1) + lfd f23,(OFF - 72)(r1) + lfd f22,(OFF - 80)(r1) + lfd f21,(OFF - 88)(r1) + lfd f20,(OFF - 96)(r1) + lfd f19,(OFF - 104)(r1) + lfd f18,(OFF - 112)(r1) + lfd f17,(OFF - 120)(r1) + lfd f16,(OFF - 128)(r1) + lfd f15,(OFF - 136)(r1) + lfd f14,(OFF - 144)(r1) + lwz r31,(OFF - 148)(r1) + lwz r30,(OFF - 152)(r1) + lwz r29,(OFF - 156)(r1) + lwz r28,(OFF - 160)(r1) + lwz r27,(OFF - 164)(r1) + lwz r26,(OFF - 168)(r1) + lwz r25,(OFF - 172)(r1) + lwz r24,(OFF - 176)(r1) + lwz r23,(OFF - 180)(r1) + lwz r22,(OFF - 184)(r1) + lwz r21,(OFF - 188)(r1) + lwz r20,(OFF - 192)(r1) + lwz r19,(OFF - 196)(r1) + lwz r18,(OFF - 200)(r1) + lwz r17,(OFF - 204)(r1) + lwz r16,(OFF - 208)(r1) + lwz r15,(OFF - 212)(r1) + lwz r14,(OFF - 216)(r1) + lwz r0, (OFF - 220)(r1) + mtcr r0 + + lwz r0,(OFF + 4)(r1) + mtlr r0 + addi r1,r1,OFF + blr + .size grt_stack_switch, . - grt_stack_switch + + + .ident "Written by T.Gingold" diff --git a/src/grt/config/pthread.c b/src/grt/config/pthread.c new file mode 100644 index 000000000..189ae90c8 --- /dev/null +++ b/src/grt/config/pthread.c @@ -0,0 +1,239 @@ +/* GRT stack implementation based on pthreads. + Copyright (C) 2003 - 2014 Felix Bertram & Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ +//----------------------------------------------------------------------------- +// Project: GHDL - VHDL Simulator +// Description: pthread port of stacks package, for use with MacOSX +// Note: Tristan's original i386/Linux used assembly-code +// to manually switch stacks for performance reasons. +// History: 2003may22, FB, created. +//----------------------------------------------------------------------------- + +#include +#include +#include +#include +#include + +//#define INFO printf +#define INFO (void) + +// GHDL names an endless loop calling FUNC with ARG a 'stack' +// at a given time, only one stack may be 'executed' +typedef struct +{ + pthread_t thread; // stack's thread + pthread_mutex_t mutex; // mutex to suspend/resume thread +#if defined(__CYGWIN__) + pthread_mutexattr_t mxAttr; +#endif + void (*Func)(void*); // stack's FUNC + void* Arg; // ARG passed to FUNC +} Stack_Type_t, *Stack_Type; + +static Stack_Type_t main_stack_context; +static Stack_Type_t *current; +extern void grt_set_main_stack (Stack_Type_t *stack); + +//---------------------------------------------------------------------------- +void grt_stack_init(void) +// Initialize the stacks package. +// This may adjust stack sizes. +// Must be called after grt.options.decode. +// => procedure Stack_Init; +{ + int res; + INFO("grt_stack_init\n"); + INFO(" main_stack_context=0x%08x\n", &main_stack_context); + + +#if defined(__CYGWIN__) + res = pthread_mutexattr_init (&main_stack_context.mxAttr); + assert (res == 0); + res = pthread_mutexattr_settype (&main_stack_context.mxAttr, + PTHREAD_MUTEX_DEFAULT); + assert (res == 0); + res = pthread_mutex_init (&main_stack_context.mutex, + &main_stack_context.mxAttr); + assert (res == 0); +#else + res = pthread_mutex_init (&main_stack_context.mutex, NULL); + assert (res == 0); +#endif + // lock the mutex, as we are currently running + res = pthread_mutex_lock (&main_stack_context.mutex); + assert (res == 0); + + current = &main_stack_context; + + grt_set_main_stack (&main_stack_context); +} + +//---------------------------------------------------------------------------- +static void* grt_stack_loop(void* pv_myStack) +{ + Stack_Type myStack= (Stack_Type)pv_myStack; + + INFO("grt_stack_loop\n"); + + INFO(" myStack=0x%08x\n", myStack); + + // block until mutex becomes available again. + // this happens when this stack is enabled for the first time + pthread_mutex_lock(&(myStack->mutex)); + + // run stack's function in endless loop + while(1) + { + INFO(" call 0x%08x with 0x%08x\n", myStack->Func, myStack->Arg); + myStack->Func(myStack->Arg); + } + + // we never get here... + return 0; +} + +//---------------------------------------------------------------------------- +Stack_Type grt_stack_create(void* Func, void* Arg) +// Create a new stack, which on first execution will call FUNC with +// an argument ARG. +// => function Stack_Create (Func : Address; Arg : Address) return Stack_Type; +{ + Stack_Type newStack; + int res; + + INFO("grt_stack_create\n"); + INFO(" call 0x%08x with 0x%08x\n", Func, Arg); + + newStack = malloc (sizeof(Stack_Type_t)); + + // init function and argument + newStack->Func = Func; + newStack->Arg = Arg; + + // create mutex +#if defined(__CYGWIN__) + res = pthread_mutexattr_init (&newStack->mxAttr); + assert (res == 0); + res = pthread_mutexattr_settype (&newStack->mxAttr, PTHREAD_MUTEX_DEFAULT); + assert (res == 0); + res = pthread_mutex_init (&newStack->mutex, &newStack->mxAttr); + assert (res == 0); +#else + res = pthread_mutex_init (&newStack->mutex, NULL); + assert (res == 0); +#endif + + // block the mutex, so that thread will blocked in grt_stack_loop + res = pthread_mutex_lock (&newStack->mutex); + assert (res == 0); + + INFO(" newStack=0x%08x\n", newStack); + + // create thread, which executes grt_stack_loop + pthread_create (&newStack->thread, NULL, grt_stack_loop, newStack); + + return newStack; +} + +static int need_longjmp; +static int run_env_en; +static jmp_buf run_env; + +//---------------------------------------------------------------------------- +void grt_stack_switch(Stack_Type To, Stack_Type From) +// Resume stack TO and save the current context to the stack pointed by +// CUR. +// => procedure Stack_Switch (To : Stack_Type; From : Stack_Type); +{ + int res; + INFO("grt_stack_switch\n"); + INFO(" from 0x%08x to 0x%08x\n", From, To); + + current = To; + + // unlock 'To' mutex. this will make the other thread either + // - starts for first time in grt_stack_loop + // - resumes at lock below + res = pthread_mutex_unlock (&To->mutex); + assert (res == 0); + + // block until 'From' mutex becomes available again + // as we are running, our mutex is locked and we block here + // when stacks are switched, with above unlock, we may proceed + res = pthread_mutex_lock (&From->mutex); + assert (res == 0); + + if (From == &main_stack_context && need_longjmp != 0) + longjmp (run_env, need_longjmp); +} + +//---------------------------------------------------------------------------- +void grt_stack_delete(Stack_Type Stack) +// Delete stack STACK, which must not be currently executed. +// => procedure Stack_Delete (Stack : Stack_Type); +{ + INFO("grt_stack_delete\n"); +} + +void +__ghdl_maybe_return_via_longjump (int val) +{ + if (!run_env_en) + return; + + if (current != &main_stack_context) + { + need_longjmp = val; + grt_stack_switch (&main_stack_context, current); + } + else + longjmp (run_env, val); +} + +int +__ghdl_run_through_longjump (int (*func)(void)) +{ + int res; + + run_env_en = 1; + res = setjmp (run_env); + if (res == 0) + res = (*func)(); + run_env_en = 0; + return res; +} + + +//---------------------------------------------------------------------------- + +#ifndef WITH_GNAT_RUN_TIME +void __gnat_raise_storage_error(void) +{ + abort (); +} + +void __gnat_raise_program_error(void) +{ + abort (); +} +#endif /* WITH_GNAT_RUN_TIME */ + +//---------------------------------------------------------------------------- +// end of file + diff --git a/src/grt/config/sparc.S b/src/grt/config/sparc.S new file mode 100644 index 000000000..0ffe412ed --- /dev/null +++ b/src/grt/config/sparc.S @@ -0,0 +1,141 @@ +/* GRT stack implementation for x86. + Copyright (C) 2002 - 2014 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + .file "sparc.S" + + .section ".text" + + /* Stack structure is: + +4 : cur_length + +0 : cur_sp + -4 : return address + -8 : process function to be executed + -12: function argument + ... + -72: %sp + */ + + /* Function called to loop on the process. */ + .align 4 + .type grt_stack_loop,#function +grt_stack_loop: + ld [%sp + 64], %o1 + jmpl %o1 + 0, %o7 + ld [%sp + 68], %o0 + ba grt_stack_loop + nop + .size grt_stack_loop, . - grt_stack_loop + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; */ + .align 4 + .global grt_stack_create + .type grt_stack_create,#function +grt_stack_create: + /* Standard prologue. */ + save %sp,-80,%sp + + /* Allocate the stack, and exit in case of failure */ + call grt_stack_allocate + nop + cmp %o0, 0 + be .Ldone + nop + + /* Note: %o0 contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + + /* The return function. */ + sethi %hi(grt_stack_loop - 8), %l2 + or %lo(grt_stack_loop - 8), %l2, %l2 + + /* Create a frame for grt_stack_loop. */ + sub %o0, (64 + 8), %l1 + + /* The function to be executed. */ + st %i0, [%l1 + 64] + /* The argument. */ + st %i1, [%l1 + 68] + + /* Create a frame for grt_stack_switch. */ + sub %l1, 64, %l0 + + /* Save frame pointer. */ + st %l1, [%l0 + 56] + /* Save return address. */ + st %l2, [%l0 + 60] + + /* Save stack pointer. */ + st %l0, [%o0] + +.Ldone: + ret + restore %o0, %g0, %o0 + .size grt_stack_create,. - grt_stack_create + + + .align 4 + .global grt_stack_switch + /* Arguments: TO, FROM. + Both are pointers to a stack_context. */ + .type grt_stack_switch,#function +grt_stack_switch: + /* Standard prologue. */ + save %sp,-80,%sp + + /* Flush and invalidate windows. + It is not clear wether the current window is saved or not, + therefore, I assume it is not. + */ + ta 3 + + /* Only IN registers %fp and %i7 (return address) must be saved. + Of course, I could use std/ldd, but it is not as clear + */ + /* Save current frame pointer. */ + st %fp, [%sp + 56] + /* Save return address. */ + st %i7, [%sp + 60] + + /* Save stack pointer. */ + st %sp, [%i1] + + /* Load stack pointer. */ + ld [%i0], %sp + + /* Load return address. */ + ld [%sp + 60], %i7 + /* Load frame pointer. */ + ld [%sp + 56], %fp + + /* Return. */ + ret + restore + .size grt_stack_switch, . - grt_stack_switch + + + .ident "Written by T.Gingold" diff --git a/src/grt/config/teststack.c b/src/grt/config/teststack.c new file mode 100644 index 000000000..6a6966d6f --- /dev/null +++ b/src/grt/config/teststack.c @@ -0,0 +1,174 @@ +#include +#include + +extern void grt_stack_init (void); +extern void grt_stack_switch (void *from, void *to); +extern void *grt_stack_create (void (*func)(void *), void *arg); + +int stack_size = 4096; +int stack_max_size = 8 * 4096; + +static void *stack1; +static void *stack2; +void *grt_stack_main_stack; + +void *grt_cur_proc; + +static int step; + +void +grt_overflow_error (void) +{ + abort (); +} + +void +grt_stack_error_null_access (void) +{ + abort (); +} + +void +grt_stack_error_memory_access (void) +{ + abort (); +} + +void +grt_stack_error_grow_failed (void) +{ + abort (); +} + +void +error (void) +{ + printf ("Test failure at step %d\n", step); + fflush (stdout); + exit (1); +} + +static void +func1 (void *ptr) +{ + if (ptr != (void *)1) + error (); + + if (step != 0) + error (); + + step = 1; + + grt_stack_switch (grt_stack_main_stack, stack1); + + if (step != 5) + error (); + + step = 6; + + grt_stack_switch (grt_stack_main_stack, stack1); + + if (step != 7) + error (); + + step = 8; + + grt_stack_switch (stack2, stack1); + + if (step != 9) + error (); + + step = 10; + + grt_stack_switch (grt_stack_main_stack, stack1); + + error (); +} + +static void +func2 (void *ptr) +{ + if (ptr != (void *)2) + error (); + + if (step == 11) + { + step = 12; + + grt_stack_switch (grt_stack_main_stack, stack2); + + error (); + } + + if (step != 1) + error (); + + step = 2; + + grt_stack_switch (grt_stack_main_stack, stack2); + + if (step != 3) + error (); + + step = 4; + + grt_stack_switch (grt_stack_main_stack, stack2); + + if (step != 8) + error (); + + step = 9; + + grt_stack_switch (stack1, stack2); +} + +int +main (void) +{ + grt_stack_init (); + + stack1 = grt_stack_create (&func1, (void *)1); + stack2 = grt_stack_create (&func2, (void *)2); + + step = 0; + grt_stack_switch (stack1, grt_stack_main_stack); + + if (step != 1) + error (); + + grt_stack_switch (stack2, grt_stack_main_stack); + + if (step != 2) + error (); + + step = 3; + + grt_stack_switch (stack2, grt_stack_main_stack); + + if (step != 4) + error (); + + step = 5; + + grt_stack_switch (stack1, grt_stack_main_stack); + + if (step != 6) + error (); + + step = 7; + + grt_stack_switch (stack1, grt_stack_main_stack); + + if (step != 10) + error (); + + step = 11; + + grt_stack_switch (stack2, grt_stack_main_stack); + + if (step != 12) + error (); + + printf ("Test successful\n"); + return 0; +} diff --git a/src/grt/config/times.c b/src/grt/config/times.c new file mode 100644 index 000000000..9c0b4ebba --- /dev/null +++ b/src/grt/config/times.c @@ -0,0 +1,55 @@ +/* GRT C bindings for time. + Copyright (C) 2002 - 2014 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ +#include +#include + +int +grt_get_clk_tck (void) +{ + return sysconf (_SC_CLK_TCK); +} + +void +grt_get_times (int *wall, int *user, int *sys) +{ + clock_t res; + struct tms buf; + + res = times (&buf); + if (res == (clock_t)-1) + { + *wall = 0; + *user = 0; + *sys = 0; + } + else + { + *wall = res; + *user = buf.tms_utime; + *sys = buf.tms_stime; + } +} + diff --git a/src/grt/config/win32.c b/src/grt/config/win32.c new file mode 100644 index 000000000..35322ba9f --- /dev/null +++ b/src/grt/config/win32.c @@ -0,0 +1,265 @@ +/* GRT stack implementation for Win32 using fibers. + Copyright (C) 2005 - 2014 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + As a special exception, if other files instantiate generics from this + unit, or you link this unit with other files to produce an executable, + this unit does not by itself cause the resulting executable to be + covered by the GNU General Public License. This exception does not + however invalidate any other reasons why the executable file might be + covered by the GNU Public License. +*/ + +#include +#include +#include +#include +#include + +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 + +double acosh (double x) +{ + return log (x + sqrt (x*x - 1)); +} + +double asinh (double x) +{ + return log (x + sqrt (x*x + 1)); +} + +double atanh (double x) +{ + return log ((1 + x) / (1 - x)) / 2; +} + +#ifndef WITH_GNAT_RUN_TIME +void __gnat_raise_storage_error(void) +{ + abort (); +} + +void __gnat_raise_program_error(void) +{ + abort (); +} +#endif + diff --git a/src/grt/config/win32thr.c b/src/grt/config/win32thr.c new file mode 100644 index 000000000..bcebc49d5 --- /dev/null +++ b/src/grt/config/win32thr.c @@ -0,0 +1,167 @@ +/* GRT stack implementation for Win32 + Copyright (C) 2004, 2005 Felix Bertram. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ +//----------------------------------------------------------------------------- +// Project: GHDL - VHDL Simulator +// Description: Win32 port of stacks package +// Note: Tristan's original i386/Linux used assembly-code +// to manually switch stacks for performance reasons. +// History: 2004feb09, FB, created. +//----------------------------------------------------------------------------- + +#include +//#include +//#include +//#include + + +//#define INFO printf +#define INFO (void) + +// GHDL names an endless loop calling FUNC with ARG a 'stack' +// at a given time, only one stack may be 'executed' +typedef struct +{ HANDLE thread; // stack's thread + HANDLE mutex; // mutex to suspend/resume thread + void (*Func)(void*); // stack's FUNC + void* Arg; // ARG passed to FUNC +} Stack_Type_t, *Stack_Type; + + +static Stack_Type_t main_stack_context; +extern void grt_set_main_stack (Stack_Type_t *stack); + +//------------------------------------------------------------------------------ +void grt_stack_init(void) +// Initialize the stacks package. +// This may adjust stack sizes. +// Must be called after grt.options.decode. +// => procedure Stack_Init; +{ INFO("grt_stack_init\n"); + INFO(" main_stack_context=0x%08x\n", &main_stack_context); + + // create event. reset event, as we are currently running + main_stack_context.mutex = CreateEvent(NULL, // lpsa + FALSE, // fManualReset + FALSE, // fInitialState + NULL); // lpszEventName + + grt_set_main_stack (&main_stack_context); +} + +//------------------------------------------------------------------------------ +static unsigned long __stdcall grt_stack_loop(void* pv_myStack) +{ + Stack_Type myStack= (Stack_Type)pv_myStack; + + INFO("grt_stack_loop\n"); + + INFO(" myStack=0x%08x\n", myStack); + + // block until event becomes set again. + // this happens when this stack is enabled for the first time + WaitForSingleObject(myStack->mutex, INFINITE); + + // run stack's function in endless loop + while(1) + { INFO(" call 0x%08x with 0x%08x\n", myStack->Func, myStack->Arg); + myStack->Func(myStack->Arg); + } + + // we never get here... + return 0; +} + +//------------------------------------------------------------------------------ +Stack_Type grt_stack_create(void* Func, void* Arg) +// Create a new stack, which on first execution will call FUNC with +// an argument ARG. +// => function Stack_Create (Func : Address; Arg : Address) return Stack_Type; +{ Stack_Type newStack; + DWORD m_IDThread; // Thread's ID (dummy) + + INFO("grt_stack_create\n"); + INFO(" call 0x%08x with 0x%08x\n", Func, Arg); + + newStack= malloc(sizeof(Stack_Type_t)); + + // init function and argument + newStack->Func= Func; + newStack->Arg= Arg; + + // create event. reset event, so that thread will blocked in grt_stack_loop + newStack->mutex= CreateEvent(NULL, // lpsa + FALSE, // fManualReset + FALSE, // fInitialState + NULL); // lpszEventName + + INFO(" newStack=0x%08x\n", newStack); + + // create thread, which executes grt_stack_loop + newStack->thread= CreateThread(NULL, // lpsa + 0, // cbStack + grt_stack_loop, // lpStartAddr + newStack, // lpvThreadParm + 0, // fdwCreate + &m_IDThread); // lpIDThread + + return newStack; +} + +//------------------------------------------------------------------------------ +void grt_stack_switch(Stack_Type To, Stack_Type From) +// Resume stack TO and save the current context to the stack pointed by +// CUR. +// => procedure Stack_Switch (To : Stack_Type; From : Stack_Type); +{ INFO("grt_stack_switch\n"); + INFO(" from 0x%08x to 0x%08x\n", From, To); + + // set 'To' event. this will make the other thread either + // - start for first time in grt_stack_loop + // - resume at WaitForSingleObject below + SetEvent(To->mutex); + + // block until 'From' event becomes set again + // as we are running, our event is reset and we block here + // when stacks are switched, with above SetEvent, we may proceed + WaitForSingleObject(From->mutex, INFINITE); +} + +//------------------------------------------------------------------------------ +void grt_stack_delete(Stack_Type Stack) +// Delete stack STACK, which must not be currently executed. +// => procedure Stack_Delete (Stack : Stack_Type); +{ INFO("grt_stack_delete\n"); +} + +//---------------------------------------------------------------------------- +#ifndef WITH_GNAT_RUN_TIME +void __gnat_raise_storage_error(void) +{ + abort (); +} + +void __gnat_raise_program_error(void) +{ + abort (); +} +#endif + +//---------------------------------------------------------------------------- +// end of file + diff --git a/src/grt/ghdl_main.adb b/src/grt/ghdl_main.adb new file mode 100644 index 000000000..ce5b67d7e --- /dev/null +++ b/src/grt/ghdl_main.adb @@ -0,0 +1,61 @@ +-- GHDL Run Time (GRT) entry point. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Ada.Unchecked_Conversion; +with Grt.Options; use Grt.Options; +with Grt.Main; +with Grt.Types; use Grt.Types; + +-- Some files are only referenced from compiled code. With it here so that +-- they get compiled during build (and elaborated). +pragma Warnings (Off); +with Grt.Rtis_Binding; +with Grt.Std_Logic_1164; +pragma Warnings (On); + + +function Ghdl_Main (Argc : Integer; Argv : System.Address) + return Integer +is + -- Grt_Init corresponds to the 'adainit' subprogram for grt. + procedure Grt_Init; + pragma Import (C, Grt_Init, "grt_init"); + + function To_Argv_Type is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Grt.Options.Argv_Type); + + Default_Progname : constant String := "ghdl_design" & NUL; +begin + if Argc > 0 then + Grt.Options.Progname := To_Argv_Type (Argv)(0); + else + Grt.Options.Progname := To_Ghdl_C_String (Default_Progname'Address); + end if; + Grt.Options.Argc := Argc; + Grt.Options.Argv := To_Argv_Type (Argv); + + Grt_Init; + Grt.Main.Run; + return 0; +end Ghdl_Main; diff --git a/src/grt/ghdl_main.ads b/src/grt/ghdl_main.ads new file mode 100644 index 000000000..88d181a0a --- /dev/null +++ b/src/grt/ghdl_main.ads @@ -0,0 +1,33 @@ +-- GHDL Run Time (GRT) entry point. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; + +-- 'main' function for grt. +-- Contrary to the C main function, ARGC can be 0 (in this case a fake argv[0] +-- is used). +function Ghdl_Main (Argc : Integer; Argv : System.Address) + return Integer; +pragma Export (C, Ghdl_Main, "ghdl_main"); + diff --git a/src/grt/ghwdump.c b/src/grt/ghwdump.c new file mode 100644 index 000000000..4affc2b5c --- /dev/null +++ b/src/grt/ghwdump.c @@ -0,0 +1,195 @@ +/* Display a GHDL Wavefile for debugging. + Copyright (C) 2005 Tristan Gingold + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ + +#include +#include +#include +#include +#include + +#include "ghwlib.h" + +static const char *progname; +void +usage (void) +{ + printf ("usage: %s [OPTIONS] FILEs...\n", progname); + printf ("Options are:\n" + " -t display types\n" + " -h display hierarchy\n" + " -T display time\n" + " -s display signals (and time)\n" + " -l display list of sections\n" + " -v verbose\n"); +} + +int +main (int argc, char **argv) +{ + int i; + int flag_disp_types; + int flag_disp_hierarchy; + int flag_disp_time; + int flag_disp_signals; + int flag_list; + int flag_verbose; + int eof; + enum ghw_sm_type sm; + + progname = argv[0]; + flag_disp_types = 0; + flag_disp_hierarchy = 0; + flag_disp_time = 0; + flag_disp_signals = 0; + flag_list = 0; + flag_verbose = 0; + + while (1) + { + int c; + + c = getopt (argc, argv, "thTslv"); + if (c == -1) + break; + switch (c) + { + case 't': + flag_disp_types = 1; + break; + case 'h': + flag_disp_hierarchy = 1; + break; + case 'T': + flag_disp_time = 1; + break; + case 's': + flag_disp_signals = 1; + flag_disp_time = 1; + break; + case 'l': + flag_list = 1; + break; + case 'v': + flag_verbose++; + break; + default: + usage (); + exit (2); + } + } + + if (optind >= argc) + { + usage (); + return 1; + } + + for (i = optind; i < argc; i++) + { + struct ghw_handler h; + struct ghw_handler *hp = &h; + + hp->flag_verbose = flag_verbose; + + if (ghw_open (hp, argv[i]) != 0) + { + fprintf (stderr, "cannot open ghw file %s\n", argv[i]); + return 1; + } + if (flag_list) + { + while (1) + { + int section; + + section = ghw_read_section (hp); + if (section == -2) + { + printf ("eof of file\n"); + break; + } + else if (section < 0) + { + printf ("Error in file\n"); + break; + } + else if (section == 0) + { + printf ("Unknown section\n"); + break; + } + printf ("Section %s\n", ghw_sections[section].name); + if ((*ghw_sections[section].handler)(hp) < 0) + break; + } + } + else + { + if (ghw_read_base (hp) < 0) + { + fprintf (stderr, "cannot read ghw file\n"); + return 2; + } + if (0) + { + int i; + printf ("String table:\n"); + + for (i = 1; i < hp->nbr_str; i++) + printf (" %s\n", hp->str_table[i]); + } + if (flag_disp_types) + ghw_disp_types (hp); + if (flag_disp_hierarchy) + ghw_disp_hie (hp, hp->hie); + +#if 1 + sm = ghw_sm_init; + eof = 0; + while (!eof) + { + switch (ghw_read_sm (hp, &sm)) + { + case ghw_res_snapshot: + case ghw_res_cycle: + if (flag_disp_time) + printf ("Time is %lld fs\n", hp->snap_time); + if (flag_disp_signals) + ghw_disp_values (hp); + break; + case ghw_res_eof: + eof = 1; + break; + default: + abort (); + } + } + +#else + if (ghw_read_dump (hp) < 0) + { + fprintf (stderr, "error in ghw dump\n"); + return 3; + } +#endif + } + ghw_close (&h); + } + return 0; +} diff --git a/src/grt/ghwlib.c b/src/grt/ghwlib.c new file mode 100644 index 000000000..2db63d9c9 --- /dev/null +++ b/src/grt/ghwlib.c @@ -0,0 +1,1746 @@ +/* GHDL Wavefile reader library. + Copyright (C) 2005 Tristan Gingold + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ + +#include +#include +#include +#include + +#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] = ""; + p = h->str_content; + prev_len = 0; + for (i = 1; i < h->nbr_str; i++) + { + int j; + int c; + char *prev; + int sh; + + h->str_table[i] = p; + prev = h->str_table[i - 1]; + for (j = 0; j < prev_len; j++) + *p++ = prev[j]; + + while (1) + { + c = fgetc (h->stream); + if (c == EOF) + return -1; + if ((c >= 0 && c <= 31) + || (c >= 128 && c <= 159)) + break; + *p++ = c; + } + *p++ = 0; + + if (h->flag_verbose > 1) + printf (" string %d (pl=%d): %s\n", i, prev_len, h->str_table[i]); + + prev_len = c & 0x1f; + sh = 5; + while (c >= 128) + { + c = fgetc (h->stream); + if (c == EOF) + return -1; + prev_len |= (c & 0x1f) << sh; + sh += 5; + } + } + if (fread (hdr, 4, 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "EOS", 4) != 0) + return -1; + return 0; +} + +union ghw_type * +ghw_get_base_type (union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + case ghdl_rtik_type_e32: + case ghdl_rtik_type_i32: + case ghdl_rtik_type_i64: + case ghdl_rtik_type_f64: + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + return t; + case ghdl_rtik_subtype_scalar: + return t->ss.base; + case ghdl_rtik_subtype_array: + return (union ghw_type*)(t->sa.base); + default: + fprintf (stderr, "ghw_get_base_type: cannot handle type %d\n", t->kind); + abort (); + } +} + +int +get_nbr_elements (union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + case ghdl_rtik_type_e32: + case ghdl_rtik_type_i32: + case ghdl_rtik_type_i64: + case ghdl_rtik_type_f64: + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + case ghdl_rtik_subtype_scalar: + return 1; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + return t->sa.nbr_el; + case ghdl_rtik_type_record: + return t->rec.nbr_el; + default: + fprintf (stderr, "get_nbr_elements: unhandled type %d\n", t->kind); + abort (); + } +} + +int +get_range_length (union ghw_range *rng) +{ + switch (rng->kind) + { + case ghdl_rtik_type_i32: + if (rng->i32.dir) + return (rng->i32.left - rng->i32.right + 1); + else + return (rng->i32.right - rng->i32.left + 1); + default: + fprintf (stderr, "get_range_length: unhandled kind %d\n", rng->kind); + abort (); + } +} + +int +ghw_read_type (struct ghw_handler *h) +{ + unsigned char hdr[8]; + int i; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + h->nbr_types = ghw_get_i32 (h, &hdr[4]); + h->types = (union ghw_type **) + malloc (h->nbr_types * sizeof (union ghw_type *)); + + for (i = 0; i < h->nbr_types; i++) + { + int t; + + t = fgetc (h->stream); + if (t == EOF) + return -1; + /* printf ("type[%d]= %d\n", i, t); */ + switch (t) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + { + struct ghw_type_enum *e; + int j; + + e = malloc (sizeof (struct ghw_type_enum)); + e->kind = t; + e->wkt = ghw_wkt_unknown; + e->name = ghw_read_strid (h); + if (ghw_read_uleb128 (h, &e->nbr) != 0) + return -1; + e->lits = (const char **) malloc (e->nbr * sizeof (char *)); + if (h->flag_verbose > 1) + printf ("enum %s:", e->name); + for (j = 0; j < e->nbr; j++) + { + e->lits[j] = ghw_read_strid (h); + if (h->flag_verbose > 1) + printf (" %s", e->lits[j]); + } + if (h->flag_verbose > 1) + printf ("\n"); + h->types[i] = (union ghw_type *)e; + } + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_i64: + case ghdl_rtik_type_f64: + { + struct ghw_type_scalar *sc; + + sc = malloc (sizeof (struct ghw_type_scalar)); + sc->kind = t; + sc->name = ghw_read_strid (h); + if (h->flag_verbose > 1) + printf ("scalar: %s\n", sc->name); + h->types[i] = (union ghw_type *)sc; + } + break; + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + { + struct ghw_type_physical *ph; + + ph = malloc (sizeof (struct ghw_type_physical)); + ph->kind = t; + ph->name = ghw_read_strid (h); + if (h->version == 0) + ph->nbr_units = 0; + else + { + int i; + + if (ghw_read_uleb128 (h, &ph->nbr_units) != 0) + return -1; + ph->units = malloc (ph->nbr_units * sizeof (struct ghw_unit)); + for (i = 0; i < ph->nbr_units; i++) + { + ph->units[i].name = ghw_read_strid (h); + if (ghw_read_lsleb128 (h, &ph->units[i].val) < 0) + return -1; + } + } + if (h->flag_verbose > 1) + printf ("physical: %s\n", ph->name); + h->types[i] = (union ghw_type *)ph; + } + break; + case ghdl_rtik_subtype_scalar: + { + struct ghw_subtype_scalar *ss; + + ss = malloc (sizeof (struct ghw_subtype_scalar)); + ss->kind = t; + ss->name = ghw_read_strid (h); + ss->base = ghw_read_typeid (h); + ss->rng = ghw_read_range (h); + if (h->flag_verbose > 1) + printf ("subtype scalar: %s\n", ss->name); + h->types[i] = (union ghw_type *)ss; + } + break; + case ghdl_rtik_type_array: + { + struct ghw_type_array *arr; + int j; + + arr = malloc (sizeof (struct ghw_type_array)); + arr->kind = t; + arr->name = ghw_read_strid (h); + arr->el = ghw_read_typeid (h); + if (ghw_read_uleb128 (h, &arr->nbr_dim) != 0) + return -1; + arr->dims = (union ghw_type **) + malloc (arr->nbr_dim * sizeof (union ghw_type *)); + for (j = 0; j < arr->nbr_dim; j++) + arr->dims[j] = ghw_read_typeid (h); + if (h->flag_verbose > 1) + printf ("array: %s\n", arr->name); + h->types[i] = (union ghw_type *)arr; + } + break; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + { + struct ghw_subtype_array *sa; + int j; + int nbr_el; + + sa = malloc (sizeof (struct ghw_subtype_array)); + sa->kind = t; + sa->name = ghw_read_strid (h); + sa->base = (struct ghw_type_array *)ghw_read_typeid (h); + nbr_el = get_nbr_elements (sa->base->el); + sa->rngs = malloc (sa->base->nbr_dim * sizeof (union ghw_range *)); + for (j = 0; j < sa->base->nbr_dim; j++) + { + sa->rngs[j] = ghw_read_range (h); + nbr_el *= get_range_length (sa->rngs[j]); + } + sa->nbr_el = nbr_el; + if (h->flag_verbose > 1) + printf ("subtype array: %s (nbr_el=%d)\n", sa->name, sa->nbr_el); + h->types[i] = (union ghw_type *)sa; + } + break; + case ghdl_rtik_type_record: + { + struct ghw_type_record *rec; + int j; + int nbr_el; + + rec = malloc (sizeof (struct ghw_type_record)); + rec->kind = t; + rec->name = ghw_read_strid (h); + if (ghw_read_uleb128 (h, &rec->nbr_fields) != 0) + return -1; + rec->el = malloc + (rec->nbr_fields * sizeof (struct ghw_record_element)); + nbr_el = 0; + for (j = 0; j < rec->nbr_fields; j++) + { + rec->el[j].name = ghw_read_strid (h); + rec->el[j].type = ghw_read_typeid (h); + nbr_el += get_nbr_elements (rec->el[j].type); + } + rec->nbr_el = nbr_el; + if (h->flag_verbose > 1) + printf ("record type: %s (nbr_el=%d)\n", rec->name, rec->nbr_el); + h->types[i] = (union ghw_type *)rec; + } + break; + default: + fprintf (stderr, "ghw_read_type: unknown type %d\n", t); + return -1; + } + } + if (fgetc (h->stream) != 0) + return -1; + return 0; +} + +int +ghw_read_wk_types (struct ghw_handler *h) +{ + char hdr[4]; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + + while (1) + { + int t; + union ghw_type *tid; + + t = fgetc (h->stream); + if (t == EOF) + return -1; + else if (t == 0) + break; + + tid = ghw_read_typeid (h); + if (tid->kind == ghdl_rtik_type_b2 + || tid->kind == ghdl_rtik_type_e8) + { + if (h->flag_verbose > 0) + printf ("%s: wkt=%d\n", tid->en.name, t); + tid->en.wkt = t; + } + } + return 0; +} + +void +ghw_disp_typename (struct ghw_handler *h, union ghw_type *t) +{ + printf ("%s", t->common.name); +} + +/* Read a signal composed of severals elements. */ +int +ghw_read_signal (struct ghw_handler *h, unsigned int *sigs, union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + case ghdl_rtik_type_e32: + case ghdl_rtik_subtype_scalar: + { + unsigned int sig_el; + + if (ghw_read_uleb128 (h, &sig_el) < 0) + return -1; + *sigs = sig_el; + if (sig_el >= h->nbr_sigs) + abort (); + if (h->sigs[sig_el].type == NULL) + h->sigs[sig_el].type = ghw_get_base_type (t); + } + return 0; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + { + int i; + int stride; + int len; + + len = t->sa.nbr_el; + stride = get_nbr_elements (t->sa.base->el); + + for (i = 0; i < len; i += stride) + if (ghw_read_signal (h, &sigs[i], t->sa.base->el) < 0) + return -1; + } + return 0; + case ghdl_rtik_type_record: + { + int i; + int off; + + off = 0; + for (i = 0; i < t->rec.nbr_fields; i++) + { + if (ghw_read_signal (h, &sigs[off], t->rec.el[i].type) < 0) + return -1; + off += get_nbr_elements (t->rec.el[i].type); + } + } + return 0; + default: + fprintf (stderr, "ghw_read_signal: type kind %d unhandled\n", t->kind); + abort (); + } +} + + +int +ghw_read_value (struct ghw_handler *h, + union ghw_val *val, union ghw_type *type) +{ + switch (ghw_get_base_type (type)->kind) + { + case ghdl_rtik_type_b2: + { + int v; + v = fgetc (h->stream); + if (v == EOF) + return -1; + val->b2 = v; + } + break; + case ghdl_rtik_type_e8: + { + int v; + v = fgetc (h->stream); + if (v == EOF) + return -1; + val->e8 = v; + } + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_p32: + { + int32_t v; + if (ghw_read_sleb128 (h, &v) < 0) + return -1; + val->i32 = v; + } + break; + case ghdl_rtik_type_f64: + { + double v; + if (ghw_read_f64 (h, &v) < 0) + return -1; + val->f64 = v; + } + break; + case ghdl_rtik_type_p64: + { + int64_t v; + if (ghw_read_lsleb128 (h, &v) < 0) + return -1; + val->i64 = v; + } + break; + default: + fprintf (stderr, "read_value: cannot handle format %d\n", type->kind); + abort (); + } + return 0; +} + +int +ghw_read_hie (struct ghw_handler *h) +{ + unsigned char hdr[16]; + int nbr_scopes; + int nbr_sigs; + int i; + struct ghw_hie *blk; + struct ghw_hie **last; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + nbr_scopes = ghw_get_i32 (h, &hdr[4]); + /* Number of declared signals (which may be composite). */ + nbr_sigs = ghw_get_i32 (h, &hdr[8]); + /* Number of basic signals. */ + h->nbr_sigs = ghw_get_i32 (h, &hdr[12]); + + if (h->flag_verbose) + printf ("%d scopes, %d signals, %d signal elements\n", + nbr_scopes, nbr_sigs, h->nbr_sigs); + + blk = (struct ghw_hie *)malloc (sizeof (struct ghw_hie)); + blk->kind = ghw_hie_design; + blk->name = NULL; + blk->parent = NULL; + blk->brother = NULL; + blk->u.blk.child = NULL; + + last = &blk->u.blk.child; + h->hie = blk; + + h->nbr_sigs++; + h->sigs = (struct ghw_sig *) malloc (h->nbr_sigs * sizeof (struct ghw_sig)); + memset (h->sigs, 0, h->nbr_sigs * sizeof (struct ghw_sig)); + + while (1) + { + int t; + struct ghw_hie *el; + unsigned int str; + + t = fgetc (h->stream); + if (t == EOF) + return -1; + if (t == 0) + break; + + if (t == ghw_hie_eos) + { + blk = blk->parent; + if (blk->u.blk.child == NULL) + last = &blk->u.blk.child; + else + { + struct ghw_hie *l = blk->u.blk.child; + while (l->brother != NULL) + l = l->brother; + last = &l->brother; + } + + continue; + } + + el = (struct ghw_hie *) malloc (sizeof (struct ghw_hie)); + el->kind = t; + el->parent = blk; + el->brother = NULL; + + /* Link. */ + *last = el; + last = &el->brother; + + /* Read name. */ + if (ghw_read_uleb128 (h, &str) != 0) + return -1; + el->name = h->str_table[str]; + + switch (t) + { + case ghw_hie_eoh: + case ghw_hie_design: + case ghw_hie_eos: + /* Should not be here. */ + abort (); + case ghw_hie_process: + break; + case ghw_hie_block: + case ghw_hie_generate_if: + case ghw_hie_generate_for: + case ghw_hie_instance: + case ghw_hie_generic: + case ghw_hie_package: + /* Create a block. */ + el->u.blk.child = NULL; + + if (t == ghw_hie_generate_for) + { + el->u.blk.iter_type = ghw_read_typeid (h); + el->u.blk.iter_value = malloc (sizeof (union ghw_val)); + if (ghw_read_value (h, el->u.blk.iter_value, + el->u.blk.iter_type) < 0) + return -1; + } + blk = el; + last = &el->u.blk.child; + break; + case ghw_hie_signal: + case ghw_hie_port_in: + case ghw_hie_port_out: + case ghw_hie_port_inout: + case ghw_hie_port_buffer: + case ghw_hie_port_linkage: + /* For a signal, read type. */ + { + int nbr_el; + unsigned int *sigs; + + el->u.sig.type = ghw_read_typeid (h); + nbr_el = get_nbr_elements (el->u.sig.type); + sigs = (unsigned int *) malloc + ((nbr_el + 1) * sizeof (unsigned int)); + el->u.sig.sigs = sigs; + /* Last element is NULL. */ + sigs[nbr_el] = 0; + + if (h->flag_verbose > 1) + printf ("signal %s: %d el [", el->name, nbr_el); + if (ghw_read_signal (h, sigs, el->u.sig.type) < 0) + return -1; + if (h->flag_verbose > 1) + { + int i; + for (i = 0; i < nbr_el; i++) + printf (" #%u", sigs[i]); + printf ("]\n"); + } + } + break; + default: + fprintf (stderr, "ghw_read_hie: unhandled kind %d\n", t); + abort (); + } + } + + /* Allocate values. */ + for (i = 0; i < h->nbr_sigs; i++) + if (h->sigs[i].type != NULL) + h->sigs[i].val = (union ghw_val *) malloc (sizeof (union ghw_val)); + return 0; +} + +const char * +ghw_get_hie_name (struct ghw_hie *h) +{ + switch (h->kind) + { + case ghw_hie_eoh: + return "eoh"; + case ghw_hie_design: + return "design"; + case ghw_hie_block: + return "block"; + case ghw_hie_generate_if: + return "generate-if"; + case ghw_hie_generate_for: + return "generate-for"; + case ghw_hie_instance: + return "instance"; + case ghw_hie_package: + return "package"; + case ghw_hie_process: + return "process"; + case ghw_hie_generic: + return "generic"; + case ghw_hie_eos: + return "eos"; + case ghw_hie_signal: + return "signal"; + case ghw_hie_port_in: + return "port-in"; + case ghw_hie_port_out: + return "port-out"; + case ghw_hie_port_inout: + return "port-inout"; + case ghw_hie_port_buffer: + return "port-buffer"; + case ghw_hie_port_linkage: + return "port-linkage"; + default: + return "??"; + } +} + +void +ghw_disp_value (union ghw_val *val, union ghw_type *type); + +void +ghw_disp_hie (struct ghw_handler *h, struct ghw_hie *top) +{ + int i; + int indent; + struct ghw_hie *hie; + struct ghw_hie *n; + + hie = top; + indent = 0; + + while (1) + { + for (i = 0; i < indent; i++) + fputc (' ', stdout); + printf ("%s", ghw_get_hie_name (hie)); + + switch (hie->kind) + { + case ghw_hie_design: + case ghw_hie_block: + case ghw_hie_generate_if: + case ghw_hie_generate_for: + case ghw_hie_instance: + case ghw_hie_process: + case ghw_hie_package: + if (hie->name) + printf (" %s", hie->name); + if (hie->kind == ghw_hie_generate_for) + { + printf ("("); + ghw_disp_value (hie->u.blk.iter_value, hie->u.blk.iter_type); + printf (")"); + } + n = hie->u.blk.child; + if (n == NULL) + n = hie->brother; + else + indent++; + break; + case ghw_hie_generic: + case ghw_hie_eos: + abort (); + case ghw_hie_signal: + case ghw_hie_port_in: + case ghw_hie_port_out: + case ghw_hie_port_inout: + case ghw_hie_port_buffer: + case ghw_hie_port_linkage: + { + unsigned int *sigs; + + printf (" %s: ", hie->name); + ghw_disp_typename (h, hie->u.sig.type); + for (sigs = hie->u.sig.sigs; *sigs != 0; sigs++) + printf (" #%u", *sigs); + n = hie->brother; + } + break; + default: + abort (); + } + printf ("\n"); + + while (n == NULL) + { + if (hie->parent == NULL) + return; + hie = hie->parent; + indent--; + n = hie->brother; + } + hie = n; + } +} + +int +ghw_read_eoh (struct ghw_handler *h) +{ + return 0; +} + + +int +ghw_read_base (struct ghw_handler *h) +{ + unsigned char hdr[4]; + int res; + + while (1) + { + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "STR", 4) == 0) + res = ghw_read_str (h); + else if (memcmp (hdr, "HIE", 4) == 0) + res = ghw_read_hie (h); + else if (memcmp (hdr, "TYP", 4) == 0) + res = ghw_read_type (h); + else if (memcmp (hdr, "WKT", 4) == 0) + res = ghw_read_wk_types (h); + else if (memcmp (hdr, "EOH", 4) == 0) + return 0; + else + { + fprintf (stderr, "ghw_read_base: unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return -1; + } + if (res != 0) + { + fprintf (stderr, "ghw_read_base: error in section %s\n", hdr); + return res; + } + } +} + +int +ghw_read_signal_value (struct ghw_handler *h, struct ghw_sig *s) +{ + return ghw_read_value (h, s->val, s->type); +} + +int +ghw_read_snapshot (struct ghw_handler *h) +{ + unsigned char hdr[12]; + int i; + struct ghw_sig *s; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + h->snap_time = ghw_get_i64 (h, &hdr[4]); + if (h->flag_verbose > 1) + printf ("Time is %lld fs\n", h->snap_time); + + for (i = 0; i < h->nbr_sigs; i++) + { + s = &h->sigs[i]; + if (s->type != NULL) + { + if (h->flag_verbose > 1) + printf ("read type %d for sig %d\n", s->type->kind, i); + if (ghw_read_signal_value (h, s) < 0) + return -1; + } + } + if (fread (hdr, 4, 1, h->stream) != 1) + return -1; + + if (memcmp (hdr, "ESN", 4)) + return -1; + + return 0; +} + +void ghw_disp_values (struct ghw_handler *h); + +int +ghw_read_cycle_start (struct ghw_handler *h) +{ + unsigned char hdr[8]; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + h->snap_time = ghw_get_i64 (h, hdr); + return 0; +} + +int +ghw_read_cycle_cont (struct ghw_handler *h, int *list) +{ + int i; + int *list_p; + + i = 0; + list_p = list; + while (1) + { + uint32_t d; + + /* Read delta to next signal. */ + if (ghw_read_uleb128 (h, &d) < 0) + return -1; + if (d == 0) + { + /* Last signal reached. */ + break; + } + + /* Find next signal. */ + while (d > 0) + { + i++; + if (h->sigs[i].type != NULL) + d--; + } + + if (ghw_read_signal_value (h, &h->sigs[i]) < 0) + return -1; + if (list_p) + *list_p++ = i; + } + + if (list_p) + *list_p = 0; + return 0; +} + +int +ghw_read_cycle_next (struct ghw_handler *h) +{ + int64_t d_time; + + if (ghw_read_lsleb128 (h, &d_time) < 0) + return -1; + if (d_time == -1) + return 0; + h->snap_time += d_time; + return 1; +} + + +int +ghw_read_cycle_end (struct ghw_handler *h) +{ + char hdr[4]; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "ECY", 4)) + return -1; + + return 0; +} + +static const char * +ghw_get_lit (union ghw_type *type, int e) +{ + if (e >= type->en.nbr || e < 0) + return "??"; + else + return type->en.lits[e]; +} + +static void +ghw_disp_lit (union ghw_type *type, int e) +{ + printf ("%s (%d)", ghw_get_lit (type, e), e); +} + +void +ghw_disp_value (union ghw_val *val, union ghw_type *type) +{ + switch (ghw_get_base_type (type)->kind) + { + case ghdl_rtik_type_b2: + ghw_disp_lit (type, val->b2); + break; + case ghdl_rtik_type_e8: + ghw_disp_lit (type, val->e8); + break; + case ghdl_rtik_type_i32: + printf ("%d", val->i32); + break; + case ghdl_rtik_type_p64: + printf ("%lld", val->i64); + break; + case ghdl_rtik_type_f64: + printf ("%g", val->f64); + break; + default: + fprintf (stderr, "ghw_disp_value: cannot handle type %d\n", + type->kind); + abort (); + } +} + +/* Put the ASCII representation of VAL into BUF, whose size if LEN. + A NUL is always written to BUF. +*/ +void +ghw_get_value (char *buf, int len, union ghw_val *val, union ghw_type *type) +{ + switch (ghw_get_base_type (type)->kind) + { + case ghdl_rtik_type_b2: + if (val->b2 <= 1) + { + strncpy (buf, type->en.lits[val->b2], len - 1); + buf[len - 1] = 0; + } + else + { + snprintf (buf, len, "?%d", val->b2); + } + break; + case ghdl_rtik_type_e8: + if (val->b2 <= type->en.nbr) + { + strncpy (buf, type->en.lits[val->e8], len - 1); + buf[len - 1] = 0; + } + else + { + snprintf (buf, len, "?%d", val->e8); + } + break; + case ghdl_rtik_type_i32: + snprintf (buf, len, "%d", val->i32); + break; + case ghdl_rtik_type_p64: + snprintf (buf, len, "%lld", val->i64); + break; + case ghdl_rtik_type_f64: + snprintf (buf, len, "%g", val->f64); + break; + default: + snprintf (buf, len, "?bad type %d?", type->kind); + } +} + +void +ghw_disp_values (struct ghw_handler *h) +{ + int i; + + for (i = 0; i < h->nbr_sigs; i++) + { + struct ghw_sig *s = &h->sigs[i]; + if (s->type != NULL) + { + printf ("#%d: ", i); + ghw_disp_value (s->val, s->type); + printf ("\n"); + } + } +} + +int +ghw_read_directory (struct ghw_handler *h) +{ + unsigned char hdr[8]; + int nbr_entries; + int i; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + nbr_entries = ghw_get_i32 (h, &hdr[4]); + + if (h->flag_verbose) + printf ("Directory (%d entries):\n", nbr_entries); + + for (i = 0; i < nbr_entries; i++) + { + unsigned char ent[8]; + int pos; + + if (fread (ent, sizeof (ent), 1, h->stream) != 1) + return -1; + + pos = ghw_get_i32 (h, &ent[4]); + if (h->flag_verbose) + printf (" %s at %d\n", ent, pos); + } + + if (fread (hdr, 4, 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "EOD", 4)) + return -1; + return 0; +} + +int +ghw_read_tailer (struct ghw_handler *h) +{ + unsigned char hdr[8]; + int pos; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + pos = ghw_get_i32 (h, &hdr[4]); + + if (h->flag_verbose) + printf ("Tailer: directory at %d\n", pos); + return 0; +} + +enum ghw_res +ghw_read_sm_hdr (struct ghw_handler *h, int *list) +{ + unsigned char hdr[4]; + int res; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + { + if (feof (h->stream)) + return ghw_res_eof; + else + return ghw_res_error; + } + if (memcmp (hdr, "SNP", 4) == 0) + { + res = ghw_read_snapshot (h); + if (res < 0) + return res; + return ghw_res_snapshot; + } + else if (memcmp (hdr, "CYC", 4) == 0) + { + res = ghw_read_cycle_start (h); + if (res < 0) + return res; + res = ghw_read_cycle_cont (h, list); + if (res < 0) + return res; + + return ghw_res_cycle; + } + else if (memcmp (hdr, "DIR", 4) == 0) + { + res = ghw_read_directory (h); + } + else if (memcmp (hdr, "TAI", 4) == 0) + { + res = ghw_read_tailer (h); + } + else + { + fprintf (stderr, "unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return -1; + } + if (res != 0) + return res; + return ghw_res_other; +} + +int +ghw_read_sm (struct ghw_handler *h, enum ghw_sm_type *sm) +{ + int res; + + while (1) + { + /* printf ("sm: state = %d\n", *sm); */ + switch (*sm) + { + case ghw_sm_init: + case ghw_sm_sect: + res = ghw_read_sm_hdr (h, NULL); + switch (res) + { + case ghw_res_other: + break; + case ghw_res_snapshot: + *sm = ghw_sm_sect; + return res; + case ghw_res_cycle: + *sm = ghw_sm_cycle; + return res; + default: + return res; + } + break; + case ghw_sm_cycle: + if (0) + printf ("Time is %lld fs\n", h->snap_time); + if (0) + ghw_disp_values (h); + + res = ghw_read_cycle_next (h); + if (res < 0) + return res; + if (res == 1) + { + res = ghw_read_cycle_cont (h, NULL); + if (res < 0) + return res; + return ghw_res_cycle; + } + res = ghw_read_cycle_end (h); + if (res < 0) + return res; + *sm = ghw_sm_sect; + break; + } + } +} + +int +ghw_read_cycle (struct ghw_handler *h) +{ + int res; + + res = ghw_read_cycle_start (h); + if (res < 0) + return res; + while (1) + { + res = ghw_read_cycle_cont (h, NULL); + if (res < 0) + return res; + + if (0) + printf ("Time is %lld fs\n", h->snap_time); + if (0) + ghw_disp_values (h); + + + res = ghw_read_cycle_next (h); + if (res < 0) + return res; + if (res == 0) + break; + } + res = ghw_read_cycle_end (h); + return res; +} + +int +ghw_read_dump (struct ghw_handler *h) +{ + unsigned char hdr[4]; + int res; + + while (1) + { + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + { + if (feof (h->stream)) + return 0; + else + return -1; + } + if (memcmp (hdr, "SNP", 4) == 0) + { + res = ghw_read_snapshot (h); + if (0 && res >= 0) + ghw_disp_values (h); + } + else if (memcmp (hdr, "CYC", 4) == 0) + { + res = ghw_read_cycle (h); + } + else if (memcmp (hdr, "DIR", 4) == 0) + { + res = ghw_read_directory (h); + } + else if (memcmp (hdr, "TAI", 4) == 0) + { + res = ghw_read_tailer (h); + } + else + { + fprintf (stderr, "unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return -1; + } + if (res != 0) + return res; + } +} + +struct ghw_section ghw_sections[] = { + { "\0\0\0", NULL }, + { "STR", ghw_read_str }, + { "HIE", ghw_read_hie }, + { "TYP", ghw_read_type }, + { "WKT", ghw_read_wk_types }, + { "EOH", ghw_read_eoh }, + { "SNP", ghw_read_snapshot }, + { "CYC", ghw_read_cycle }, + { "DIR", ghw_read_directory }, + { "TAI", ghw_read_tailer } +}; + +int +ghw_read_section (struct ghw_handler *h) +{ + unsigned char hdr[4]; + int i; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + { + if (feof (h->stream)) + return -2; + else + return -1; + } + + for (i = 1; i < sizeof (ghw_sections) / sizeof (*ghw_sections); i++) + if (memcmp (hdr, ghw_sections[i].name, 4) == 0) + return i; + + fprintf (stderr, "ghw_read_section: unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return 0; +} + +void +ghw_close (struct ghw_handler *h) +{ + if (h->stream) + { + fclose (h->stream); + h->stream = NULL; + } +} + +const char * +ghw_get_dir (int is_downto) +{ + return is_downto ? "downto" : "to"; +} + +void +ghw_disp_range (union ghw_type *type, union ghw_range *rng) +{ + switch (rng->kind) + { + case ghdl_rtik_type_e8: + printf ("%s %s %s", ghw_get_lit (type, rng->e8.left), + ghw_get_dir (rng->e8.dir), ghw_get_lit (type, rng->e8.right)); + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_p32: + printf ("%d %s %d", + rng->i32.left, ghw_get_dir (rng->i32.dir), rng->i32.right); + break; + case ghdl_rtik_type_i64: + case ghdl_rtik_type_p64: + printf ("%lld %s %lld", + rng->i64.left, ghw_get_dir (rng->i64.dir), rng->i64.right); + break; + case ghdl_rtik_type_f64: + printf ("%g %s %g", + rng->f64.left, ghw_get_dir (rng->f64.dir), rng->f64.right); + break; + default: + printf ("?(%d)", rng->kind); + } +} + +void +ghw_disp_type (struct ghw_handler *h, union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + { + struct ghw_type_enum *e = &t->en; + int i; + + printf ("type %s is (", e->name); + for (i = 0; i < e->nbr; i++) + { + if (i != 0) + printf (", "); + printf ("%s", e->lits[i]); + } + printf (");"); + if (e->wkt != ghw_wkt_unknown) + printf (" -- WKT:%d", e->wkt); + printf ("\n"); + } + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_f64: + { + struct ghw_type_scalar *s = &t->sc; + printf ("type %s is range <>;\n", s->name); + } + break; + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + { + int i; + + struct ghw_type_physical *p = &t->ph; + printf ("type %s is range <> units\n", p->name); + for (i = 0; i < p->nbr_units; i++) + { + struct ghw_unit *u = &p->units[i]; + printf (" %s = %lld %s;\n", u->name, u->val, p->units[0].name); + } + printf ("end units\n"); + } + break; + case ghdl_rtik_subtype_scalar: + { + struct ghw_subtype_scalar *s = &t->ss; + printf ("subtype %s is ", s->name); + ghw_disp_typename (h, s->base); + printf (" range "); + ghw_disp_range (s->base, s->rng); + printf (";\n"); + } + break; + case ghdl_rtik_type_array: + { + struct ghw_type_array *a = &t->ar; + int i; + + printf ("type %s is array (", a->name); + for (i = 0; i < a->nbr_dim; i++) + { + if (i != 0) + printf (", "); + ghw_disp_typename (h, a->dims[i]); + printf (" range <>"); + } + printf (") of "); + ghw_disp_typename (h, a->el); + printf (";\n"); + } + break; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + { + struct ghw_subtype_array *a = &t->sa; + int i; + + printf ("subtype %s is ", a->name); + ghw_disp_typename (h, (union ghw_type *)a->base); + printf (" ("); + for (i = 0; i < a->base->nbr_dim; i++) + { + if (i != 0) + printf (", "); + ghw_disp_range ((union ghw_type *)a->base, a->rngs[i]); + } + printf (");\n"); + } + break; + case ghdl_rtik_type_record: + { + struct ghw_type_record *r = &t->rec; + int i; + + printf ("type %s is record\n", r->name); + for (i = 0; i < r->nbr_fields; i++) + { + printf (" %s: ", r->el[i].name); + ghw_disp_typename (h, r->el[i].type); + printf ("\n"); + } + printf ("end record;\n"); + } + break; + default: + printf ("ghw_disp_type: unhandled type kind %d\n", t->kind); + } +} + +void +ghw_disp_types (struct ghw_handler *h) +{ + int i; + + for (i = 0; i < h->nbr_types; i++) + ghw_disp_type (h, h->types[i]); +} diff --git a/src/grt/ghwlib.h b/src/grt/ghwlib.h new file mode 100644 index 000000000..0138267ed --- /dev/null +++ b/src/grt/ghwlib.h @@ -0,0 +1,399 @@ +/* GHDL Wavefile reader library. + Copyright (C) 2005 Tristan Gingold + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ + + +#ifndef _GHWLIB_H_ +#define _GHWLIB_H_ + +#include +#include + +#ifdef __GNUC__ +#include +#endif + +enum ghdl_rtik { + ghdl_rtik_top, /* 0 */ + ghdl_rtik_library, + ghdl_rtik_package, + ghdl_rtik_package_body, + ghdl_rtik_entity, + ghdl_rtik_architecture, /* 5 */ + ghdl_rtik_process, + ghdl_rtik_block, + ghdl_rtik_if_generate, + ghdl_rtik_for_generate, + ghdl_rtik_instance, + ghdl_rtik_constant, + ghdl_rtik_iterator, + ghdl_rtik_variable, + ghdl_rtik_signal, + ghdl_rtik_file, + ghdl_rtik_port, + ghdl_rtik_generic, + ghdl_rtik_alias, + ghdl_rtik_guard, + ghdl_rtik_component, + ghdl_rtik_attribute, + ghdl_rtik_type_b2, /* 22 */ + ghdl_rtik_type_e8, + ghdl_rtik_type_e32, + ghdl_rtik_type_i32, /* 25 */ + ghdl_rtik_type_i64, + ghdl_rtik_type_f64, + ghdl_rtik_type_p32, + ghdl_rtik_type_p64, + ghdl_rtik_type_access, /* 30 */ + ghdl_rtik_type_array, + ghdl_rtik_type_record, + ghdl_rtik_type_file, + ghdl_rtik_subtype_scalar, + ghdl_rtik_subtype_array, /* 35 */ + ghdl_rtik_subtype_array_ptr, + ghdl_rtik_subtype_unconstrained_array, + ghdl_rtik_subtype_record, + ghdl_rtik_subtype_access, + ghdl_rtik_type_protected, + ghdl_rtik_element, + ghdl_rtik_unit, + ghdl_rtik_attribute_transaction, + ghdl_rtik_attribute_quiet, + ghdl_rtik_attribute_stable, + ghdl_rtik_error +}; + +/* Well-known types. */ +enum ghw_wkt_type { + ghw_wkt_unknown, + ghw_wkt_boolean, + ghw_wkt_bit, + ghw_wkt_std_ulogic +}; + +struct ghw_range_b2 +{ + enum ghdl_rtik kind : 8; + int dir : 8; /* 0: to, !0: downto. */ + unsigned char left; + unsigned char right; +}; + +struct ghw_range_e8 +{ + enum ghdl_rtik kind : 8; + int dir : 8; /* 0: to, !0: downto. */ + unsigned char left; + unsigned char right; +}; + +struct ghw_range_i32 +{ + enum ghdl_rtik kind : 8; + int dir : 8; /* 0: to, !0: downto. */ + int32_t left; + int32_t right; +}; + +struct ghw_range_i64 +{ + enum ghdl_rtik kind : 8; + int dir : 8; + int64_t left; + int64_t right; +}; + +struct ghw_range_f64 +{ + enum ghdl_rtik kind : 8; + int dir : 8; + double left; + double right; +}; + +union ghw_range +{ + enum ghdl_rtik kind : 8; + struct ghw_range_e8 e8; + struct ghw_range_i32 i32; + struct ghw_range_i64 i64; + struct ghw_range_f64 f64; +}; + +/* Note: the first two fields must be kind and name. */ +union ghw_type; + +struct ghw_type_common +{ + enum ghdl_rtik kind; + const char *name; +}; + +struct ghw_type_enum +{ + enum ghdl_rtik kind; + const char *name; + + enum ghw_wkt_type wkt; + unsigned int nbr; + const char **lits; +}; + +struct ghw_type_scalar +{ + enum ghdl_rtik kind; + const char *name; +}; + +struct ghw_unit +{ + const char *name; + int64_t val; +}; + +struct ghw_type_physical +{ + enum ghdl_rtik kind; + const char *name; + uint32_t nbr_units; + struct ghw_unit *units; +}; + +struct ghw_type_array +{ + enum ghdl_rtik kind; + const char *name; + + unsigned int nbr_dim; + union ghw_type *el; + union ghw_type **dims; +}; + +struct ghw_subtype_array +{ + enum ghdl_rtik kind; + const char *name; + + struct ghw_type_array *base; + int nbr_el; + union ghw_range **rngs; +}; + +struct ghw_subtype_scalar +{ + enum ghdl_rtik kind; + const char *name; + + union ghw_type *base; + union ghw_range *rng; +}; + +struct ghw_record_element +{ + const char *name; + union ghw_type *type; +}; + +struct ghw_type_record +{ + enum ghdl_rtik kind; + const char *name; + + unsigned int nbr_fields; + int nbr_el; /* Number of scalar signals. */ + struct ghw_record_element *el; +}; + +union ghw_type +{ + enum ghdl_rtik kind; + struct ghw_type_common common; + struct ghw_type_enum en; + struct ghw_type_scalar sc; + struct ghw_type_physical ph; + struct ghw_subtype_scalar ss; + struct ghw_subtype_array sa; + struct ghw_type_array ar; + struct ghw_type_record rec; +}; + +union ghw_val +{ + unsigned char b2; + unsigned char e8; + int32_t i32; + int64_t i64; + double f64; +}; + +/* A non-composite signal. */ +struct ghw_sig +{ + union ghw_type *type; + union ghw_val *val; +}; + +enum ghw_hie_kind { + ghw_hie_eoh = 0, + ghw_hie_design = 1, + ghw_hie_block = 3, + ghw_hie_generate_if = 4, + ghw_hie_generate_for = 5, + ghw_hie_instance = 6, + ghw_hie_package = 7, + ghw_hie_process = 13, + ghw_hie_generic = 14, + ghw_hie_eos = 15, + ghw_hie_signal = 16, + ghw_hie_port_in = 17, + ghw_hie_port_out = 18, + ghw_hie_port_inout = 19, + ghw_hie_port_buffer = 20, + ghw_hie_port_linkage = 21 +}; + +struct ghw_hie +{ + enum ghw_hie_kind kind; + struct ghw_hie *parent; + const char *name; + struct ghw_hie *brother; + union + { + struct + { + struct ghw_hie *child; + union ghw_type *iter_type; + union ghw_val *iter_value; + } blk; + struct + { + union ghw_type *type; + /* Array of signal elements. + Last element is 0. */ + unsigned int *sigs; + } sig; + } u; +}; + +struct ghw_handler +{ + FILE *stream; + /* True if words are big-endian. */ + int word_be; + int word_len; + int off_len; + /* Minor version. */ + int version; + + /* Set by user. */ + int flag_verbose; + + /* String table. */ + /* Number of strings. */ + int nbr_str; + /* Size of the strings (without nul). */ + int str_size; + /* String table. */ + char **str_table; + /* Array containing strings. */ + char *str_content; + + /* Type table. */ + int nbr_types; + union ghw_type **types; + + /* Non-composite (or basic) signals. */ + int nbr_sigs; + struct ghw_sig *sigs; + + /* Hierarchy. */ + struct ghw_hie *hie; + + /* Time of the next cycle. */ + int64_t snap_time; +}; + +/* Open a GHW file with H. + Return < 0 in case of error. */ +int ghw_open (struct ghw_handler *h, const char *filename); + +union ghw_type *ghw_get_base_type (union ghw_type *t); + +/* Put the ASCII representation of VAL into BUF, whose size if LEN. + A NUL is always written to BUF. */ +void ghw_get_value (char *buf, int len, + union ghw_val *val, union ghw_type *type); + +const char *ghw_get_hie_name (struct ghw_hie *h); + +void ghw_disp_hie (struct ghw_handler *h, struct ghw_hie *top); + +int ghw_read_base (struct ghw_handler *h); + +void ghw_disp_values (struct ghw_handler *h); + +int ghw_read_cycle_start (struct ghw_handler *h); + +int ghw_read_cycle_cont (struct ghw_handler *h, int *list); + +int ghw_read_cycle_next (struct ghw_handler *h); + +int ghw_read_cycle_end (struct ghw_handler *h); + +enum ghw_sm_type { + /* At init; + Read section name. */ + ghw_sm_init = 0, + ghw_sm_sect = 1, + ghw_sm_cycle = 2 +}; + +enum ghw_res { + ghw_res_error = -1, + ghw_res_eof = -2, + ghw_res_ok = 0, + ghw_res_snapshot = 1, + ghw_res_cycle = 2, + ghw_res_other = 3 +}; + +int ghw_read_sm (struct ghw_handler *h, enum ghw_sm_type *sm); + +int ghw_read_dump (struct ghw_handler *h); + +struct ghw_section { + const char name[4]; + int (*handler)(struct ghw_handler *h); +}; + +extern struct ghw_section ghw_sections[]; + +int ghw_read_section (struct ghw_handler *h); + +void ghw_close (struct ghw_handler *h); + +const char *ghw_get_dir (int is_downto); + +/* Note: TYPE must be a base type (used only to display literals). */ +void ghw_disp_range (union ghw_type *type, union ghw_range *rng); + +void ghw_disp_type (struct ghw_handler *h, union ghw_type *t); + +void ghw_disp_types (struct ghw_handler *h); +#endif /* _GHWLIB_H_ */ diff --git a/src/grt/grt-arch.ads b/src/grt/grt-arch.ads new file mode 100644 index 000000000..5f5aa0e4c --- /dev/null +++ b/src/grt/grt-arch.ads @@ -0,0 +1,2 @@ +With Grt.Arch_None; +Package Grt.Arch renames Grt.Arch_None; diff --git a/src/grt/grt-arch_none.adb b/src/grt/grt-arch_none.adb new file mode 100644 index 000000000..14db1c7d5 --- /dev/null +++ b/src/grt/grt-arch_none.adb @@ -0,0 +1,7 @@ +package body Grt.Arch_None is + function Get_Time_Stamp return Ghdl_U64 is + begin + return 0; + end Get_Time_Stamp; +end Grt.Arch_None; + diff --git a/src/grt/grt-arch_none.ads b/src/grt/grt-arch_none.ads new file mode 100644 index 000000000..f8ae437d6 --- /dev/null +++ b/src/grt/grt-arch_none.ads @@ -0,0 +1,6 @@ +with Grt.Types; use Grt.Types; + +package Grt.Arch_None is + function Get_Time_Stamp return Ghdl_U64; + pragma Inline (Get_Time_Stamp); +end Grt.Arch_None; diff --git a/src/grt/grt-astdio.adb b/src/grt/grt-astdio.adb new file mode 100644 index 000000000..456d024ac --- /dev/null +++ b/src/grt/grt-astdio.adb @@ -0,0 +1,231 @@ +-- GHDL Run Time (GRT) stdio subprograms for GRT types. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.C; use Grt.C; + +package body Grt.Astdio is + procedure Put (Stream : FILEs; Str : String) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Str'Address, Str'Length, 1, Stream); + end Put; + + procedure Put (Stream : FILEs; C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), Stream); + end Put; + + procedure Put (Stream : FILEs; Str : Ghdl_C_String) + is + Len : Natural; + S : size_t; + pragma Unreferenced (S); + begin + Len := strlen (Str); + S := fwrite (Str (1)'Address, size_t (Len), 1, Stream); + end Put; + + procedure New_Line (Stream : FILEs) is + begin + Put (Stream, Nl); + end New_Line; + + procedure Put (Str : String) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Str'Address, Str'Length, 1, stdout); + end Put; + + procedure Put (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), stdout); + end Put; + + procedure Put (Str : Ghdl_C_String) + is + Len : Natural; + S : size_t; + pragma Unreferenced (S); + begin + Len := strlen (Str); + S := fwrite (Str (1)'Address, size_t (Len), 1, stdout); + end Put; + + procedure New_Line is + begin + Put (Nl); + end New_Line; + + procedure Put_Line (Str : String) + is + begin + Put (Str); + New_Line; + end Put_Line; + + procedure Put_Str_Len (Stream : FILEs; Str : Ghdl_Str_Len_Type) + is + S : String (1 .. 3); + begin + if Str.Str = null then + S (1) := '''; + S (2) := Character'Val (Str.Len); + S (3) := '''; + Put (Stream, S); + else + Put (Stream, Str.Str (1 .. Str.Len)); + end if; + end Put_Str_Len; + + generic + type Ntype is range <>; + Max_Len : Natural; + procedure Put_Ntype (Stream : FILEs; N : Ntype); + + procedure Put_Ntype (Stream : FILEs; N : Ntype) + is + Str : String (1 .. Max_Len); + P : Natural := Str'Last; + V : Ntype; + begin + -- V is negativ. + if N > 0 then + V := -N; + else + V := N; + end if; + loop + Str (P) := Character'Val (48 - (V rem 10)); -- V is <= 0. + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + if N < 0 then + P := P - 1; + Str (P) := '-'; + end if; + Put (Stream, Str (P .. Max_Len)); + end Put_Ntype; + + generic + type Utype is mod <>; + Max_Len : Natural; + procedure Put_Utype (Stream : FILEs; N : Utype); + + procedure Put_Utype (Stream : FILEs; N : Utype) + is + Str : String (1 .. Max_Len); + P : Natural := Str'Last; + V : Utype := N; + begin + loop + Str (P) := Character'Val (48 + (V rem 10)); + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + Put (Stream, Str (P .. Max_Len)); + end Put_Utype; + + procedure Put_I32_1 is new Put_Ntype (Ntype => Ghdl_I32, Max_Len => 11); + procedure Put_I32 (Stream : FILEs; I32 : Ghdl_I32) renames Put_I32_1; + + procedure Put_U32_1 is new Put_Utype (Utype => Ghdl_U32, Max_Len => 11); + procedure Put_U32 (Stream : FILEs; U32 : Ghdl_U32) renames Put_U32_1; + + procedure Put_I64_1 is new Put_Ntype (Ntype => Ghdl_I64, Max_Len => 20); + procedure Put_I64 (Stream : FILEs; I64 : Ghdl_I64) renames Put_I64_1; + + procedure Put_U64_1 is new Put_Utype (Utype => Ghdl_U64, Max_Len => 20); + procedure Put_U64 (Stream : FILEs; U64 : Ghdl_U64) renames Put_U64_1; + + procedure Put_F64 (Stream : FILEs; F64 : Ghdl_F64) + is + procedure Fprintf_G (Stream : FILEs; + Arg : Ghdl_F64); + pragma Import (C, Fprintf_G, "__ghdl_fprintf_g"); + begin + Fprintf_G (Stream, F64); + end Put_F64; + + Hex_Map : constant array (0 .. 15) of Character := "0123456789ABCDEF"; + + procedure Put (Stream : FILEs; Addr : System.Address) + is + Res : String (1 .. System.Word_Size / 4); + Val : Integer_Address := To_Integer (Addr); + begin + for I in reverse Res'Range loop + Res (I) := Hex_Map (Natural (Val and 15)); + Val := Val / 16; + end loop; + Put (Stream, Res); + end Put; + + procedure Put_Dir (Stream : FILEs; Dir : Ghdl_Dir_Type) is + begin + case Dir is + when Dir_To => + Put (Stream, " to "); + when Dir_Downto => + Put (Stream, " downto "); + end case; + end Put_Dir; + + procedure Put_Time (Stream : FILEs; Time : Std_Time) is + begin + if Time = Std_Time'First then + Put (Stream, "-Inf"); + else + -- Do not bother with sec, min, and hr. + if (Time mod 1_000_000_000_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000_000_000)); + Put (Stream, "ms"); + elsif (Time mod 1_000_000_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000_000)); + Put (Stream, "us"); + elsif (Time mod 1_000_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000)); + Put (Stream, "ns"); + elsif (Time mod 1_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000)); + Put (Stream, "ps"); + else + Put_I64 (Stream, Ghdl_I64 (Time)); + Put (Stream, "fs"); + end if; + end if; + end Put_Time; + +end Grt.Astdio; diff --git a/src/grt/grt-astdio.ads b/src/grt/grt-astdio.ads new file mode 100644 index 000000000..8e8b739cc --- /dev/null +++ b/src/grt/grt-astdio.ads @@ -0,0 +1,60 @@ +-- GHDL Run Time (GRT) stdio subprograms for GRT types. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; +with Grt.Types; use Grt.Types; +with Grt.Stdio; use Grt.Stdio; + +package Grt.Astdio is + pragma Preelaborate (Grt.Astdio); + + -- Procedures to disp on STREAM. + procedure Put (Stream : FILEs; Str : String); + procedure Put_I32 (Stream : FILEs; I32 : Ghdl_I32); + procedure Put_U32 (Stream : FILEs; U32 : Ghdl_U32); + procedure Put_I64 (Stream : FILEs; I64 : Ghdl_I64); + procedure Put_U64 (Stream : FILEs; U64 : Ghdl_U64); + procedure Put_F64 (Stream : FILEs; F64 : Ghdl_F64); + procedure Put (Stream : FILEs; Addr : System.Address); + procedure Put (Stream : FILEs; Str : Ghdl_C_String); + procedure Put (Stream : FILEs; C : Character); + procedure New_Line (Stream : FILEs); + + -- Display time with unit, without space. + -- Eg: 10ns, 100ms, 97ps... + procedure Put_Time (Stream : FILEs; Time : Std_Time); + + -- And on stdout. + procedure Put (Str : String); + procedure Put (C : Character); + procedure New_Line; + procedure Put_Line (Str : String); + procedure Put (Str : Ghdl_C_String); + + -- Put STR using put procedures. + procedure Put_Str_Len (Stream : FILEs; Str : Ghdl_Str_Len_Type); + + -- Put " to " or " downto ". + procedure Put_Dir (Stream : FILEs; Dir : Ghdl_Dir_Type); +end Grt.Astdio; diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb new file mode 100644 index 000000000..b935fd9a3 --- /dev/null +++ b/src/grt/grt-avhpi.adb @@ -0,0 +1,1142 @@ +-- GHDL Run Time (GRT) - VHPI implementation for Ada. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; + +package body Grt.Avhpi is + procedure Get_Root_Inst (Res : out VhpiHandleT) + is + begin + Res := (Kind => VhpiRootInstK, + Ctxt => Get_Top_Context); + end Get_Root_Inst; + + procedure Get_Package_Inst (Res : out VhpiHandleT) is + begin + Res := (Kind => VhpiIteratorK, + Ctxt => (Base => Null_Address, + Block => To_Ghdl_Rti_Access (Ghdl_Rti_Top'Address)), + Rel => VhpiPackInsts, + It_Cur => 0, + It2 => 0, + Max2 => 0); + end Get_Package_Inst; + + -- Number of elements in an array. + function Ranges_To_Length (Rngs : Ghdl_Range_Array; + Indexes : Ghdl_Rti_Arr_Acc) + return Ghdl_Index_Type + is + Res : Ghdl_Index_Type; + begin + Res := 1; + for I in Rngs'Range loop + Res := Res * Range_To_Length + (Rngs (I), Get_Base_Type (Indexes (I - Rngs'First))); + end loop; + return Res; + end Ranges_To_Length; + + procedure Vhpi_Iterator (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default value in case of success. + Res := (Kind => VhpiIteratorK, + Ctxt => Ref.Ctxt, + Rel => Rel, + It_Cur => 0, + It2 => 0, + Max2 => 0); + Error := AvhpiErrorOk; + + case Rel is + when VhpiInternalRegions => + case Ref.Kind is + when VhpiRootInstK + | VhpiArchBodyK + | VhpiBlockStmtK + | VhpiIfGenerateK => + return; + when VhpiForGenerateK => + Res.It2 := 1; + return; + when VhpiCompInstStmtK => + Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt); + return; + when others => + null; + end case; + when VhpiDecls => + case Ref.Kind is + when VhpiArchBodyK + | VhpiBlockStmtK + | VhpiIfGenerateK + | VhpiForGenerateK => + return; + when VhpiRootInstK + | VhpiPackInstK => + Res.It2 := 1; + return; + when VhpiCompInstStmtK => + Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt); + Res.It2 := 1; + return; + when others => + null; + end case; + when VhpiIndexedNames => + case Ref.Kind is + when VhpiGenericDeclK => + Res := (Kind => AvhpiNameIteratorK, + Ctxt => Ref.Ctxt, + N_Addr => Avhpi_Get_Address (Ref), + N_Type => Ref.Obj.Obj_Type, + N_Idx => 0, + N_Obj => Ref.Obj); + when VhpiIndexedNameK => + Res := (Kind => AvhpiNameIteratorK, + Ctxt => Ref.Ctxt, + N_Addr => Ref.N_Addr, + N_Type => Ref.N_Type, + N_Idx => 0, + N_Obj => Ref.N_Obj); + when others => + Error := AvhpiErrorNotImplemented; + return; + end case; + case Res.N_Type.Kind is + when Ghdl_Rtik_Subtype_Array => + declare + St : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Res.N_Type); + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Res.Ctxt), + Bt, Rngs); + Res.N_Idx := Ranges_To_Length (Rngs, Bt.Indexes); + end; + when others => + Error := AvhpiErrorBadRel; + end case; + return; + when others => + null; + end case; + -- Failure. + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end Vhpi_Iterator; + + -- OBJ_RTI is the RTI for the base name. + function Add_Index (Ctxt : Rti_Context; + Obj_Base : Address; + Obj_Rti : Ghdl_Rtin_Object_Acc; + El_Type : Ghdl_Rti_Access; + Off : Ghdl_Index_Type) return Address + is + pragma Unreferenced (Ctxt); + Is_Sig : Boolean; + El_Size : Ghdl_Index_Type; + El_Type1 : Ghdl_Rti_Access; + begin + case Obj_Rti.Common.Kind is + when Ghdl_Rtik_Generic => + Is_Sig := False; + when others => + Internal_Error ("add_index"); + end case; + + if El_Type.Kind = Ghdl_Rtik_Subtype_Scalar then + El_Type1 := Get_Base_Type (El_Type); + else + El_Type1 := El_Type; + end if; + + case El_Type1.Kind is + when Ghdl_Rtik_Type_P64 => + if Is_Sig then + El_Size := Address'Size / Storage_Unit; + else + El_Size := Ghdl_I64'Size / Storage_Unit; + end if; + when Ghdl_Rtik_Subtype_Array => + if Is_Sig then + El_Size := Ghdl_Index_Type + (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Sigsize); + else + El_Size := Ghdl_Index_Type + (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Valsize); + end if; + when others => + Internal_Error ("add_index"); + end case; + return Obj_Base + Off * El_Size; + end Add_Index; + + procedure Vhpi_Scan_Indexed_Name (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + El_Type : Ghdl_Rti_Access; + begin + if Iterator.N_Idx = 0 then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + El_Type := To_Ghdl_Rtin_Type_Array_Acc + (Get_Base_Type (Iterator.N_Type)).Element; + + Res := (Kind => VhpiIndexedNameK, + Ctxt => Iterator.Ctxt, + N_Addr => Iterator.N_Addr, + N_Type => El_Type, + N_Idx => 0, + N_Obj => Iterator.N_Obj); + + -- Increment Address. + Iterator.N_Addr := Add_Index + (Iterator.Ctxt, Iterator.N_Addr, Iterator.N_Obj, El_Type, 1); + + Iterator.N_Idx := Iterator.N_Idx - 1; + Error := AvhpiErrorOk; + end Vhpi_Scan_Indexed_Name; + + procedure Vhpi_Scan_Internal_Regions (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + Blk : Ghdl_Rtin_Block_Acc; + Ch : Ghdl_Rti_Access; + Nblk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + if Blk = null then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + loop + << Again >> null; + if Iterator.It_Cur >= Blk.Nbr_Child then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + Ch := Blk.Children (Iterator.It_Cur); + Nblk := To_Ghdl_Rtin_Block_Acc (Ch); + + if Iterator.Max2 /= 0 then + -- A for generate. + Iterator.It2 := Iterator.It2 + 1; + if Iterator.It2 >= Iterator.Max2 then + -- End of loop. + Iterator.Max2 := 0; + Iterator.It_Cur := Iterator.It_Cur + 1; + goto Again; + else + declare + Base : Address; + begin + Base := To_Addr_Acc (Iterator.Ctxt.Base + Nblk.Loc).all; + Base := Base + Iterator.It2 * Nblk.Size; + Res := (Kind => VhpiForGenerateK, + Ctxt => (Base => Base, + Block => Ch)); + + Error := AvhpiErrorOk; + return; + end; + end if; + end if; + + + Iterator.It_Cur := Iterator.It_Cur + 1; + + case Ch.Kind is + when Ghdl_Rtik_Process => + Res := (Kind => VhpiProcessStmtK, + Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc, + Block => Ch)); + Error := AvhpiErrorOk; + return; + when Ghdl_Rtik_Block => + Res := (Kind => VhpiBlockStmtK, + Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc, + Block => Ch)); + Error := AvhpiErrorOk; + return; + when Ghdl_Rtik_If_Generate => + Res := (Kind => VhpiIfGenerateK, + Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base + + Nblk.Loc).all, + Block => Ch)); + -- Return only if the condition is true. + if Res.Ctxt.Base /= Null_Address then + Error := AvhpiErrorOk; + return; + end if; + when Ghdl_Rtik_For_Generate => + Res := (Kind => VhpiForGenerateK, + Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base + + Nblk.Loc).all, + Block => Ch)); + Iterator.Max2 := Get_For_Generate_Length (Nblk, Iterator.Ctxt); + Iterator.It2 := 0; + if Iterator.Max2 > 0 then + Iterator.It_Cur := Iterator.It_Cur - 1; + Error := AvhpiErrorOk; + return; + end if; + -- If the iterator range is nul, then continue to scan. + when Ghdl_Rtik_Instance => + Res := (Kind => VhpiCompInstStmtK, + Ctxt => Iterator.Ctxt, + Inst => To_Ghdl_Rtin_Instance_Acc (Ch)); + Error := AvhpiErrorOk; + return; + when others => + -- Next one. + null; + end case; + end loop; + end Vhpi_Scan_Internal_Regions; + + procedure Rti_To_Handle (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Res : out VhpiHandleT) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Signal => + Res := (Kind => VhpiSigDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Port => + Res := (Kind => VhpiPortDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Generic => + Res := (Kind => VhpiGenericDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Subtype_Array => + declare + Atype : Ghdl_Rtin_Subtype_Array_Acc; + Bt : Ghdl_Rtin_Type_Array_Acc; + begin + Atype := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt := Atype.Basetype; + if Atype.Name = Bt.Name then + Res := (Kind => VhpiArrayTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + else + Res := (Kind => VhpiSubtypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + end if; + end; + when Ghdl_Rtik_Type_Array => + Res := (Kind => VhpiArrayTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Res := (Kind => VhpiEnumTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 => + Res := (Kind => VhpiPhysTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Subtype_Scalar => + Res := (Kind => VhpiSubtypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when others => + Res := (Kind => VhpiUndefined, + Ctxt => Ctxt); + end case; + end Rti_To_Handle; + + procedure Vhpi_Scan_Decls (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + Blk : Ghdl_Rtin_Block_Acc; + Ch : Ghdl_Rti_Access; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + + -- If there is no context, returns now. + -- This may happen for a unbound compinststmt. + if Blk = null then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + if Iterator.It2 = 1 then + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + -- Iterate on the entity. + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + when Ghdl_Rtik_Package_Body => + -- Iterate on the package. + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + when Ghdl_Rtik_Package => + -- Only for std.standard. + Iterator.It2 := 0; + when others => + Internal_Error ("vhpi_scan_decls"); + end case; + end if; + loop + loop + exit when Iterator.It_Cur >= Blk.Nbr_Child; + + Ch := Blk.Children (Iterator.It_Cur); + + Iterator.It_Cur := Iterator.It_Cur + 1; + + case Ch.Kind is + when Ghdl_Rtik_Port + | Ghdl_Rtik_Generic + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Type_Array + | Ghdl_Rtik_Subtype_Array + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Subtype_Scalar => + Rti_To_Handle (Ch, Iterator.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + return; + else + Internal_Error ("vhpi_scan_decls"); + end if; + when others => + null; + end case; + end loop; + case Iterator.It2 is + when 1 => + -- Iterate on the architecture/package decl. + Iterator.It2 := 0; + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + Iterator.It_Cur := 0; + when others => + exit; + end case; + end loop; + Error := AvhpiErrorIteratorEnd; + end Vhpi_Scan_Decls; + + procedure Vhpi_Scan (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + if Iterator.Kind = AvhpiNameIteratorK then + case Iterator.N_Type.Kind is + when Ghdl_Rtik_Subtype_Array => + Vhpi_Scan_Indexed_Name (Iterator, Res, Error); + when others => + Error := AvhpiErrorHandle; + Res := Null_Handle; + end case; + return; + elsif Iterator.Kind /= VhpiIteratorK then + Error := AvhpiErrorHandle; + Res := Null_Handle; + return; + end if; + + case Iterator.Rel is + when VhpiPackInsts => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + if Iterator.It_Cur >= Blk.Nbr_Child then + Error := AvhpiErrorIteratorEnd; + return; + end if; + Res := (Kind => VhpiPackInstK, + Ctxt => (Base => Null_Address, + Block => Blk.Children (Iterator.It_Cur))); + Iterator.It_Cur := Iterator.It_Cur + 1; + Error := AvhpiErrorOk; + end; + when VhpiInternalRegions => + Vhpi_Scan_Internal_Regions (Iterator, Res, Error); + when VhpiDecls => + Vhpi_Scan_Decls (Iterator, Res, Error); + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Scan; + + function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String + is + begin + case Obj.Kind is + when VhpiEnumTypeDeclK => + return To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name; + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK + | VhpiProcessStmtK + | VhpiBlockStmtK + | VhpiIfGenerateK + | VhpiForGenerateK => + return To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name; + when VhpiRootInstK => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + return Blk.Name; + end; + when VhpiCompInstStmtK => + return Obj.Inst.Name; + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK => + return Obj.Obj.Name; + when VhpiSubtypeDeclK => + return To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name; + when others => + return null; + end case; + end Avhpi_Get_Base_Name; + + procedure Vhpi_Get_Str (Property : VhpiStrPropertyT; + Obj : VhpiHandleT; + Res : out String; + Len : out Natural) + is + subtype R_Type is String (1 .. Res'Length); + R : R_Type renames Res; + + procedure Add (C : Character) is + begin + Len := Len + 1; + if Len <= R_Type'Last then + R (Len) := C; + end if; + end Add; + + procedure Add (Str : String) is + begin + for I in Str'Range loop + Add (Str (I)); + end loop; + end Add; + + procedure Add (Str : Ghdl_C_String) is + begin + for I in Str'Range loop + exit when Str (I) = NUL; + Add (Str (I)); + end loop; + end Add; + begin + Len := 0; + + case Property is + when VhpiNameP => + case Obj.Kind is + when VhpiEnumTypeDeclK => + Add (To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name); + when VhpiSubtypeDeclK => + Add (To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name); + when VhpiArrayTypeDeclK => + Add (To_Ghdl_Rtin_Type_Array_Acc (Obj.Atype).Name); + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK + | VhpiProcessStmtK + | VhpiBlockStmtK + | VhpiIfGenerateK => + Add (To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name); + when VhpiRootInstK => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + Add (Blk.Name); + end; + when VhpiCompInstStmtK => + Add (Obj.Inst.Name); + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK => + Add (Obj.Obj.Name); + when VhpiForGenerateK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Iter : Ghdl_Rtin_Object_Acc; + Iter_Type : Ghdl_Rti_Access; + Vptr : Ghdl_Value_Ptr; + Buf : String (1 .. 12); + Buf_Len : Natural; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Vptr := To_Ghdl_Value_Ptr + (Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Obj.Ctxt)); + Add (Blk.Name); + Add ('('); + Iter_Type := Iter.Obj_Type; + if Iter_Type.Kind = Ghdl_Rtik_Subtype_Scalar then + Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc + (Iter_Type).Basetype; + end if; + case Iter_Type.Kind is + when Ghdl_Rtik_Type_I32 => + To_String (Buf, Buf_Len, Vptr.I32); + Add (Buf (Buf_Len .. Buf'Last)); +-- when Ghdl_Rtik_Type_E8 => +-- Disp_Enum_Value +-- (Stream, Rti, Ghdl_Index_Type (Vptr.E8)); +-- when Ghdl_Rtik_Type_E32 => +-- Disp_Enum_Value +-- (Stream, Rti, Ghdl_Index_Type (Vptr.E32)); +-- when Ghdl_Rtik_Type_B1 => +-- Disp_Enum_Value +-- (Stream, Rti, +-- Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1))); + when others => + Add ('?'); + end case; + --Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False); + Add (')'); + end; + when others => + null; + end case; + when VhpiCompNameP => + case Obj.Kind is + when VhpiCompInstStmtK => + declare + Comp : Ghdl_Rtin_Component_Acc; + begin + Comp := To_Ghdl_Rtin_Component_Acc (Obj.Inst.Instance); + if Comp.Common.Kind = Ghdl_Rtik_Component then + Add (Comp.Name); + end if; + end; + when others => + null; + end case; + when VhpiLibLogicalNameP => + case Obj.Kind is + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Lib : Ghdl_Rtin_Type_Scalar_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + if Blk.Common.Kind = Ghdl_Rtik_Package_Body then + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + end if; + Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent); + if Lib.Common.Kind /= Ghdl_Rtik_Library then + Internal_Error ("VhpiLibLogicalNameP"); + end if; + Add (Lib.Name); + end; + when others => + null; + end case; + when VhpiFullNameP => + declare + Rstr : Rstring; + Nctxt : Rti_Context; + begin + if Obj.Kind = VhpiCompInstStmtK then + Get_Instance_Context (Obj.Inst, Obj.Ctxt, Nctxt); + Get_Path_Name (Rstr, Nctxt, ':', False); + else + Get_Path_Name (Rstr, Obj.Ctxt, ':', False); + end if; + Copy (Rstr, R, Len); + Free (Rstr); + case Obj.Kind is + when VhpiCompInstStmtK => + null; + when VhpiPortDeclK + | VhpiSigDeclK => + Add (':'); + Add (Obj.Obj.Name); + when others => + null; + end case; + end; + when others => + null; + end case; + end Vhpi_Get_Str; + + procedure Vhpi_Handle (Rel : VhpiOneToOneT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default error. + Error := AvhpiErrorNotImplemented; + + case Rel is + when VhpiDesignUnit => + case Ref.Kind is + when VhpiRootInstK => + case Ref.Ctxt.Block.Kind is + when Ghdl_Rtik_Architecture => + Res := (Kind => VhpiArchBodyK, + Ctxt => Ref.Ctxt); + Error := AvhpiErrorOk; + return; + when others => + return; + end case; + when others => + return; + end case; + when VhpiPrimaryUnit => + case Ref.Kind is + when VhpiArchBodyK => + declare + Rti : Ghdl_Rti_Access; + Ent : Ghdl_Rtin_Block_Acc; + begin + Rti := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block).Parent; + Ent := To_Ghdl_Rtin_Block_Acc (Rti); + Res := (Kind => VhpiEntityDeclK, + Ctxt => (Base => Ref.Ctxt.Base + Ent.Loc, + Block => Rti)); + Error := AvhpiErrorOk; + end; + when others => + return; + end case; + when VhpiIterScheme => + case Ref.Kind is + when VhpiForGenerateK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Iter : Ghdl_Rtin_Object_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Res := (Kind => VhpiConstDeclK, + Ctxt => Ref.Ctxt, + Obj => Iter); + Error := AvhpiErrorOk; + end; + when others => + return; + end case; + when VhpiSubtype => + case Ref.Kind is + when VhpiPortDeclK + | VhpiSigDeclK + | VhpiGenericDeclK + | VhpiConstDeclK => + Res := (Kind => VhpiSubtypeIndicK, + Ctxt => Ref.Ctxt, + Atype => Ref.Obj.Obj_Type); + Error := AvhpiErrorOk; + when others => + return; + end case; + when VhpiTypeMark => + case Ref.Kind is + when VhpiSubtypeIndicK => + -- FIXME: if the subtype is anonymous, return the base type. + Rti_To_Handle (Ref.Atype, Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + return; + when others => + return; + end case; + when VhpiBaseType => + declare + Atype : Ghdl_Rti_Access; + begin + case Ref.Kind is + when VhpiSubtypeIndicK + | VhpiSubtypeDeclK + | VhpiArrayTypeDeclK => + Atype := Ref.Atype; + when VhpiGenericDeclK => + Atype := Ref.Obj.Obj_Type; + when VhpiIndexedNameK => + Atype := Ref.N_Type; + when others => + return; + end case; + case Atype.Kind is + when Ghdl_Rtik_Subtype_Array => + Rti_To_Handle + (To_Ghdl_Rti_Access (To_Ghdl_Rtin_Subtype_Array_Acc + (Atype).Basetype), + Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + when Ghdl_Rtik_Subtype_Scalar => + Rti_To_Handle + (To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype, + Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + when Ghdl_Rtik_Type_Array => + Res := Ref; + Error := AvhpiErrorOk; + when others => + return; + end case; + end; + when VhpiElemSubtype => + declare + Base_Type : Ghdl_Rtin_Type_Array_Acc; + begin + case Ref.Atype.Kind is + when Ghdl_Rtik_Subtype_Array => + Base_Type := + To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype).Basetype; + when Ghdl_Rtik_Type_Array => + Base_Type := To_Ghdl_Rtin_Type_Array_Acc (Ref.Atype); + when others => + return; + end case; + Rti_To_Handle (Base_Type.Element, Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + end; + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Handle; + + procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Index : Natural; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default error. + Error := AvhpiErrorNotImplemented; + + case Rel is + when VhpiConstraints => + case Ref.Kind is + when VhpiSubtypeIndicK => + if Ref.Atype.Kind = Ghdl_Rtik_Subtype_Array then + declare + Arr_Subtype : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype); + Basetype : constant Ghdl_Rtin_Type_Array_Acc := + Arr_Subtype.Basetype; + Idx : constant Ghdl_Index_Type := + Ghdl_Index_Type (Index); + Bounds : Ghdl_Range_Array (0 .. Basetype.Nbr_Dim - 1); + Range_Basetype : Ghdl_Rti_Access; + begin + if Idx not in 1 .. Basetype.Nbr_Dim then + Res := Null_Handle; + Error := AvhpiErrorBadIndex; + return; + end if; + -- constraint type is basetype.indexes (idx - 1) + Bound_To_Range + (Loc_To_Addr (Arr_Subtype.Common.Depth, + Arr_Subtype.Bounds, Ref.Ctxt), + Basetype, Bounds); + Res := (Kind => VhpiIntRangeK, + Ctxt => Ref.Ctxt, + Rng_Type => Basetype.Indexes (Idx - 1), + Rng_Addr => Bounds (Idx - 1)); + Range_Basetype := Get_Base_Type (Res.Rng_Type); + case Range_Basetype.Kind is + when Ghdl_Rtik_Type_I32 => + null; + when Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Res := (Kind => VhpiEnumRangeK, + Ctxt => Ref.Ctxt, + Rng_Type => Res.Rng_Type, + Rng_Addr => Res.Rng_Addr); + when others => + Internal_Error + ("vhpi_handle_by_index/constraint"); + end case; + Error := AvhpiErrorOk; + end; + end if; + when others => + return; + end case; + when VhpiIndexedNames => + declare + Base_Type, El_Type : VhpiHandleT; + begin + Vhpi_Handle (VhpiBaseType, Ref, Base_Type, Error); + if Error /= AvhpiErrorOk then + return; + end if; + if Vhpi_Get_Kind (Base_Type) /= VhpiArrayTypeDeclK then + Error := AvhpiErrorBadRel; + return; + end if; + Vhpi_Handle (VhpiElemSubtype, Base_Type, El_Type, Error); + if Error /= AvhpiErrorOk then + return; + end if; + Res := (Kind => VhpiIndexedNameK, + Ctxt => Ref.Ctxt, + N_Addr => Avhpi_Get_Address (Ref), + N_Type => El_Type.Atype, + N_Idx => Ghdl_Index_Type (Index), + N_Obj => Ref.Obj); + if Res.N_Addr = Null_Address then + Error := AvhpiErrorBadRel; + return; + end if; + Res.N_Addr := Add_Index + (Res.Ctxt, Res.N_Addr, Res.N_Obj, Res.N_Type, + Ghdl_Index_Type (Index)); + end; + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Handle_By_Index; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out VhpiIntT; + Error : out AvhpiErrorT) + is + begin + case Property is + when VhpiLeftBoundP => + if Obj.Kind /= VhpiIntRangeK then + Res := 0; + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Left; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when VhpiRightBoundP => + if Obj.Kind /= VhpiIntRangeK then + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Right; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when others => + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Get; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out Boolean; + Error : out AvhpiErrorT) + is + begin + case Property is + when VhpiIsUpP => + if Obj.Kind /= VhpiIntRangeK then + Res := False; + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Dir = Dir_To; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when others => + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Get; + + function Vhpi_Get_EntityClass (Obj : VhpiHandleT) + return VhpiEntityClassT + is + begin + case Obj.Kind is + when VhpiArchBodyK => + return VhpiArchitectureEC; + when others => + return VhpiErrorEC; + end case; + end Vhpi_Get_EntityClass; + + function Vhpi_Get_Kind (Obj : VhpiHandleT) return VhpiClassKindT is + begin + return Obj.Kind; + end Vhpi_Get_Kind; + + function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT is + begin + case Obj.Kind is + when VhpiPortDeclK => + case Obj.Obj.Common.Mode and Ghdl_Rti_Signal_Mode_Mask is + when Ghdl_Rti_Signal_Mode_In => + return VhpiInMode; + when Ghdl_Rti_Signal_Mode_Out => + return VhpiOutMode; + when Ghdl_Rti_Signal_Mode_Inout => + return VhpiInoutMode; + when Ghdl_Rti_Signal_Mode_Buffer => + return VhpiBufferMode; + when Ghdl_Rti_Signal_Mode_Linkage => + return VhpiLinkageMode; + when others => + return VhpiErrorMode; + end case; + when others => + return VhpiErrorMode; + end case; + end Vhpi_Get_Mode; + + function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access is + begin + case Obj.Kind is + when VhpiSubtypeIndicK + | VhpiEnumTypeDeclK => + return Obj.Atype; + when VhpiSigDeclK + | VhpiPortDeclK => + return To_Ghdl_Rti_Access (Obj.Obj); + when others => + return null; + end case; + end Avhpi_Get_Rti; + + function Avhpi_Get_Address (Obj : VhpiHandleT) return Address is + begin + case Obj.Kind is + when VhpiPortDeclK + | VhpiSigDeclK + | VhpiGenericDeclK + | VhpiConstDeclK => + return Loc_To_Addr (Obj.Ctxt.Block.Depth, + Obj.Obj.Loc, + Obj.Ctxt); + when others => + return Null_Address; + end case; + end Avhpi_Get_Address; + + function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context is + begin + return Obj.Ctxt; + end Avhpi_Get_Context; + + function Vhpi_Compare_Handles (Hdl1, Hdl2 : VhpiHandleT) + return Boolean + is + begin + if Hdl1.Kind /= Hdl2.Kind then + return False; + end if; + case Hdl1.Kind is + when VhpiSubtypeIndicK + | VhpiSubtypeDeclK + | VhpiArrayTypeDeclK + | VhpiPhysTypeDeclK => + return Hdl1.Atype = Hdl2.Atype; + when others => + -- FIXME: todo + Internal_Error ("vhpi_compare_handles"); + end case; + end Vhpi_Compare_Handles; + + function Vhpi_Put_Value (Obj : VhpiHandleT; Val : Ghdl_I64) + return AvhpiErrorT + is + Vptr : Ghdl_Value_Ptr; + Atype : Ghdl_Rti_Access; + begin + case Obj.Kind is + when VhpiIndexedNameK => + Vptr := To_Ghdl_Value_Ptr (Obj.N_Addr); + Atype := Obj.N_Type; + when others => + return AvhpiErrorNotImplemented; + end case; + case Get_Base_Type (Atype).Kind is + when Ghdl_Rtik_Type_P64 => + null; + when others => + return AvhpiErrorHandle; + end case; + Vptr.I64 := Val; + return AvhpiErrorOk; + end Vhpi_Put_Value; +end Grt.Avhpi; + + diff --git a/src/grt/grt-avhpi.ads b/src/grt/grt-avhpi.ads new file mode 100644 index 000000000..1eff5a8a3 --- /dev/null +++ b/src/grt/grt-avhpi.ads @@ -0,0 +1,561 @@ +-- GHDL Run Time (GRT) - VHPI implementation for Ada. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +-- Ada oriented implementation of VHPI. +-- This doesn't follow exactly what VHPI defined, but: +-- * it should be easy to write a VHPI interface from this implementation. +-- * this implementation is thread-safe (no global storage). +-- * this implementation never allocates memory. +with System; use System; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; + +package Grt.Avhpi is + -- Object Kinds. + type VhpiClassKindT is + ( + VhpiUndefined, + VhpiAccessTypeDeclK, + VhpiAggregateK, + VhpiAliasDeclK, + VhpiAllLiteralK, + VhpiAllocatorK, + VhpiAnyCollectionK, + VhpiArchBodyK, + VhpiArgvK, + VhpiArrayTypeDeclK, + VhpiAssertStmtK, + VhpiAssocElemK, + VhpiAttrDeclK, + VhpiAttrSpecK, + VhpiBinaryExprK, + VhpiBitStringLiteralK, + VhpiBlockConfigK, + VhpiBlockStmtK, + VhpiBranchK, + VhpiCallbackK, + VhpiCaseStmtK, + VhpiCharLiteralK, + VhpiCompConfigK, + VhpiCompDeclK, + VhpiCompInstStmtK, + VhpiCondSigAssignStmtK, + VhpiCondWaveformK, + VhpiConfigDeclK, + VhpiConstDeclK, + VhpiConstParamDeclK, + VhpiConvFuncK, + VhpiDeRefObjK, + VhpiDisconnectSpecK, + VhpiDriverK, + VhpiDriverCollectionK, + VhpiElemAssocK, + VhpiElemDeclK, + VhpiEntityClassEntryK, + VhpiEntityDeclK, + VhpiEnumLiteralK, + VhpiEnumRangeK, + VhpiEnumTypeDeclK, + VhpiExitStmtK, + VhpiFileDeclK, + VhpiFileParamDeclK, + VhpiFileTypeDeclK, + VhpiFloatRangeK, + VhpiFloatTypeDeclK, + VhpiForGenerateK, + VhpiForLoopK, + VhpiForeignfK, + VhpiFuncCallK, + VhpiFuncDeclK, + VhpiGenericDeclK, + VhpiGroupDeclK, + VhpiGroupTempDeclK, + VhpiIfGenerateK, + VhpiIfStmtK, + VhpiInPortK, + VhpiIndexedNameK, + VhpiIntLiteralK, + VhpiIntRangeK, + VhpiIntTypeDeclK, + VhpiIteratorK, + VhpiLibraryDeclK, + VhpiLoopStmtK, + VhpiNextStmtK, + VhpiNullLiteralK, + VhpiNullStmtK, + VhpiOperatorK, + VhpiOthersLiteralK, + VhpiOutPortK, + VhpiPackBodyK, + VhpiPackDeclK, + VhpiPackInstK, + VhpiParamAttrNameK, + VhpiPhysLiteralK, + VhpiPhysRangeK, + VhpiPhysTypeDeclK, + VhpiPortDeclK, + VhpiProcCallStmtK, + VhpiProcDeclK, + VhpiProcessStmtK, + VhpiProtectedTypeK, + VhpiProtectedTypeBodyK, + VhpiProtectedTypeDeclK, + VhpiRealLiteralK, + VhpiRecordTypeDeclK, + VhpiReportStmtK, + VhpiReturnStmtK, + VhpiRootInstK, + VhpiSelectSigAssignStmtK, + VhpiSelectWaveformK, + VhpiSelectedNameK, + VhpiSigDeclK, + VhpiSigParamDeclK, + VhpiSimpAttrNameK, + VhpiSimpleSigAssignStmtK, + VhpiSliceNameK, + VhpiStringLiteralK, + VhpiSubpBodyK, + VhpiSubtypeDeclK, + VhpiSubtypeIndicK, + VhpiToolK, + VhpiTransactionK, + VhpiTypeConvK, + VhpiUnaryExprK, + VhpiUnitDeclK, + VhpiUserAttrNameK, + VhpiVarAssignStmtK, + VhpiVarDeclK, + VhpiVarParamDeclK, + VhpiWaitStmtK, + VhpiWaveformElemK, + VhpiWhileLoopK, + + -- Iterator, but on a name. + AvhpiNameIteratorK + ); + + type VhpiOneToOneT is + ( + VhpiAbstractLiteral, + VhpiActual, + VhpiAllLiteral, + VhpiAttrDecl, + VhpiAttrSpec, + VhpiBaseType, + VhpiBaseUnit, + VhpiBasicSignal, + VhpiBlockConfig, + VhpiCaseExpr, + VhpiCondExpr, + VhpiConfigDecl, + VhpiConfigSpec, + VhpiConstraint, + VhpiContributor, + VhpiCurCallback, + VhpiCurEqProcess, + VhpiCurStackFrame, + VhpiDeRefObj, + VhpiDecl, + VhpiDesignUnit, + VhpiDownStack, + VhpiElemSubtype, + VhpiEntityAspect, + VhpiEntityDecl, + VhpiEqProcessStmt, + VhpiExpr, + VhpiFormal, + VhpiFuncDecl, + VhpiGroupTempDecl, + VhpiGuardExpr, + VhpiGuardSig, + VhpiImmRegion, + VhpiInPort, + VhpiInitExpr, + VhpiIterScheme, + VhpiLeftExpr, + VhpiLexicalScope, + VhpiLhsExpr, + VhpiLocal, + VhpiLogicalExpr, + VhpiName, + VhpiOperator, + VhpiOthersLiteral, + VhpiOutPort, + VhpiParamDecl, + VhpiParamExpr, + VhpiParent, + VhpiPhysLiteral, + VhpiPrefix, + VhpiPrimaryUnit, + VhpiProtectedTypeBody, + VhpiProtectedTypeDecl, + VhpiRejectTime, + VhpiReportExpr, + VhpiResolFunc, + VhpiReturnExpr, + VhpiReturnTypeMark, + VhpiRhsExpr, + VhpiRightExpr, + VhpiRootInst, + VhpiSelectExpr, + VhpiSeverityExpr, + VhpiSimpleName, + VhpiSubpBody, + VhpiSubpDecl, + VhpiSubtype, + VhpiSuffix, + VhpiTimeExpr, + VhpiTimeOutExpr, + VhpiTool, + VhpiTypeMark, + VhpiUnitDecl, + VhpiUpStack, + VhpiUpperRegion, + VhpiValExpr, + VhpiValSubtype + ); + + -- Methods used to traverse 1 to many relationships. + type VhpiOneToManyT is + ( + VhpiAliasDecls, + VhpiArgvs, + VhpiAttrDecls, + VhpiAttrSpecs, + VhpiBasicSignals, + VhpiBlockStmts, + VhpiBranchs, + VhpiCallbacks, + VhpiChoices, + VhpiCompInstStmts, + VhpiCondExprs, + VhpiCondWaveforms, + VhpiConfigItems, + VhpiConfigSpecs, + VhpiConstDecls, + VhpiConstraints, + VhpiContributors, + VhpiCurRegions, + VhpiDecls, + VhpiDepUnits, + VhpiDesignUnits, + VhpiDrivenSigs, + VhpiDrivers, + VhpiElemAssocs, + VhpiEntityClassEntrys, + VhpiEntityDesignators, + VhpiEnumLiterals, + VhpiForeignfs, + VhpiGenericAssocs, + VhpiGenericDecls, + VhpiIndexExprs, + VhpiIndexedNames, + VhpiInternalRegions, + VhpiMembers, + VhpiPackInsts, + VhpiParamAssocs, + VhpiParamDecls, + VhpiPortAssocs, + VhpiPortDecls, + VhpiRecordElems, + VhpiSelectWaveforms, + VhpiSelectedNames, + VhpiSensitivitys, + VhpiSeqStmts, + VhpiSigAttrs, + VhpiSigDecls, + VhpiSigNames, + VhpiSignals, + VhpiSpecNames, + VhpiSpecs, + VhpiStmts, + VhpiTransactions, + VhpiTypeMarks, + VhpiUnitDecls, + VhpiUses, + VhpiVarDecls, + VhpiWaveformElems, + VhpiLibraryDecls + ); + + type VhpiIntPropertyT is + ( + VhpiAccessP, + VhpiArgcP, + VhpiAttrKindP, + VhpiBaseIndexP, + VhpiBeginLineNoP, + VhpiEndLineNoP, + VhpiEntityClassP, + VhpiForeignKindP, + VhpiFrameLevelP, + VhpiGenerateIndexP, + VhpiIntValP, + VhpiIsAnonymousP, + VhpiIsBasicP, + VhpiIsCompositeP, + VhpiIsDefaultP, + VhpiIsDeferredP, + VhpiIsDiscreteP, + VhpiIsForcedP, + VhpiIsForeignP, + VhpiIsGuardedP, + VhpiIsImplicitDeclP, + VhpiIsInvalidP_DEPRECATED, + VhpiIsLocalP, + VhpiIsNamedP, + VhpiIsNullP, + VhpiIsOpenP, + VhpiIsPLIP, + VhpiIsPassiveP, + VhpiIsPostponedP, + VhpiIsProtectedTypeP, + VhpiIsPureP, + VhpiIsResolvedP, + VhpiIsScalarP, + VhpiIsSeqStmtP, + VhpiIsSharedP, + VhpiIsTransportP, + VhpiIsUnaffectedP, + VhpiIsUnconstrainedP, + VhpiIsUninstantiatedP, + VhpiIsUpP, + VhpiIsVitalP, + VhpiIteratorTypeP, + VhpiKindP, + VhpiLeftBoundP, + VhpiLevelP_DEPRECATED, + VhpiLineNoP, + VhpiLineOffsetP, + VhpiLoopIndexP, + VhpiModeP, + VhpiNumDimensionsP, + VhpiNumFieldsP_DEPRECATED, + VhpiNumGensP, + VhpiNumLiteralsP, + VhpiNumMembersP, + VhpiNumParamsP, + VhpiNumPortsP, + VhpiOpenModeP, + VhpiPhaseP, + VhpiPositionP, + VhpiPredefAttrP, + VhpiReasonP, + VhpiRightBoundP, + VhpiSigKindP, + VhpiSizeP, + VhpiStartLineNoP, + VhpiStateP, + VhpiStaticnessP, + VhpiVHDLversionP, + VhpiIdP, + VhpiCapabilitiesP + ); + + -- String properties. + type VhpiStrPropertyT is + ( + VhpiCaseNameP, + VhpiCompNameP, + VhpiDefNameP, + VhpiFileNameP, + VhpiFullCaseNameP, + VhpiFullNameP, + VhpiKindStrP, + VhpiLabelNameP, + VhpiLibLogicalNameP, + VhpiLibPhysicalNameP, + VhpiLogicalNameP, + VhpiLoopLabelNameP, + VhpiNameP, + VhpiOpNameP, + VhpiStrValP, + VhpiToolVersionP, + VhpiUnitNameP + ); + + -- Possible Errors. + type AvhpiErrorT is + ( + AvhpiErrorOk, + AvhpiErrorBadRel, + AvhpiErrorHandle, + AvhpiErrorNotImplemented, + AvhpiErrorIteratorEnd, + AvhpiErrorBadIndex + ); + + type VhpiHandleT is private; + + -- A null handle. + Null_Handle : constant VhpiHandleT; + + -- Get the root instance. + procedure Get_Root_Inst (Res : out VhpiHandleT); + + -- Get the instanciated packages. + procedure Get_Package_Inst (Res : out VhpiHandleT); + + procedure Vhpi_Handle (Rel : VhpiOneToOneT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + + procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Index : Natural; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + + procedure Vhpi_Iterator (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + procedure Vhpi_Scan (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + + procedure Vhpi_Get_Str (Property : VhpiStrPropertyT; + Obj : VhpiHandleT; + Res : out String; + Len : out Natural); + + subtype VhpiIntT is Ghdl_I32; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out VhpiIntT; + Error : out AvhpiErrorT); + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out Boolean; + Error : out AvhpiErrorT); + + -- Almost the same as Vhpi_Get_Str (VhpiName, OBJ), but there is not + -- indexes for generate stmt. + function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String; + + -- Return TRUE iff HDL1 and HDL2 are equivalent. + function Vhpi_Compare_Handles (Hdl1, Hdl2 : VhpiHandleT) + return Boolean; + +-- procedure Vhpi_Handle_By_Simple_Name (Ref : VhpiHandleT; +-- Res : out VhpiHandleT; +-- Error : out AvhpiErrorT); + + type VhpiEntityClassT is + ( + VhpiErrorEC, + VhpiEntityEC, + VhpiArchitectureEC, + VhpiConfigurationEC, + VhpiProcedureEC, + VhpiFunctionEC, + VhpiPackageEC, + VhpiTypeEC, + VhpiSubtypeEC, + VhpiConstantEC, + VhpiSignalEC, + VhpiVariableEC, + VhpiComponentEC, + VhpiLabelEC, + VhpiLiteralEC, + VhpiUnitsEC, + VhpiFileEC, + VhpiGroupEC + ); + + function Vhpi_Get_EntityClass (Obj : VhpiHandleT) + return VhpiEntityClassT; + + type VhpiModeT is + ( + VhpiErrorMode, + VhpiInMode, + VhpiOutMode, + VhpiInoutMode, + VhpiBufferMode, + VhpiLinkageMode + ); + function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT; + + function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access; + + function Avhpi_Get_Address (Obj : VhpiHandleT) return Address; + + function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context; + + function Vhpi_Get_Kind (Obj : VhpiHandleT) return VhpiClassKindT; + + function Vhpi_Put_Value (Obj : VhpiHandleT; Val : Ghdl_I64) + return AvhpiErrorT; +private + type VhpiHandleT (Kind : VhpiClassKindT := VhpiUndefined) is record + -- Context. + Ctxt : Rti_Context; + + case Kind is + when VhpiIteratorK => + Rel : VhpiOneToManyT; + It_Cur : Ghdl_Index_Type; + It2 : Ghdl_Index_Type; + Max2 : Ghdl_Index_Type; + when AvhpiNameIteratorK + | VhpiIndexedNameK => + N_Addr : Address; + N_Type : Ghdl_Rti_Access; + N_Idx : Ghdl_Index_Type; + N_Obj : Ghdl_Rtin_Object_Acc; + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK + | VhpiConstDeclK => + Obj : Ghdl_Rtin_Object_Acc; + when VhpiSubtypeIndicK + | VhpiSubtypeDeclK + | VhpiArrayTypeDeclK + | VhpiEnumTypeDeclK + | VhpiPhysTypeDeclK => + Atype : Ghdl_Rti_Access; + when VhpiCompInstStmtK => + Inst : Ghdl_Rtin_Instance_Acc; + when VhpiIntRangeK + | VhpiEnumRangeK + | VhpiFloatRangeK + | VhpiPhysRangeK => + Rng_Type : Ghdl_Rti_Access; + Rng_Addr : Ghdl_Range_Ptr; + when others => + null; + end case; + -- Current Object. + --Obj : Ghdl_Rti_Access; + end record; + + Null_Handle : constant VhpiHandleT := (Kind => VhpiUndefined, + Ctxt => (Base => Null_Address, + Block => null)); +end Grt.Avhpi; diff --git a/src/grt/grt-avls.adb b/src/grt/grt-avls.adb new file mode 100644 index 000000000..7f13ed39a --- /dev/null +++ b/src/grt/grt-avls.adb @@ -0,0 +1,249 @@ +-- GHDL Run Time (GRT) - binary balanced tree. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; + +package body Grt.Avls is + function Get_Height (Tree: AVL_Tree; N : AVL_Nid) return Ghdl_I32 is + begin + if N = AVL_Nil then + return 0; + else + return Tree (N).Height; + end if; + end Get_Height; + + procedure Check_AVL (Tree : AVL_Tree; N : AVL_Nid) + is + L, R : AVL_Nid; + Lh, Rh : Ghdl_I32; + H : Ghdl_I32; + begin + if N = AVL_Nil then + return; + end if; + L := Tree (N).Left; + R := Tree (N).Right; + H := Get_Height (Tree, N); + if L = AVL_Nil and R = AVL_Nil then + if Get_Height (Tree, N) /= 1 then + Internal_Error ("check_AVL(1)"); + end if; + return; + elsif L = AVL_Nil then + Check_AVL (Tree, R); + if H /= Get_Height (Tree, R) + 1 or H > 2 then + Internal_Error ("check_AVL(2)"); + end if; + elsif R = AVL_Nil then + Check_AVL (Tree, L); + if H /= Get_Height (Tree, L) + 1 or H > 2 then + Internal_Error ("check_AVL(3)"); + end if; + else + Check_AVL (Tree, L); + Check_AVL (Tree, R); + Lh := Get_Height (Tree, L); + Rh := Get_Height (Tree, R); + if Ghdl_I32'Max (Lh, Rh) + 1 /= H then + Internal_Error ("check_AVL(4)"); + end if; + if Rh - Lh > 1 or Rh - Lh < -1 then + Internal_Error ("check_AVL(5)"); + end if; + end if; + end Check_AVL; + + procedure Compute_Height (Tree : in out AVL_Tree; N : AVL_Nid) + is + begin + Tree (N).Height := + Ghdl_I32'Max (Get_Height (Tree, Tree (N).Left), + Get_Height (Tree, Tree (N).Right)) + 1; + end Compute_Height; + + procedure Simple_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid) + is + R : AVL_Nid; + V : AVL_Value; + begin + -- Rotate nodes. + R := Tree (N).Right; + Tree (N).Right := Tree (R).Right; + Tree (R).Right := Tree (R).Left; + Tree (R).Left := Tree (N).Left; + Tree (N).Left := R; + -- Swap vals. + V := Tree (N).Val; + Tree (N).Val := Tree (R).Val; + Tree (R).Val := V; + -- Adjust bal. + Compute_Height (Tree, R); + Compute_Height (Tree, N); + end Simple_Rotate_Right; + + procedure Simple_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid) + is + L : AVL_Nid; + V : AVL_Value; + begin + L := Tree (N).Left; + Tree (N).Left := Tree (L).Left; + Tree (L).Left := Tree (L).Right; + Tree (L).Right := Tree (N).Right; + Tree (N).Right := L; + V := Tree (N).Val; + Tree (N).Val := Tree (L).Val; + Tree (L).Val := V; + Compute_Height (Tree, L); + Compute_Height (Tree, N); + end Simple_Rotate_Left; + + procedure Double_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid) + is + R : AVL_Nid; + begin + R := Tree (N).Right; + Simple_Rotate_Left (Tree, R); + Simple_Rotate_Right (Tree, N); + end Double_Rotate_Right; + + procedure Double_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid) + is + L : AVL_Nid; + begin + L := Tree (N).Left; + Simple_Rotate_Right (Tree, L); + Simple_Rotate_Left (Tree, N); + end Double_Rotate_Left; + + procedure Insert (Tree : in out AVL_Tree; + Cmp : AVL_Compare_Func; + Val : AVL_Nid; + N : AVL_Nid; + Res : out AVL_Nid) + is + Diff : Integer; + Op_Ch, Ch : AVL_Nid; + begin + Diff := Cmp.all (Tree (Val).Val, Tree (N).Val); + if Diff = 0 then + Res := N; + return; + end if; + if Diff < 0 then + if Tree (N).Left = AVL_Nil then + Tree (N).Left := Val; + Compute_Height (Tree, N); + -- N is balanced. + Res := Val; + else + Ch := Tree (N).Left; + Op_Ch := Tree (N).Right; + Insert (Tree, Cmp, Val, Ch, Res); + if Res /= Val then + return; + end if; + if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then + -- Rotate + if Get_Height (Tree, Tree (Ch).Left) + > Get_Height (Tree, Tree (Ch).Right) + then + Simple_Rotate_Left (Tree, N); + else + Double_Rotate_Left (Tree, N); + end if; + else + Compute_Height (Tree, N); + end if; + end if; + else + if Tree (N).Right = AVL_Nil then + Tree (N).Right := Val; + Compute_Height (Tree, N); + -- N is balanced. + Res := Val; + else + Ch := Tree (N).Right; + Op_Ch := Tree (N).Left; + Insert (Tree, Cmp, Val, Ch, Res); + if Res /= Val then + return; + end if; + if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then + -- Rotate + if Get_Height (Tree, Tree (Ch).Right) + > Get_Height (Tree, Tree (Ch).Left) + then + Simple_Rotate_Right (Tree, N); + else + Double_Rotate_Right (Tree, N); + end if; + else + Compute_Height (Tree, N); + end if; + end if; + end if; + end Insert; + + procedure Get_Node (Tree : in out AVL_Tree; + Cmp : AVL_Compare_Func; + N : AVL_Nid; + Res : out AVL_Nid) + is + begin + if Tree'First /= AVL_Root or N /= Tree'Last then + Internal_Error ("avls.get_node"); + end if; + Insert (Tree, Cmp, N, AVL_Root, Res); + Check_AVL (Tree, AVL_Root); + end Get_Node; + + function Find_Node (Tree : AVL_Tree; + Cmp : AVL_Compare_Func; + Val : AVL_Value) return AVL_Nid + is + N : AVL_Nid; + Diff : Integer; + begin + N := AVL_Root; + if Tree'Last < AVL_Root then + return AVL_Nil; + end if; + loop + Diff := Cmp.all (Val, Tree (N).Val); + if Diff = 0 then + return N; + end if; + if Diff < 0 then + N := Tree (N).Left; + else + N := Tree (N).Right; + end if; + if N = AVL_Nil then + return AVL_Nil; + end if; + end loop; + end Find_Node; +end Grt.Avls; diff --git a/src/grt/grt-avls.ads b/src/grt/grt-avls.ads new file mode 100644 index 000000000..790053c6f --- /dev/null +++ b/src/grt/grt-avls.ads @@ -0,0 +1,84 @@ +-- GHDL Run Time (GRT) - binary balanced tree. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; + +package Grt.Avls is + -- Implementation of a binary balanced tree. + -- This package is very generic, and provides only the algorithm. + -- The user must provide the storage of the tree. + -- The basic types of this implementation ares: + -- * AVL_Value: the value stored in the tree. This is an integer on 32 + -- bits. However, they may either really represent integers or an index + -- into another table. To compare two values, a user function is always + -- provided. + -- * AVL_Nid: a node id or an index into the tree. + -- * AVL_Node: a node, indexed by AVL_Nid. + -- * AVL_Tree: an array of AVL_Node, indexed by AVL_Nid. This represents + -- the tree. The root of the tree is always AVL_Root, which is the + -- first element of the array. + -- + -- As a choice, this package never allocate nodes. So, to insert a value + -- in the tree, the user must allocate an (empty) node, set the value of + -- the node and try to insert this node into the tree. If the value is + -- already in the tree, Get_Node will returns the node id which contains + -- the value. Otherwise, Get_Node returns the node just created by the + -- user. + + -- The value in an AVL tree. + -- This is fixed. + type AVL_Value is new Ghdl_I32; + + -- An AVL node id. + type AVL_Nid is new Ghdl_I32; + AVL_Nil : constant AVL_Nid := 0; + AVL_Root : constant AVL_Nid := 1; + + type AVL_Node is record + Val : AVL_Value; + Left : AVL_Nid; + Right : AVL_Nid; + Height : Ghdl_I32; + end record; + + type AVL_Tree is array (AVL_Nid range <>) of AVL_Node; + + -- Compare two values. + -- Returns < 0 if L < R, 0 if L = R, > 0 if L > R. + type AVL_Compare_Func is access function (L, R : AVL_Value) return Integer; + + -- Try to insert node N into TREE. + -- Returns either N or the node id of a node containing already the value. + procedure Get_Node (Tree : in out AVL_Tree; + Cmp : AVL_Compare_Func; + N : AVL_Nid; + Res : out AVL_Nid); + + function Find_Node (Tree : AVL_Tree; + Cmp : AVL_Compare_Func; + Val : AVL_Value) return AVL_Nid; + +end Grt.Avls; + + diff --git a/src/grt/grt-c.ads b/src/grt/grt-c.ads new file mode 100644 index 000000000..24003cf4a --- /dev/null +++ b/src/grt/grt-c.ads @@ -0,0 +1,54 @@ +-- GHDL Run Time (GRT) - C interface. +-- Copyright (C) 2005 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +-- This package declares C types. +-- It is a really stripped down version of interfaces.C! +with System; + +package Grt.C is + pragma Preelaborate (Grt.C); + + -- Type void * and char *. + subtype voids is System.Address; + subtype chars is System.Address; + subtype long is Long_Integer; + + -- Type size_t. + type size_t is mod 2 ** Standard'Address_Size; + + -- Type int. It is an alias on Integer for simplicity. + subtype int is Integer; + + -- Low level memory management. + procedure Free (Addr : System.Address); + function Malloc (Size : size_t) return System.Address; + function Realloc (Ptr : System.Address; Size : size_t) + return System.Address; + +private + pragma Import (C, Free); + pragma Import (C, Malloc); + pragma Import (C, Realloc); +end Grt.C; diff --git a/src/grt/grt-cbinding.c b/src/grt/grt-cbinding.c new file mode 100644 index 000000000..b95c0f0a9 --- /dev/null +++ b/src/grt/grt-cbinding.c @@ -0,0 +1,99 @@ +/* GRT C bindings. + Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold. + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ +#include +#include +#include + +FILE * +__ghdl_get_stdout (void) +{ + return stdout; +} + +FILE * +__ghdl_get_stdin (void) +{ + return stdin; +} + +FILE * +__ghdl_get_stderr (void) +{ + return stderr; +} + +int +__ghdl_snprintf_g (char *buf, unsigned int len, double val) +{ + snprintf (buf, len, "%g", val); + return strlen (buf); +} + +void +__ghdl_snprintf_nf (char *buf, unsigned int len, int ndigits, double val) +{ + snprintf (buf, len, "%.*f", ndigits, val); +} + +void +__ghdl_snprintf_fmtf (char *buf, unsigned int len, + const char *format, double v) +{ + snprintf (buf, len, format, v); +} + +void +__ghdl_fprintf_g (FILE *stream, double val) +{ + fprintf (stream, "%g", val); +} + +void +__ghdl_fprintf_clock (FILE *stream, int a, int b) +{ + fprintf (stream, "%3d.%03d", a, b); +} + +#ifndef WITH_GNAT_RUN_TIME +void +__gnat_last_chance_handler (void) +{ + abort (); +} + +void * +__gnat_malloc (size_t size) +{ + void *res; + res = malloc (size); + return res; +} + +void +__gnat_free (void *ptr) +{ + free (ptr); +} + +void * +__gnat_realloc (void *ptr, size_t size) +{ + return realloc (ptr, size); +} +#endif diff --git a/src/grt/grt-cvpi.c b/src/grt/grt-cvpi.c new file mode 100644 index 000000000..51edd678f --- /dev/null +++ b/src/grt/grt-cvpi.c @@ -0,0 +1,277 @@ +/* GRT VPI C helpers. + Copyright (C) 2003, 2004, 2005 Tristan Gingold & Felix Bertram + + GHDL is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any later + version. + + GHDL is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING. If not, write to the Free + Software Foundation, 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. +*/ +//----------------------------------------------------------------------------- +// Description: VPI interface for GRT runtime, "C" helpers +// the main purpose of this code is to interface with the +// Icarus Verilog Interactive (IVI) simulator GUI +//----------------------------------------------------------------------------- + +#include +#include + +//----------------------------------------------------------------------------- +// 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 +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 +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 +static void * +module_open (const char *path) +{ + return dlopen (path, RTLD_LAZY); +} + +static void * +module_symbol (void *handle, const char *symbol) +{ + return dlsym (handle, symbol); +} + +static const char * +module_error (void) +{ + return dlerror (); +} +#endif + +int +loadVpiModule (const char* modulename) +{ + static const char * const vpitablenames[] = + { + "_vlog_startup_routines", // with leading underscore: MacOSX + "vlog_startup_routines" // w/o leading underscore: Linux + }; + static const char * const vpithunknames[] = + { + "_vpi_register_sim", // with leading underscore: MacOSX + "vpi_register_sim" // w/o leading underscore: Linux + }; + + int i; + void* vpimod; + + fprintf (stderr, "loading VPI module '%s'\n", modulename); + + vpimod = module_open (modulename); + + if (vpimod == NULL) + { + const char *msg; + + msg = module_error (); + + fprintf (stderr, "%s\n", msg == NULL ? "unknown dlopen error" : msg); + return -1; + } + + for (i = 0; i < 2; i++) // try with and w/o leading underscores + { + void* vpithunk; + void* vpitable; + + vpitable = module_symbol (vpimod, vpitablenames[i]); + vpithunk = module_symbol (vpimod, vpithunknames[i]); + + if (vpithunk) + { + typedef int (*funT)(p_vpi_thunk tp); + funT regsim; + + regsim = (funT)vpithunk; + regsim (&thunkTable); + } + else + { + // this is not an error, as the register-mechanism + // is not standardized + } + + if (vpitable) + { + unsigned int tmp; + //extern void (*vlog_startup_routines[])(); + typedef void (*vlog_startup_routines_t)(void); + vlog_startup_routines_t *vpifuns; + + vpifuns = (vlog_startup_routines_t*)vpitable; + for (tmp = 0; vpifuns[tmp]; tmp++) + { + vpifuns[tmp](); + } + + fprintf (stderr, "VPI module loaded!\n"); + return 0; // successfully registered VPI module + } + } + fprintf (stderr, "vlog_startup_routines not found\n"); + return -1; // failed to register VPI module +} + +void +vpi_printf (const char *fmt, ...) +{ + va_list params; + + va_start (params, fmt); + vprintf (fmt, params); + va_end (params); +} + +//----------------------------------------------------------------------------- +// end of file + diff --git a/src/grt/grt-disp.adb b/src/grt/grt-disp.adb new file mode 100644 index 000000000..e68b1168b --- /dev/null +++ b/src/grt/grt-disp.adb @@ -0,0 +1,227 @@ +-- GHDL Run Time (GRT) - Common display subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Astdio; use Grt.Astdio; +with Grt.Stdio; use Grt.Stdio; +--with Grt.Errors; use Grt.Errors; + +package body Grt.Disp is + +-- procedure Put_Trim (Stream : FILEs; Str : String) +-- is +-- Start : Natural; +-- begin +-- Start := Str'First; +-- while Start <= Str'Last and then Str (Start) = ' ' loop +-- Start := Start + 1; +-- end loop; +-- Put (Stream, Str (Start .. Str'Last)); +-- end Put_Trim; + +-- procedure Put_E8 (Stream : FILEs; E8 : Ghdl_E8; Type_Desc : Ghdl_Desc_Ptr) +-- is +-- begin +-- Put_Str_Len (Stream, Type_Desc.E8.Values (Natural (E8))); +-- end Put_E8; + + --procedure Put_E32 + -- (Stream : FILEs; E32 : Ghdl_E32; Type_Desc : Ghdl_Desc_Ptr) + --is + --begin + -- Put_Str_Len (Stream, Type_Desc.E32.Values (Natural (E32))); + --end Put_E32; + + procedure Put_Sig_Index (Sig : Sig_Table_Index) + is + begin + Put_I32 (stdout, Ghdl_I32 (Sig)); + end Put_Sig_Index; + + procedure Put_Sig_Range (Sig : Sig_Table_Range) + is + begin + Put_Sig_Index (Sig.First); + if Sig.Last /= Sig.First then + Put ("-"); + Put_Sig_Index (Sig.Last); + end if; + end Put_Sig_Range; + + procedure Disp_Now + is + begin + Put ("Now is "); + Put_Time (stdout, Current_Time); + Put (" +"); + Put_I32 (stdout, Ghdl_I32 (Current_Delta)); + New_Line; + end Disp_Now; + + procedure Disp_Propagation_Kind (Kind : Propagation_Kind_Type) + is + begin + case Kind is + when Drv_One_Driver => + Put ("Drv (1 drv) "); + when Eff_One_Driver => + Put ("Eff (1 drv) "); + when Drv_One_Port => + Put ("Drv (1 prt) "); + when Eff_One_Port => + Put ("Eff (1 prt) "); + when Imp_Forward => + Put ("Forward "); + when Imp_Forward_Build => + Put ("Forward_Build "); + when Imp_Guard => + Put ("Guard "); + when Imp_Stable => + Put ("Stable "); + when Imp_Quiet => + Put ("Quiet "); + when Imp_Transaction => + Put ("Transaction "); + when Imp_Delayed => + Put ("Delayed "); + when Eff_Actual => + Put ("Eff Actual "); + when Eff_Multiple => + Put ("Eff multiple "); + when Drv_One_Resolved => + Put ("Drv 1 resolved "); + when Eff_One_Resolved => + Put ("Eff 1 resolved "); + when In_Conversion => + Put ("In conv "); + when Out_Conversion => + Put ("Out conv "); + when Drv_Error => + Put ("Drv error "); + when Drv_Multiple => + Put ("Drv multiple "); + when Prop_End => + Put ("end "); + end case; + end Disp_Propagation_Kind; + + procedure Disp_Signals_Order is + begin + for I in Propagation.First .. Propagation.Last loop + Put_I32 (stdout, Ghdl_I32 (I)); + Put (": "); + Disp_Propagation_Kind (Propagation.Table (I).Kind); + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Eff_One_Driver + | Drv_One_Port + | Eff_One_Port + | Drv_One_Resolved + | Eff_One_Resolved + | Imp_Guard + | Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Delayed + | Eff_Actual => + Put_Sig_Index (Signal_Ptr_To_Index (Propagation.Table (I).Sig)); + New_Line; + when Imp_Forward => + Put_I32 (stdout, Ghdl_I32 (Propagation.Table (I).Sig.Net)); + New_Line; + when Imp_Forward_Build => + declare + Forward : Forward_Build_Acc; + begin + Forward := Propagation.Table (I).Forward; + Put_Sig_Index (Signal_Ptr_To_Index (Forward.Src)); + Put (" -> "); + Put_Sig_Index (Signal_Ptr_To_Index (Forward.Targ)); + New_Line; + end; + when Eff_Multiple + | Drv_Multiple => + Put_Sig_Range (Propagation.Table (I).Resolv.Sig_Range); + New_Line; + when In_Conversion + | Out_Conversion => + declare + Conv : Sig_Conversion_Acc; + begin + Conv := Propagation.Table (I).Conv; + Put_Sig_Range (Conv.Src); + Put (" -> "); + Put_Sig_Range (Conv.Dest); + New_Line; + end; + when Prop_End => + New_Line; + when Drv_Error => + null; + end case; + end loop; + end Disp_Signals_Order; + + procedure Disp_Mode (Mode : Mode_Type) + is + begin + case Mode is + when Mode_B1 => + Put (" b1"); + when Mode_E8 => + Put (" e8"); + when Mode_E32 => + Put ("e32"); + when Mode_I32 => + Put ("i32"); + when Mode_I64 => + Put ("i64"); + when Mode_F64 => + Put ("f64"); + end case; + end Disp_Mode; + + procedure Disp_Value (Value : Value_Union; Mode : Mode_Type) is + begin + case Mode is + when Mode_B1 => + if Value.B1 then + Put ("T"); + else + Put ("F"); + end if; + when Mode_E8 => + Put_I32 (stdout, Ghdl_I32 (Value.E8)); + when Mode_E32 => + Put_I32 (stdout, Ghdl_I32 (Value.E32)); + when Mode_I32 => + Put_I32 (stdout, Value.I32); + when Mode_I64 => + Put_I64 (stdout, Value.I64); + when Mode_F64 => + Put_F64 (stdout, Value.F64); + end case; + end Disp_Value; +end Grt.Disp; diff --git a/src/grt/grt-disp.ads b/src/grt/grt-disp.ads new file mode 100644 index 000000000..6c15b37c9 --- /dev/null +++ b/src/grt/grt-disp.ads @@ -0,0 +1,46 @@ +-- GHDL Run Time (GRT) - Common display subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Signals; use Grt.Signals; +with Grt.Types; use Grt.Types; + +package Grt.Disp is + -- Display SIG number. + procedure Put_Sig_Index (Sig : Sig_Table_Index); + + -- Disp current time and current delta. + procedure Disp_Now; + + procedure Disp_Propagation_Kind (Kind : Propagation_Kind_Type); + + -- Disp signals propagation order. + procedure Disp_Signals_Order; + + -- Disp mode. + procedure Disp_Mode (Mode : Mode_Type); + + -- Disp value (numeric). + procedure Disp_Value (Value : Value_Union; Mode : Mode_Type); + +end Grt.Disp; diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb new file mode 100644 index 000000000..08d27dacb --- /dev/null +++ b/src/grt/grt-disp_rti.adb @@ -0,0 +1,1080 @@ +-- GHDL Run Time (GRT) - RTI dumper. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Astdio; use Grt.Astdio; +with Grt.Errors; use Grt.Errors; +with Grt.Hooks; use Grt.Hooks; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; + +package body Grt.Disp_Rti is + procedure Disp_Kind (Kind : Ghdl_Rtik); + + procedure Disp_Name (Name : Ghdl_C_String) is + begin + if Name = null then + Put (stdout, ""); + else + Put (stdout, Name); + end if; + end Disp_Name; + + -- Disp value stored at ADDR and whose type is described by RTI. + procedure Disp_Enum_Value + (Stream : FILEs; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Put (Stream, Enum_Rti.Names (Val)); + end Disp_Enum_Value; + + procedure Disp_Scalar_Value + (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Addr : in out Address; + Is_Sig : Boolean) + is + procedure Update (S : Ghdl_Index_Type) is + begin + Addr := Addr + (S / Storage_Unit); + end Update; + + Vptr : Ghdl_Value_Ptr; + begin + if Is_Sig then + Vptr := To_Ghdl_Value_Ptr (To_Addr_Acc (Addr).all); + Update (Address'Size); + else + Vptr := To_Ghdl_Value_Ptr (Addr); + end if; + + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + Put_I32 (Stream, Vptr.I32); + if not Is_Sig then + Update (32); + end if; + when Ghdl_Rtik_Type_E8 => + Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E8)); + if not Is_Sig then + Update (8); + end if; + when Ghdl_Rtik_Type_E32 => + Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E32)); + if not Is_Sig then + Update (32); + end if; + when Ghdl_Rtik_Type_B1 => + Disp_Enum_Value (Stream, Rti, + Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1))); + if not Is_Sig then + Update (8); + end if; + when Ghdl_Rtik_Type_F64 => + Put_F64 (Stream, Vptr.F64); + if not Is_Sig then + Update (64); + end if; + when Ghdl_Rtik_Type_P64 => + Put_I64 (Stream, Vptr.I64); + Put (Stream, " "); + Put (Stream, + Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); + if not Is_Sig then + Update (64); + end if; + when Ghdl_Rtik_Type_P32 => + Put_I32 (Stream, Vptr.I32); + Put (Stream, " "); + Put (Stream, + Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); + if not Is_Sig then + Update (32); + end if; + when others => + Internal_Error ("disp_rti.disp_scalar_value"); + end case; + end Disp_Scalar_Value; + +-- function Get_Scalar_Type_Kind (Rti : Ghdl_Rti_Access) return Ghdl_Rtik +-- is +-- Ndef : Ghdl_Rti_Access; +-- begin +-- if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then +-- Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype; +-- else +-- Ndef := Rti; +-- end if; +-- case Ndef.Kind is +-- when Ghdl_Rtik_Type_I32 => +-- return Ndef.Kind; +-- when others => +-- return Ghdl_Rtik_Error; +-- end case; +-- end Get_Scalar_Type_Kind; + + procedure Disp_Array_Value_1 (Stream : FILEs; + El_Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Rngs : Ghdl_Range_Array; + Rtis : Ghdl_Rti_Arr_Acc; + Index : Ghdl_Index_Type; + Obj : in out Address; + Is_Sig : Boolean) + is + Length : Ghdl_Index_Type; + begin + Length := Range_To_Length (Rngs (Index), Get_Base_Type (Rtis (Index))); + Put (Stream, "("); + for I in 1 .. Length loop + if I /= 1 then + Put (Stream, ", "); + end if; + if Index = Rngs'Last then + Disp_Value (Stream, El_Rti, Ctxt, Obj, Is_Sig); + else + Disp_Array_Value_1 + (Stream, El_Rti, Ctxt, Rngs, Rtis, Index + 1, Obj, Is_Sig); + end if; + end loop; + Put (Stream, ")"); + end Disp_Array_Value_1; + + procedure Disp_Array_Value (Stream : FILEs; + Rti : Ghdl_Rtin_Type_Array_Acc; + Ctxt : Rti_Context; + Vals : Ghdl_Uc_Array_Acc; + Is_Sig : Boolean) + is + Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; + Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); + Obj : Address; + begin + Bound_To_Range (Vals.Bounds, Rti, Rngs); + Obj := Vals.Base; + Disp_Array_Value_1 + (Stream, Rti.Element, Ctxt, Rngs, Rti.Indexes, 0, Obj, Is_Sig); + end Disp_Array_Value; + + procedure Disp_Record_Value (Stream : FILEs; + Rti : Ghdl_Rtin_Type_Record_Acc; + Ctxt : Rti_Context; + Obj : Address; + Is_Sig : Boolean) + is + El : Ghdl_Rtin_Element_Acc; + El_Addr : Address; + begin + Put (Stream, "("); + for I in 1 .. Rti.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); + if I /= 1 then + Put (", "); + end if; + Put (Stream, El.Name); + Put (" => "); + if Is_Sig then + El_Addr := Obj + El.Sig_Off; + else + El_Addr := Obj + El.Val_Off; + end if; + if Rti_Complex_Type (El.Eltype) then + El_Addr := Obj + To_Ghdl_Index_Acc (El_Addr).all; + end if; + Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Is_Sig); + end loop; + Put (")"); + -- FIXME: update ADDR. + end Disp_Record_Value; + + procedure Disp_Value + (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Obj : in out Address; + Is_Sig : Boolean) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Subtype_Scalar => + Disp_Scalar_Value + (Stream, To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype, + Obj, Is_Sig); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + Disp_Scalar_Value (Stream, Rti, Obj, Is_Sig); + when Ghdl_Rtik_Type_Array => + Disp_Array_Value (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, + To_Ghdl_Uc_Array_Acc (Obj), Is_Sig); + when Ghdl_Rtik_Subtype_Array => + declare + St : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + B : Address; + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); + B := Obj; + Disp_Array_Value_1 + (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig); + end; + when Ghdl_Rtik_Type_File => + declare + Vptr : Ghdl_Value_Ptr; + begin + Vptr := To_Ghdl_Value_Ptr (Obj); + Put (Stream, "File#"); + Put_I32 (Stream, Vptr.I32); + -- FIXME: update OBJ (not very useful since never in a + -- composite type). + end; + when Ghdl_Rtik_Type_Record => + Disp_Record_Value + (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Is_Sig); + when Ghdl_Rtik_Type_Protected => + Put (Stream, "Unhandled protected type"); + when others => + Put (Stream, "Unknown Rti Kind : "); + Disp_Kind(Rti.Kind); + end case; + -- Put_Line(":"); + end Disp_Value; + + procedure Disp_Kind (Kind : Ghdl_Rtik) is + begin + case Kind is + when Ghdl_Rtik_Top => + Put ("ghdl_rtik_top"); + when Ghdl_Rtik_Package => + Put ("ghdl_rtik_package"); + when Ghdl_Rtik_Package_Body => + Put ("ghdl_rtik_package_body"); + when Ghdl_Rtik_Entity => + Put ("ghdl_rtik_entity"); + when Ghdl_Rtik_Architecture => + Put ("ghdl_rtik_architecture"); + + when Ghdl_Rtik_Port => + Put ("ghdl_rtik_port"); + when Ghdl_Rtik_Generic => + Put ("ghdl_rtik_generic"); + when Ghdl_Rtik_Process => + Put ("ghdl_rtik_process"); + when Ghdl_Rtik_Component => + Put ("ghdl_rtik_component"); + when Ghdl_Rtik_Attribute => + Put ("ghdl_rtik_attribute"); + + when Ghdl_Rtik_Attribute_Quiet => + Put ("ghdl_rtik_attribute_quiet"); + when Ghdl_Rtik_Attribute_Stable => + Put ("ghdl_rtik_attribute_stable"); + when Ghdl_Rtik_Attribute_Transaction => + Put ("ghdl_rtik_attribute_transaction"); + + when Ghdl_Rtik_Constant => + Put ("ghdl_rtik_constant"); + when Ghdl_Rtik_Iterator => + Put ("ghdl_rtik_iterator"); + when Ghdl_Rtik_Signal => + Put ("ghdl_rtik_signal"); + when Ghdl_Rtik_Variable => + Put ("ghdl_rtik_variable"); + when Ghdl_Rtik_Guard => + Put ("ghdl_rtik_guard"); + when Ghdl_Rtik_File => + Put ("ghdl_rtik_file"); + + when Ghdl_Rtik_Instance => + Put ("ghdl_rtik_instance"); + when Ghdl_Rtik_Block => + Put ("ghdl_rtik_block"); + when Ghdl_Rtik_If_Generate => + Put ("ghdl_rtik_if_generate"); + when Ghdl_Rtik_For_Generate => + Put ("ghdl_rtik_for_generate"); + + when Ghdl_Rtik_Type_B1 => + Put ("ghdl_rtik_type_b1"); + when Ghdl_Rtik_Type_E8 => + Put ("ghdl_rtik_type_e8"); + when Ghdl_Rtik_Type_E32 => + Put ("ghdl_rtik_type_e32"); + when Ghdl_Rtik_Type_P64 => + Put ("ghdl_rtik_type_p64"); + when Ghdl_Rtik_Type_I32 => + Put ("ghdl_rtik_type_i32"); + + when Ghdl_Rtik_Type_Array => + Put ("ghdl_rtik_type_array"); + when Ghdl_Rtik_Subtype_Array => + Put ("ghdl_rtik_subtype_array"); + when Ghdl_Rtik_Type_Record => + Put ("ghdl_rtik_type_record"); + + when Ghdl_Rtik_Type_Access => + Put ("ghdl_rtik_type_access"); + when Ghdl_Rtik_Type_File => + Put ("ghdl_rtik_type_file"); + when Ghdl_Rtik_Type_Protected => + Put ("ghdl_rtik_type_protected"); + + when Ghdl_Rtik_Subtype_Scalar => + Put ("ghdl_rtik_subtype_scalar"); + + when Ghdl_Rtik_Element => + Put ("ghdl_rtik_element"); + when Ghdl_Rtik_Unit64 => + Put ("ghdl_rtik_unit64"); + when Ghdl_Rtik_Unitptr => + Put ("ghdl_rtik_unitptr"); + + when others => + Put ("ghdl_rtik_#"); + Put_I32 (stdout, Ghdl_Rtik'Pos (Kind)); + end case; + end Disp_Kind; + + procedure Disp_Depth (Depth : Ghdl_Rti_Depth) is + begin + Put (", D="); + Put_I32 (stdout, Ghdl_I32 (Depth)); + end Disp_Depth; + + procedure Disp_Indent (Indent : Natural) is + begin + for I in 1 .. Indent loop + Put (' '); + end loop; + end Disp_Indent; + + -- Disp a subtype_indication. + -- OBJ may be necessary when the subtype is an unconstrained array type, + -- whose bounds are stored with the object. + procedure Disp_Subtype_Indication + (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address); + + procedure Disp_Range + (Stream : FILEs; Kind : Ghdl_Rtik; Rng : Ghdl_Range_Ptr) + is + begin + case Kind is + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_P32 => + Put_I32 (Stream, Rng.I32.Left); + Put_Dir (Stream, Rng.I32.Dir); + Put_I32 (Stream, Rng.I32.Right); + when Ghdl_Rtik_Type_F64 => + Put_F64 (Stream, Rng.F64.Left); + Put_Dir (Stream, Rng.F64.Dir); + Put_F64 (Stream, Rng.F64.Right); + when Ghdl_Rtik_Type_P64 => + Put_I64 (Stream, Rng.P64.Left); + Put_Dir (Stream, Rng.P64.Dir); + Put_I64 (Stream, Rng.P64.Right); + when others => + Put ("?Scal"); + end case; + end Disp_Range; + + procedure Disp_Scalar_Type_Name (Def : Ghdl_Rti_Access) is + begin + case Def.Kind is + when Ghdl_Rtik_Subtype_Scalar => + declare + Rti : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); + if Rti.Name /= null then + Disp_Name (Rti.Name); + else + Disp_Scalar_Type_Name (Rti.Basetype); + end if; + end; + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when others => + Put ("#disp_scalar_type_name#"); + end case; + end Disp_Scalar_Type_Name; + + procedure Disp_Type_Array_Name (Def : Ghdl_Rtin_Type_Array_Acc; + Bounds_Ptr : Address) + is + Bounds : Address; + + procedure Align (A : Ghdl_Index_Type) is + begin + Bounds := Align (Bounds, Ghdl_Rti_Loc (A)); + end Align; + + procedure Update (S : Ghdl_Index_Type) is + begin + Bounds := Bounds + (S / Storage_Unit); + end Update; + + procedure Disp_Bounds (Def : Ghdl_Rti_Access) + is + Ndef : Ghdl_Rti_Access; + begin + if Bounds = Null_Address then + Put ("?"); + else + if Def.Kind = Ghdl_Rtik_Subtype_Scalar then + Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def).Basetype; + else + Ndef := Def; + end if; + case Ndef.Kind is + when Ghdl_Rtik_Type_I32 => + Align (Ghdl_Range_I32'Alignment); + Disp_Range (stdout, Ndef.Kind, To_Ghdl_Range_Ptr (Bounds)); + Update (Ghdl_Range_I32'Size); + when others => + Disp_Kind (Ndef.Kind); + -- Bounds are not known anymore. + Bounds := Null_Address; + end case; + end if; + end Disp_Bounds; + begin + Disp_Name (Def.Name); + if Bounds_Ptr = Null_Address then + return; + end if; + Put (" ("); + Bounds := Bounds_Ptr; + for I in 0 .. Def.Nbr_Dim - 1 loop + if I /= 0 then + Put (", "); + end if; + Disp_Scalar_Type_Name (Def.Indexes (I)); + Put (" range "); + Disp_Bounds (Def.Indexes (I)); + end loop; + Put (")"); + end Disp_Type_Array_Name; + + procedure Disp_Subtype_Scalar_Range + (Stream : FILEs; Def : Ghdl_Rtin_Subtype_Scalar_Acc; Ctxt : Rti_Context) + is + Range_Addr : Address; + Rng : Ghdl_Range_Ptr; + begin + Range_Addr := Loc_To_Addr (Def.Common.Depth, + Def.Range_Loc, Ctxt); + Rng := To_Ghdl_Range_Ptr (Range_Addr); + Disp_Range (Stream, Def.Basetype.Kind, Rng); + end Disp_Subtype_Scalar_Range; + + procedure Disp_Subtype_Indication + (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address) + is + begin + case Def.Kind is + when Ghdl_Rtik_Subtype_Scalar => + declare + Rti : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); + if Rti.Name /= null then + Disp_Name (Rti.Name); + else + Disp_Subtype_Indication + (Rti.Basetype, Null_Context, Null_Address); + Put (" range "); + Disp_Subtype_Scalar_Range (stdout, Rti, Ctxt); + end if; + end; + --Disp_Scalar_Subtype_Name (To_Ghdl_Rtin_Scalsubtype_Acc (Def), + -- Base); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when Ghdl_Rtik_Type_File + | Ghdl_Rtik_Type_Access => + Disp_Name (To_Ghdl_Rtin_Type_Fileacc_Acc (Def).Name); + when Ghdl_Rtik_Type_Record => + Disp_Name (To_Ghdl_Rtin_Type_Record_Acc (Def).Name); + when Ghdl_Rtik_Type_Array => + declare + Bounds : Address; + begin + if Obj = Null_Address then + Bounds := Null_Address; + else + Bounds := To_Ghdl_Uc_Array_Acc (Obj).Bounds; + end if; + Disp_Type_Array_Name (To_Ghdl_Rtin_Type_Array_Acc (Def), + Bounds); + end; + when Ghdl_Rtik_Subtype_Array => + declare + Sdef : Ghdl_Rtin_Subtype_Array_Acc; + begin + Sdef := To_Ghdl_Rtin_Subtype_Array_Acc (Def); + if Sdef.Name /= null then + Disp_Name (Sdef.Name); + else + Disp_Type_Array_Name + (Sdef.Basetype, + Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt)); + end if; + end; + when Ghdl_Rtik_Type_Protected => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when others => + Disp_Kind (Def.Kind); + Put (' '); + end case; + end Disp_Subtype_Indication; + + + procedure Disp_Rti (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Indent : Natural); + + procedure Disp_Rti_Arr (Nbr : Ghdl_Index_Type; + Arr : Ghdl_Rti_Arr_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + for I in 1 .. Nbr loop + Disp_Rti (Arr (I - 1), Ctxt, Indent); + end loop; + end Disp_Rti_Arr; + + procedure Disp_Block (Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Nctxt : Rti_Context; + begin + Disp_Indent (Indent); + Disp_Kind (Blk.Common.Kind); + Disp_Depth (Blk.Common.Depth); + Put (": "); + Disp_Name (Blk.Name); + New_Line; + if Blk.Parent /= null then + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + -- Disp entity. + Disp_Rti (Blk.Parent, Ctxt, Indent + 1); + when others => + null; + end case; + end if; + case Blk.Common.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Package_Body + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_Process => + Nctxt := (Base => Ctxt.Base + Blk.Loc, + Block => To_Ghdl_Rti_Access (Blk)); + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + when Ghdl_Rtik_For_Generate => + declare + Length : Ghdl_Index_Type; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all, + Block => To_Ghdl_Rti_Access (Blk)); + Length := Get_For_Generate_Length (Blk, Ctxt); + for I in 1 .. Length loop + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + Nctxt.Base := Nctxt.Base + Blk.Size; + end loop; + end; + when Ghdl_Rtik_If_Generate => + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all, + Block => To_Ghdl_Rti_Access (Blk)); + if Nctxt.Base /= Null_Address then + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + end if; + when others => + Internal_Error ("disp_block"); + end case; + end Disp_Block; + + procedure Disp_Object (Obj : Ghdl_Rtin_Object_Acc; + Is_Sig : Boolean; + Ctxt : Rti_Context; + Indent : Natural) + is + Addr : Address; + Obj_Type : Ghdl_Rti_Access; + begin + Disp_Indent (Indent); + Disp_Kind (Obj.Common.Kind); + Disp_Depth (Obj.Common.Depth); + Put ("; "); + Disp_Name (Obj.Name); + Put (": "); + Addr := Loc_To_Addr (Obj.Common.Depth, Obj.Loc, Ctxt); + Obj_Type := Obj.Obj_Type; + Disp_Subtype_Indication (Obj_Type, Ctxt, Addr); + Put (" := "); + + -- FIXME: put this into a function. + if (Obj_Type.Kind = Ghdl_Rtik_Subtype_Array + or Obj_Type.Kind = Ghdl_Rtik_Type_Record) + and then Rti_Complex_Type (Obj_Type) + then + Addr := To_Addr_Acc (Addr).all; + end if; + Disp_Value (stdout, Obj_Type, Ctxt, Addr, Is_Sig); + New_Line; + end Disp_Object; + + procedure Disp_Attribute (Obj : Ghdl_Rtin_Object_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Obj.Common.Kind); + Disp_Depth (Obj.Common.Depth); + Put ("; "); + Disp_Name (Obj.Name); + Put (": "); + Disp_Subtype_Indication (Obj.Obj_Type, Ctxt, Null_Address); + New_Line; + end Disp_Attribute; + + procedure Disp_Component (Comp : Ghdl_Rtin_Component_Acc; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Comp.Common.Kind); + Disp_Depth (Comp.Common.Depth); + Put (": "); + Disp_Name (Comp.Name); + New_Line; + --Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Base, Ident + 1); + end Disp_Component; + + procedure Disp_Instance (Inst : Ghdl_Rtin_Instance_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Inst_Addr : Address; + Inst_Base : Address; + Inst_Rti : Ghdl_Rti_Access; + Nindent : Natural; + Nctxt : Rti_Context; + begin + Disp_Indent (Indent); + Disp_Kind (Inst.Common.Kind); + Put (": "); + Disp_Name (Inst.Name); + New_Line; + + Inst_Addr := Ctxt.Base + Inst.Loc; + -- Read sub instance. + Inst_Base := To_Addr_Acc (Inst_Addr).all; + + Nindent := Indent + 1; + + case Inst.Instance.Kind is + when Ghdl_Rtik_Component => + declare + Comp : Ghdl_Rtin_Component_Acc; + begin + Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); + Disp_Indent (Nindent); + Disp_Kind (Comp.Common.Kind); + Put (": "); + Disp_Name (Comp.Name); + New_Line; + -- Disp components generics and ports. + -- FIXME: the data to disp are at COMP_BASE. + Nctxt := (Base => Inst_Addr, + Block => Inst.Instance); + Nindent := Nindent + 1; + Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Nctxt, Nindent); + Nindent := Nindent + 1; + end; + when Ghdl_Rtik_Entity => + null; + when others => + null; + end case; + + -- Read instance RTI. + if Inst_Base /= Null_Address then + Inst_Rti := To_Ghdl_Rti_Acc_Acc (Inst_Base).all; + Nctxt := (Base => Inst_Base, + Block => Inst_Rti); + Disp_Block (To_Ghdl_Rtin_Block_Acc (Inst_Rti), + Nctxt, Nindent); + end if; + end Disp_Instance; + + procedure Disp_Type_Enum_Decl (Enum : Ghdl_Rtin_Type_Enum_Acc; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Enum.Common.Kind); + Put (": "); + Disp_Name (Enum.Name); + Put (" is ("); + Disp_Name (Enum.Names (0)); + for I in 1 .. Enum.Nbr - 1 loop + Put (", "); + Disp_Name (Enum.Names (I)); + end loop; + Put (")"); + New_Line; + end Disp_Type_Enum_Decl; + + procedure Disp_Subtype_Scalar_Decl (Def : Ghdl_Rtin_Subtype_Scalar_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Bt : Ghdl_Rti_Access; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Disp_Depth (Def.Common.Depth); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + Bt := Def.Basetype; + case Bt.Kind is + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_F64 => + declare + Bdef : Ghdl_Rtin_Type_Scalar_Acc; + begin + Bdef := To_Ghdl_Rtin_Type_Scalar_Acc (Bt); + if Bdef.Name /= Def.Name then + Disp_Name (Bdef.Name); + Put (" range "); + end if; + -- This is the type definition. + Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); + end; + when Ghdl_Rtik_Type_P64 + | Ghdl_Rtik_Type_P32 => + declare + Bdef : Ghdl_Rtin_Type_Physical_Acc; + Unit : Ghdl_Rti_Access; + begin + Bdef := To_Ghdl_Rtin_Type_Physical_Acc (Bt); + if Bdef.Name /= Def.Name then + Disp_Name (Bdef.Name); + Put (" range "); + end if; + -- This is the type definition. + Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); + if Bdef.Name = Def.Name then + for I in 0 .. Bdef.Nbr - 1 loop + Unit := Bdef.Units (I); + New_Line; + Disp_Indent (Indent + 1); + Disp_Kind (Unit.Kind); + Put (": "); + Disp_Name (Get_Physical_Unit_Name (Unit)); + Put (" = "); + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + Put_I64 (stdout, + To_Ghdl_Rtin_Unit64_Acc (Unit).Value); + when Ghdl_Rtik_Unitptr => + case Bt.Kind is + when Ghdl_Rtik_Type_P64 => + Put_I64 + (stdout, + To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64); + when Ghdl_Rtik_Type_P32 => + Put_I32 + (stdout, + To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32); + when others => + Internal_Error + ("disp_rti.subtype.scalar_decl(P32/P64)"); + end case; + when others => + Internal_Error + ("disp_rti.subtype.scalar_decl(P32/P64)"); + end case; + end loop; + end if; + end; + when others => + Disp_Subtype_Indication + (To_Ghdl_Rti_Access (Def), Ctxt, Null_Address); + end case; + New_Line; + end Disp_Subtype_Scalar_Decl; + + procedure Disp_Type_Array_Decl (Def : Ghdl_Rtin_Type_Array_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is array ("); + for I in 0 .. Def.Nbr_Dim - 1 loop + if I /= 0 then + Put (", "); + end if; + Disp_Subtype_Indication (Def.Indexes (I), Ctxt, Null_Address); + Put (" range <>"); + end loop; + Put (") of "); + Disp_Subtype_Indication (Def.Element, Ctxt, Null_Address); + New_Line; + end Disp_Type_Array_Decl; + + procedure Disp_Subtype_Array_Decl (Def : Ghdl_Rtin_Subtype_Array_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Basetype : constant Ghdl_Rtin_Type_Array_Acc := Def.Basetype; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + Disp_Type_Array_Name + (Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt)); + if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then + Put (" of "); + Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address); + end if; + New_Line; + end Disp_Subtype_Array_Decl; + + procedure Disp_Type_File_Or_Access (Def : Ghdl_Rtin_Type_Fileacc_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + case Def.Common.Kind is + when Ghdl_Rtik_Type_Access => + Put ("access "); + when Ghdl_Rtik_Type_File => + Put ("file "); + when others => + Put ("?? "); + end case; + Disp_Subtype_Indication (Def.Base, Ctxt, Null_Address); + New_Line; + end Disp_Type_File_Or_Access; + + procedure Disp_Type_Record (Def : Ghdl_Rtin_Type_Record_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + El : Ghdl_Rtin_Element_Acc; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is record"); + New_Line; + for I in 1 .. Def.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1)); + Disp_Indent (Indent + 1); + Disp_Kind (El.Common.Kind); + Put (": "); + Disp_Name (El.Name); + Put (": "); + Disp_Subtype_Indication (El.Eltype, Ctxt, Null_Address); + New_Line; + end loop; + end Disp_Type_Record; + + procedure Disp_Type_Protected (Def : Ghdl_Rtin_Type_Scalar_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + pragma Unreferenced (Ctxt); + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is protected"); + New_Line; + end Disp_Type_Protected; + + procedure Disp_Rti (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + if Rti = null then + return; + end if; + + case Rti.Kind is + when Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Package + | Ghdl_Rtik_Process + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate + | Ghdl_Rtik_For_Generate => + Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Package_Body => + Disp_Rti (To_Ghdl_Rtin_Block_Acc (Rti).Parent, Ctxt, Indent); + Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), True, Ctxt, Indent); + when Ghdl_Rtik_Generic + | Ghdl_Rtik_Constant + | Ghdl_Rtik_Variable + | Ghdl_Rtik_Iterator + | Ghdl_Rtik_File => + Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), False, Ctxt, Indent); + when Ghdl_Rtik_Component => + Disp_Component (To_Ghdl_Rtin_Component_Acc (Rti), Indent); + when Ghdl_Rtik_Attribute => + Disp_Attribute (To_Ghdl_Rtin_Object_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Instance => + Disp_Instance (To_Ghdl_Rtin_Instance_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Type_Enum_Decl (To_Ghdl_Rtin_Type_Enum_Acc (Rti), Indent); + when Ghdl_Rtik_Subtype_Scalar => + Disp_Subtype_Scalar_Decl (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti), + Ctxt, Indent); + when Ghdl_Rtik_Type_Array => + Disp_Type_Array_Decl + (To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Subtype_Array => + Disp_Subtype_Array_Decl + (To_Ghdl_Rtin_Subtype_Array_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Access + | Ghdl_Rtik_Type_File => + Disp_Type_File_Or_Access + (To_Ghdl_Rtin_Type_Fileacc_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Record => + Disp_Type_Record + (To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Protected => + Disp_Type_Protected + (To_Ghdl_Rtin_Type_Scalar_Acc (Rti), Ctxt, Indent); + when others => + Disp_Indent (Indent); + Disp_Kind (Rti.Kind); + Put_Line (" ? "); + end case; + end Disp_Rti; + + Disp_Rti_Flag : Boolean := False; + + procedure Disp_All + is + Ctxt : Rti_Context; + begin + if not Disp_Rti_Flag then + return; + end if; + + Put ("DISP_RTI.Disp_All: "); + Disp_Kind (Ghdl_Rti_Top.Common.Kind); + New_Line; + Ctxt := (Base => Ghdl_Rti_Top_Instance, + Block => Ghdl_Rti_Top.Parent); + Disp_Rti_Arr (Ghdl_Rti_Top.Nbr_Child, + Ghdl_Rti_Top.Children, + Ctxt, 0); + Disp_Rti (Ghdl_Rti_Top.Parent, Ctxt, 0); + + --Disp_Hierarchy; + end Disp_All; + + function Disp_Rti_Option (Opt : String) return Boolean + is + begin + if Opt = "--dump-rti" then + Disp_Rti_Flag := True; + return True; + else + return False; + end if; + end Disp_Rti_Option; + + procedure Disp_Rti_Help + is + procedure P (Str : String) renames Put_Line; + begin + P (" --dump-rti dump Run Time Information"); + end Disp_Rti_Help; + + Disp_Rti_Hooks : aliased constant Hooks_Type := + (Option => Disp_Rti_Option'Access, + Help => Disp_Rti_Help'Access, + Init => null, + Start => Disp_All'Access, + Finish => null); + + procedure Register is + begin + Register_Hooks (Disp_Rti_Hooks'Access); + end Register; + +end Grt.Disp_Rti; diff --git a/src/grt/grt-disp_rti.ads b/src/grt/grt-disp_rti.ads new file mode 100644 index 000000000..6033d2011 --- /dev/null +++ b/src/grt/grt-disp_rti.ads @@ -0,0 +1,43 @@ +-- GHDL Run Time (GRT) - RTI dumper. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Types; use Grt.Types; +with Grt.Stdio; use Grt.Stdio; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; + +package Grt.Disp_Rti is + -- Disp NAME. If NAME is null, then disp . + procedure Disp_Name (Name : Ghdl_C_String); + + -- Disp a value. + procedure Disp_Value (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Obj : in out Address; + Is_Sig : Boolean); + + procedure Register; +end Grt.Disp_Rti; diff --git a/src/grt/grt-disp_signals.adb b/src/grt/grt-disp_signals.adb new file mode 100644 index 000000000..424d20dcf --- /dev/null +++ b/src/grt/grt-disp_signals.adb @@ -0,0 +1,524 @@ +-- GHDL Run Time (GRT) - Display subprograms for signals. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Ada.Unchecked_Conversion; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; +with Grt.Astdio; use Grt.Astdio; +with Grt.Errors; use Grt.Errors; +pragma Elaborate_All (Grt.Rtis_Utils); +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Options; +with Grt.Processes; +with Grt.Disp; use Grt.Disp; + +package body Grt.Disp_Signals is + procedure Foreach_Scalar_Signal + (Process : access procedure (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param : Rti_Object)) + is + procedure Call_Process (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param : Rti_Object) is + begin + Process.all (Val_Addr, Val_Name, Val_Type, Param); + end Call_Process; + + pragma Inline (Call_Process); + + procedure Foreach_Scalar_Signal_Signal is new + Foreach_Scalar (Param_Type => Rti_Object, + Process => Call_Process); + + function Foreach_Scalar_Signal_Object + (Ctxt : Rti_Context; Obj : Ghdl_Rti_Access) + return Traverse_Result + is + Sig : Ghdl_Rtin_Object_Acc; + begin + case Obj.Kind is + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Sig := To_Ghdl_Rtin_Object_Acc (Obj); + Foreach_Scalar_Signal_Signal + (Ctxt, Sig.Obj_Type, + Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, + Rti_Object'(Obj, Ctxt)); + when others => + null; + end case; + return Traverse_Ok; + end Foreach_Scalar_Signal_Object; + + function Foreach_Scalar_Signal_Traverse is + new Traverse_Blocks (Process => Foreach_Scalar_Signal_Object); + + Res : Traverse_Result; + pragma Unreferenced (Res); + begin + Res := Foreach_Scalar_Signal_Traverse (Get_Top_Context); + end Foreach_Scalar_Signal; + + procedure Disp_Context (Ctxt : Rti_Context) + is + Blk : Ghdl_Rtin_Block_Acc; + Nctxt : Rti_Context; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Blk.Common.Kind is + when Ghdl_Rtik_Block + | Ghdl_Rtik_Process => + Nctxt := Get_Parent_Context (Ctxt); + Disp_Context (Nctxt); + Put ('.'); + Put (Blk.Name); + when Ghdl_Rtik_Entity => + Put (Blk.Name); + when Ghdl_Rtik_Architecture => + Nctxt := Get_Parent_Context (Ctxt); + Disp_Context (Nctxt); + Put ('('); + Put (Blk.Name); + Put (')'); + when others => + Internal_Error ("disp_context"); + end case; + end Disp_Context; + + -- This is a debugging procedure. + pragma Unreferenced (Disp_Context); + + -- Option --trace-signals. + + -- Disp transaction TRANS from signal SIG. + procedure Disp_Transaction (Trans : Transaction_Acc; + Sig_Type : Ghdl_Rti_Access; + Mode : Mode_Type) + is + T : Transaction_Acc; + begin + T := Trans; + loop + case T.Kind is + when Trans_Value => + if Sig_Type /= null then + Disp_Value (stdout, T.Val, Sig_Type); + else + Disp_Value (T.Val, Mode); + end if; + when Trans_Direct => + if Sig_Type /= null then + Disp_Value (stdout, T.Val_Ptr.all, Sig_Type); + else + Disp_Value (T.Val_Ptr.all, Mode); + end if; + when Trans_Null => + Put ("NULL"); + when Trans_Error => + Put ("ERROR"); + end case; + if T.Kind = Trans_Direct then + -- The Time field is not updated for direct transaction. + Put ("[DIRECT]"); + else + Put ("@"); + Put_Time (stdout, T.Time); + end if; + T := T.Next; + exit when T = null; + Put (", "); + end loop; + end Disp_Transaction; + + procedure Disp_Simple_Signal + (Sig : Ghdl_Signal_Ptr; Sig_Type : Ghdl_Rti_Access; Sources : Boolean) + is + function To_Address is new Ada.Unchecked_Conversion + (Source => Resolved_Signal_Acc, Target => Address); + begin + Put (' '); + Put (stdout, Sig.all'Address); + Put (' '); + Disp_Mode (Sig.Mode); + Put (' '); + if Sig.Active then + Put ('A'); + else + Put ('-'); + end if; + if Sig.Event then + Put ('E'); + else + Put ('-'); + end if; + if Sig.Has_Active then + Put ('a'); + else + Put ('-'); + end if; + if Sig.S.Effective /= null then + Put ('e'); + else + Put ('-'); + end if; + if Boolean'(True) then + Put (" last_event="); + Put_Time (stdout, Sig.Last_Event); + Put (" last_active="); + Put_Time (stdout, Sig.Last_Active); + end if; + Put (" val="); + if Sig_Type /= null then + Disp_Value (stdout, Sig.Value, Sig_Type); + else + Disp_Value (Sig.Value, Sig.Mode); + end if; + Put ("; drv="); + if Sig_Type /= null then + Disp_Value (stdout, Sig.Driving_Value, Sig_Type); + else + Disp_Value (Sig.Driving_Value, Sig.Mode); + end if; + if Sources then + if Sig.Nbr_Ports > 0 then + Put (';'); + Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports)); + Put (" ports"); + end if; + if Sig.S.Mode_Sig in Mode_Signal_User then + if Sig.S.Resolv /= null then + Put (stdout, " res func "); + Put (stdout, To_Address(Sig.S.Resolv)); + end if; + if Sig.S.Nbr_Drivers = 0 then + Put ("; no driver"); + elsif Sig.S.Nbr_Drivers = 1 then + Put ("; trans="); + Disp_Transaction + (Sig.S.Drivers (0).First_Trans, Sig_Type, Sig.Mode); + else + for I in 0 .. Sig.S.Nbr_Drivers - 1 loop + New_Line; + Put (" "); + Disp_Transaction + (Sig.S.Drivers (I).First_Trans, Sig_Type, Sig.Mode); + end loop; + end if; + end if; + end if; + New_Line; + end Disp_Simple_Signal; + + procedure Disp_Signal_Name (Stream : FILEs; + Ctxt : Rti_Context; + Sig : Ghdl_Rtin_Object_Acc) is + begin + case Sig.Common.Kind is + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard => + Put (stdout, Ctxt); + Put ("."); + Put (Stream, Sig.Name); + when Ghdl_Rtik_Attribute_Quiet => + Put (stdout, Ctxt); + Put ("."); + Put (Stream, " 'quiet"); + when Ghdl_Rtik_Attribute_Stable => + Put (stdout, Ctxt); + Put ("."); + Put (Stream, " 'stable"); + when Ghdl_Rtik_Attribute_Transaction => + Put (stdout, Ctxt); + Put ("."); + Put (Stream, " 'transaction"); + when others => + null; + end case; + end Disp_Signal_Name; + + procedure Disp_Scalar_Signal (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) + is + begin + Disp_Signal_Name (stdout, Parent.Ctxt, + To_Ghdl_Rtin_Object_Acc (Parent.Obj)); + Put (stdout, Val_Name); + Disp_Simple_Signal (To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all), + Val_Type, Options.Disp_Sources); + end Disp_Scalar_Signal; + + + procedure Disp_All_Signals is + begin + Foreach_Scalar_Signal (Disp_Scalar_Signal'access); + end Disp_All_Signals; + + -- Option disp-sensitivity + + procedure Disp_Scalar_Sensitivity (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) + is + pragma Unreferenced (Val_Type); + Sig : Ghdl_Signal_Ptr; + + Action : Action_List_Acc; + begin + Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); + if Sig.Flags.Seen then + return; + else + Sig.Flags.Seen := True; + end if; + Disp_Signal_Name (stdout, Parent.Ctxt, + To_Ghdl_Rtin_Object_Acc (Parent.Obj)); + Put (stdout, Val_Name); + New_Line (stdout); + + Action := Sig.Event_List; + while Action /= null loop + Put (stdout, " wakeup "); + Grt.Processes.Disp_Process_Name (stdout, Action.Proc); + New_Line (stdout); + Action := Action.Next; + end loop; + + if Sig.S.Mode_Sig in Mode_Signal_User then + for I in 1 .. Sig.S.Nbr_Drivers loop + Put (stdout, " driven "); + Grt.Processes.Disp_Process_Name + (stdout, Sig.S.Drivers (I - 1).Proc); + New_Line (stdout); + end loop; + end if; + end Disp_Scalar_Sensitivity; + + procedure Disp_All_Sensitivity is + begin + Foreach_Scalar_Signal (Disp_Scalar_Sensitivity'access); + end Disp_All_Sensitivity; + + + -- Option disp-signals-map + + procedure Disp_Signals_Map_Scalar (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) + is + pragma Unreferenced (Val_Type); + + function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Signal_Ptr); + + S : Ghdl_Signal_Ptr; + begin + Disp_Signal_Name (stdout, + Parent.Ctxt, To_Ghdl_Rtin_Object_Acc (Parent.Obj)); + Put (stdout, Val_Name); + Put (": "); + S := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); + Put (stdout, S.all'Address); + Put (" net: "); + Put_I32 (stdout, Ghdl_I32 (S.Net)); + if S.Has_Active then + Put (" +A"); + end if; + New_Line; + end Disp_Signals_Map_Scalar; + + procedure Disp_Signals_Map is + begin + Foreach_Scalar_Signal (Disp_Signals_Map_Scalar'access); + end Disp_Signals_Map; + + -- Option --disp-signals-table + procedure Disp_Mode_Signal (Mode : Mode_Signal_Type) + is + begin + case Mode is + when Mode_Signal => + Put ("signal"); + when Mode_Linkage => + Put ("linkage"); + when Mode_Buffer => + Put ("buffer"); + when Mode_Out => + Put ("out"); + when Mode_Inout => + Put ("inout"); + when Mode_In => + Put ("in"); + when Mode_Stable => + Put ("stable"); + when Mode_Quiet => + Put ("quiet"); + when Mode_Transaction => + Put ("transaction"); + when Mode_Delayed => + Put ("delayed"); + when Mode_Guard => + Put ("guard"); + when Mode_Conv_In => + Put ("conv_in"); + when Mode_Conv_Out => + Put ("conv_out"); + when Mode_End => + Put ("end"); + end case; + end Disp_Mode_Signal; + + procedure Disp_Signals_Table + is + Sig : Ghdl_Signal_Ptr; + begin + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + Put_Sig_Index (I); + Put (": "); + Put (stdout, Sig.all'Address); + if Sig.Has_Active then + Put (" +A"); + end if; + Put (" net: "); + Put_I32 (stdout, Ghdl_I32 (Sig.Net)); + Put (" smode: "); + Disp_Mode_Signal (Sig.S.Mode_Sig); + Put (" #prt: "); + Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports)); + if Sig.S.Mode_Sig in Mode_Signal_User then + Put (" #drv: "); + Put_I32 (stdout, Ghdl_I32 (Sig.S.Nbr_Drivers)); + if Sig.S.Effective /= null then + Put (" eff: "); + Put (stdout, Sig.S.Effective.all'Address); + end if; + if Sig.S.Resolv /= null then + Put (" resolved"); + end if; + end if; + if Boolean'(False) then + Put (" link: "); + Put (stdout, Sig.Link.all'Address); + end if; + New_Line; + if Sig.Nbr_Ports /= 0 then + for J in 1 .. Sig.Nbr_Ports loop + Put (" "); + Put (stdout, Sig.Ports (J - 1).all'Address); + end loop; + New_Line; + end if; + end loop; + Grt.Stdio.fflush (stdout); + end Disp_Signals_Table; + + procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr) + is + begin + Disp_Simple_Signal (Sig, null, True); + end Disp_A_Signal; + + procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr) + is + Found : Boolean := False; + Cur_Ctxt : Rti_Context; + Cur_Sig : Ghdl_Rtin_Object_Acc; + + procedure Process_Scalar (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param : Boolean) + is + pragma Unreferenced (Val_Type); + pragma Unreferenced (Param); + Sig1 : Ghdl_Signal_Ptr; + begin + -- Read the signal. + Sig1 := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); + if Sig1 = Sig and not Found then + Disp_Signal_Name (Stream, Cur_Ctxt, Cur_Sig); + Put (Stream, Val_Name); + Found := True; + end if; + end Process_Scalar; + + procedure Foreach_Scalar is new Grt.Rtis_Utils.Foreach_Scalar + (Param_Type => Boolean, Process => Process_Scalar); + + function Process_Block (Ctxt : Rti_Context; + Obj : Ghdl_Rti_Access) + return Traverse_Result + is + begin + case Obj.Kind is + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Transaction => + Cur_Ctxt := Ctxt; + Cur_Sig := To_Ghdl_Rtin_Object_Acc (Obj); + Foreach_Scalar + (Ctxt, Cur_Sig.Obj_Type, + Loc_To_Addr (Cur_Sig.Common.Depth, Cur_Sig.Loc, Ctxt), + True, True); + if Found then + return Traverse_Stop; + end if; + when others => + null; + end case; + return Traverse_Ok; + end Process_Block; + + function Foreach_Block is new Grt.Rtis_Utils.Traverse_Blocks + (Process_Block); + + Res_Status : Traverse_Result; + pragma Unreferenced (Res_Status); + begin + Res_Status := Foreach_Block (Get_Top_Context); + if not Found then + Put (Stream, "(unknown signal)"); + end if; + end Put_Signal_Name; + +end Grt.Disp_Signals; diff --git a/src/grt/grt-disp_signals.ads b/src/grt/grt-disp_signals.ads new file mode 100644 index 000000000..73bd60d06 --- /dev/null +++ b/src/grt/grt-disp_signals.ads @@ -0,0 +1,48 @@ +-- GHDL Run Time (GRT) - Display subprograms for signals. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Signals; use Grt.Signals; +with Grt.Stdio; use Grt.Stdio; + +package Grt.Disp_Signals is + procedure Disp_All_Signals; + + procedure Disp_Signals_Map; + + procedure Disp_Signals_Table; + + procedure Disp_All_Sensitivity; + + procedure Disp_Mode_Signal (Mode : Mode_Signal_Type); + + -- Disp informations on signal SIG. + -- To be used inside the debugger. + procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr); + + -- Put the full name of signal SIG. + -- This operation is really expensive, since the whole hierarchy is + -- traversed. + procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr); +end Grt.Disp_Signals; diff --git a/src/grt/grt-disp_tree.adb b/src/grt/grt-disp_tree.adb new file mode 100644 index 000000000..7d5811960 --- /dev/null +++ b/src/grt/grt-disp_tree.adb @@ -0,0 +1,461 @@ +-- GHDL Run Time (GRT) - Tree displayer. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Disp_Rti; use Grt.Disp_Rti; +with Grt.Rtis; use Grt.Rtis; +with Grt.Stdio; use Grt.Stdio; +with Grt.Astdio; use Grt.Astdio; +with Grt.Types; use Grt.Types; +with Grt.Errors; use Grt.Errors; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Hooks; use Grt.Hooks; + +package body Grt.Disp_Tree is + -- Set by --disp-tree, to display the design hierarchy. + type Disp_Tree_Kind is + ( + Disp_Tree_None, -- Do not disp tree. + Disp_Tree_Inst, -- Disp entities, arch, package, blocks, components. + Disp_Tree_Proc, -- As above plus processes + Disp_Tree_Port -- As above plus ports and signals. + ); + Disp_Tree_Flag : Disp_Tree_Kind := Disp_Tree_None; + + + -- Get next interesting child. + procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc; + Index : in out Ghdl_Index_Type; + Child : out Ghdl_Rti_Access) + is + begin + -- Exit if no more children. + while Index < Parent.Nbr_Child loop + Child := Parent.Children (Index); + Index := Index + 1; + case Child.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate + | Ghdl_Rtik_Instance => + return; + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard => + if Disp_Tree_Flag >= Disp_Tree_Port then + return; + end if; + when Ghdl_Rtik_Process => + if Disp_Tree_Flag >= Disp_Tree_Proc then + return; + end if; + when others => + null; + end case; + end loop; + Child := null; + end Get_Tree_Child; + + procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Entity + | Ghdl_Rtik_Process + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate => + declare + Blk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Rti); + begin + Disp_Name (Blk.Name); + end; + when Ghdl_Rtik_Package_Body + | Ghdl_Rtik_Package => + declare + Blk : Ghdl_Rtin_Block_Acc; + Lib : Ghdl_Rtin_Type_Scalar_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Rti); + if Rti.Kind = Ghdl_Rtik_Package_Body then + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + end if; + Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent); + Disp_Name (Lib.Name); + Put ('.'); + Disp_Name (Blk.Name); + end; + when Ghdl_Rtik_For_Generate => + declare + Blk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Rti); + Iter : Ghdl_Rtin_Object_Acc; + Addr : Address; + begin + Disp_Name (Blk.Name); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); + Put ('('); + Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False); + Put (')'); + end; + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Iterator => + Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name); + when Ghdl_Rtik_Instance => + Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name); + when others => + null; + end case; + + case Rti.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Package_Body => + Put (" [package]"); + when Ghdl_Rtik_Entity => + Put (" [entity]"); + when Ghdl_Rtik_Architecture => + Put (" [arch]"); + when Ghdl_Rtik_Process => + Put (" [process]"); + when Ghdl_Rtik_Block => + Put (" [block]"); + when Ghdl_Rtik_For_Generate => + Put (" [for-generate]"); + when Ghdl_Rtik_If_Generate => + Put (" [if-generate "); + if Ctxt.Base = Null_Address then + Put ("false]"); + else + Put ("true]"); + end if; + when Ghdl_Rtik_Signal => + Put (" [signal]"); + when Ghdl_Rtik_Port => + Put (" [port "); + case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is + when Ghdl_Rti_Signal_Mode_In => + Put ("in"); + when Ghdl_Rti_Signal_Mode_Out => + Put ("out"); + when Ghdl_Rti_Signal_Mode_Inout => + Put ("inout"); + when Ghdl_Rti_Signal_Mode_Buffer => + Put ("buffer"); + when Ghdl_Rti_Signal_Mode_Linkage => + Put ("linkage"); + when others => + Put ("?"); + end case; + Put ("]"); + when Ghdl_Rtik_Guard => + Put (" [guard]"); + when Ghdl_Rtik_Iterator => + Put (" [iterator]"); + when Ghdl_Rtik_Instance => + Put (" [instance]"); + when others => + null; + end case; + end Disp_Tree_Child; + + procedure Disp_Tree_Block + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String); + + procedure Disp_Tree_Block1 + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) + is + Child : Ghdl_Rti_Access; + Child2 : Ghdl_Rti_Access; + Index : Ghdl_Index_Type; + + procedure Disp_Header (Nctxt : Rti_Context; + Force_Cont : Boolean := False) + is + begin + Put (Pfx); + + if Blk.Common.Kind /= Ghdl_Rtik_Entity + and Child2 = null + and Force_Cont = False + then + Put ("`-"); + else + Put ("+-"); + end if; + + Disp_Tree_Child (Child, Nctxt); + New_Line; + end Disp_Header; + + procedure Disp_Sub_Block + (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context) + is + Npfx : String (1 .. Pfx'Length + 2); + begin + Npfx (1 .. Pfx'Length) := Pfx; + Npfx (Pfx'Length + 2) := ' '; + if Child2 = null then + Npfx (Pfx'Length + 1) := ' '; + else + Npfx (Pfx'Length + 1) := '|'; + end if; + Disp_Tree_Block (Sub_Blk, Nctxt, Npfx); + end Disp_Sub_Block; + + begin + Index := 0; + Get_Tree_Child (Blk, Index, Child); + while Child /= null loop + Get_Tree_Child (Blk, Index, Child2); + + case Child.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + declare + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + begin + Nctxt := (Base => Ctxt.Base + Nblk.Loc, + Block => Child); + Disp_Header (Nctxt, False); + Disp_Sub_Block (Nblk, Nctxt); + end; + when Ghdl_Rtik_For_Generate => + declare + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + Length : Ghdl_Index_Type; + Old_Child2 : Ghdl_Rti_Access; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + Length := Get_For_Generate_Length (Nblk, Ctxt); + Disp_Header (Nctxt, Length > 1); + Old_Child2 := Child2; + if Length > 1 then + Child2 := Child; + end if; + for I in 1 .. Length loop + Disp_Sub_Block (Nblk, Nctxt); + if I /= Length then + Nctxt.Base := Nctxt.Base + Nblk.Size; + if I = Length - 1 then + Child2 := Old_Child2; + end if; + Disp_Header (Nctxt); + end if; + end loop; + Child2 := Old_Child2; + end; + when Ghdl_Rtik_If_Generate => + declare + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + Disp_Header (Nctxt); + if Nctxt.Base /= Null_Address then + Disp_Sub_Block (Nblk, Nctxt); + end if; + end; + when Ghdl_Rtik_Instance => + declare + Inst : Ghdl_Rtin_Instance_Acc; + Sub_Ctxt : Rti_Context; + Sub_Blk : Ghdl_Rtin_Block_Acc; + Npfx : String (1 .. Pfx'Length + 4); + Comp : Ghdl_Rtin_Component_Acc; + Ch : Ghdl_Rti_Access; + begin + Disp_Header (Ctxt); + Inst := To_Ghdl_Rtin_Instance_Acc (Child); + Get_Instance_Context (Inst, Ctxt, Sub_Ctxt); + Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block); + if Inst.Instance.Kind = Ghdl_Rtik_Component + and then Disp_Tree_Flag >= Disp_Tree_Port + then + -- Disp generics and ports of the component. + Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); + for I in 1 .. Comp.Nbr_Child loop + Ch := Comp.Children (I - 1); + if Ch.Kind = Ghdl_Rtik_Port then + -- Disp only port (and not generics). + Put (Pfx); + if Child2 = null then + Put (" "); + else + Put ("| "); + end if; + if I = Comp.Nbr_Child and then Sub_Blk = null then + Put ("`-"); + else + Put ("+-"); + end if; + Disp_Tree_Child (Ch, Sub_Ctxt); + New_Line; + end if; + end loop; + end if; + if Sub_Blk /= null then + Npfx (1 .. Pfx'Length) := Pfx; + if Child2 = null then + Npfx (Pfx'Length + 1) := ' '; + else + Npfx (Pfx'Length + 1) := '|'; + end if; + Npfx (Pfx'Length + 2) := ' '; + Npfx (Pfx'Length + 3) := '`'; + Npfx (Pfx'Length + 4) := '-'; + Put (Npfx); + Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt); + New_Line; + Npfx (Pfx'Length + 3) := ' '; + Npfx (Pfx'Length + 4) := ' '; + Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx); + end if; + end; + when others => + Disp_Header (Ctxt); + end case; + + Child := Child2; + end loop; + end Disp_Tree_Block1; + + procedure Disp_Tree_Block + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) + is + begin + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + declare + Npfx : String (1 .. Pfx'Length + 2); + Nctxt : Rti_Context; + begin + -- The entity. + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + Disp_Tree_Block1 + (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx); + -- Then the architecture. + Put (Pfx); + Put ("`-"); + Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt); + New_Line; + Npfx (1 .. Pfx'Length) := Pfx; + Npfx (Pfx'Length + 1) := ' '; + Npfx (Pfx'Length + 2) := ' '; + Disp_Tree_Block1 (Blk, Ctxt, Npfx); + end; + when Ghdl_Rtik_Package_Body => + Disp_Tree_Block1 + (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx); + when others => + Disp_Tree_Block1 (Blk, Ctxt, Pfx); + end case; + end Disp_Tree_Block; + + procedure Disp_Hierarchy + is + Ctxt : Rti_Context; + Parent : Ghdl_Rtin_Block_Acc; + Child : Ghdl_Rti_Access; + begin + if Disp_Tree_Flag = Disp_Tree_None then + return; + end if; + + Ctxt := Get_Top_Context; + Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + + Disp_Tree_Child (Parent.Parent, Ctxt); + New_Line; + Disp_Tree_Block (Parent, Ctxt, ""); + + for I in 1 .. Ghdl_Rti_Top.Nbr_Child loop + Child := Ghdl_Rti_Top.Children (I - 1); + Ctxt := (Base => Null_Address, + Block => Child); + Disp_Tree_Child (Child, Ctxt); + New_Line; + Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, ""); + end loop; + end Disp_Hierarchy; + + function Disp_Tree_Option (Option : String) return Boolean + is + Opt : constant String (1 .. Option'Length) := Option; + begin + if Opt'Length >= 11 and then Opt (1 .. 11) = "--disp-tree" then + if Opt'Length = 11 then + Disp_Tree_Flag := Disp_Tree_Port; + elsif Opt (12 .. Opt'Last) = "=port" then + Disp_Tree_Flag := Disp_Tree_Port; + elsif Opt (12 .. Opt'Last) = "=proc" then + Disp_Tree_Flag := Disp_Tree_Proc; + elsif Opt (12 .. Opt'Last) = "=inst" then + Disp_Tree_Flag := Disp_Tree_Inst; + elsif Opt (12 .. Opt'Last) = "=none" then + Disp_Tree_Flag := Disp_Tree_None; + else + Error ("bad argument for --disp-tree option, try --help"); + end if; + return True; + else + return False; + end if; + end Disp_Tree_Option; + + procedure Disp_Tree_Help + is + procedure P (Str : String) renames Put_Line; + begin + P (" --disp-tree[=KIND] disp the design hierarchy after elaboration"); + P (" KIND is inst, proc, port (default)"); + end Disp_Tree_Help; + + Disp_Tree_Hooks : aliased constant Hooks_Type := + (Option => Disp_Tree_Option'Access, + Help => Disp_Tree_Help'Access, + Init => null, + Start => Disp_Hierarchy'Access, + Finish => null); + + procedure Register is + begin + Register_Hooks (Disp_Tree_Hooks'Access); + end Register; + +end Grt.Disp_Tree; diff --git a/src/grt/grt-disp_tree.ads b/src/grt/grt-disp_tree.ads new file mode 100644 index 000000000..e3bc983a7 --- /dev/null +++ b/src/grt/grt-disp_tree.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - RTI dumper. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +package Grt.Disp_Tree is + procedure Register; +end Grt.Disp_Tree; diff --git a/src/grt/grt-errors.adb b/src/grt/grt-errors.adb new file mode 100644 index 000000000..eddea38c1 --- /dev/null +++ b/src/grt/grt-errors.adb @@ -0,0 +1,253 @@ +-- GHDL Run Time (GRT) - Error handling. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Stdio; use Grt.Stdio; +with Grt.Astdio; use Grt.Astdio; +with Grt.Options; use Grt.Options; +with Grt.Hooks; use Grt.Hooks; + +package body Grt.Errors is + -- Called in case of premature exit. + -- CODE is 0 for success, 1 for failure. + procedure Ghdl_Exit (Code : Integer); + pragma No_Return (Ghdl_Exit); + + procedure Ghdl_Exit (Code : Integer) + is + procedure C_Exit (Status : Integer); + pragma Import (C, C_Exit, "exit"); + pragma No_Return (C_Exit); + begin + C_Exit (Code); + end Ghdl_Exit; + + procedure Maybe_Return_Via_Longjump (Val : Integer); + pragma Import (C, Maybe_Return_Via_Longjump, + "__ghdl_maybe_return_via_longjump"); + + procedure Exit_Simulation is + begin + Maybe_Return_Via_Longjump (-2); + Internal_Error ("exit_simulation"); + end Exit_Simulation; + + procedure Fatal_Error is + begin + if Error_Hook /= null then + -- Call the hook, but avoid infinite loop by reseting it. + declare + Current_Hook : constant Proc_Hook_Type := Error_Hook; + begin + Error_Hook := null; + Current_Hook.all; + end; + end if; + Maybe_Return_Via_Longjump (-1); + if Expect_Failure then + Ghdl_Exit (0); + else + Ghdl_Exit (1); + end if; + end Fatal_Error; + + procedure Put_Err (Str : String) is + begin + Put (stderr, Str); + end Put_Err; + + procedure Put_Err (Str : Ghdl_C_String) is + begin + Put (stderr, Str); + end Put_Err; + + procedure Put_Err (N : Integer) is + begin + Put_I32 (stderr, Ghdl_I32 (N)); + end Put_Err; + + procedure Newline_Err is + begin + New_Line (stderr); + end Newline_Err; + +-- procedure Put_Err (Str : Ghdl_Str_Len_Type) +-- is +-- S : String (1 .. 3); +-- begin +-- if Str.Str = null then +-- S (1) := '''; +-- S (2) := Character'Val (Str.Len); +-- S (3) := '''; +-- Put_Err (S); +-- else +-- Put_Err (Str.Str (1 .. Str.Len)); +-- end if; +-- end Put_Err; + + procedure Report_H (Str : String := "") is + begin + Put_Err (Str); + end Report_H; + + procedure Report_C (Str : String) is + begin + Put_Err (Str); + end Report_C; + + procedure Report_C (Str : Ghdl_C_String) + is + Len : constant Natural := strlen (Str); + begin + Put_Err (Str (1 .. Len)); + end Report_C; + + procedure Report_C (N : Integer) + renames Put_Err; + + procedure Report_Now_C is + begin + Put_Time (stderr, Grt.Types.Current_Time); + end Report_Now_C; + + procedure Report_E (Str : String) is + begin + Put_Err (Str); + Newline_Err; + end Report_E; + + procedure Report_E (Str : Std_String_Ptr) + is + subtype Ada_Str is String (1 .. Natural (Str.Bounds.Dim_1.Length)); + begin + if Ada_Str'Length > 0 then + Put_Err (Ada_Str (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1))); + end if; + Newline_Err; + end Report_E; + + procedure Error_H is + begin + Put_Err (Progname); + Put_Err (":error: "); + end Error_H; + + Cont : Boolean := False; + + procedure Error_C (Str : String) is + begin + if not Cont then + Error_H; + Cont := True; + end if; + Put_Err (Str); + end Error_C; + + procedure Error_C (Str : Ghdl_C_String) + is + Len : constant Natural := strlen (Str); + begin + if not Cont then + Error_H; + Cont := True; + end if; + Put_Err (Str (1 .. Len)); + end Error_C; + + procedure Error_C (N : Integer) is + begin + if not Cont then + Error_H; + Cont := True; + end if; + Put_Err (N); + end Error_C; + +-- procedure Error_C (Inst : Ghdl_Instance_Name_Acc) +-- is +-- begin +-- if not Cont then +-- Error_H; +-- Cont := True; +-- end if; +-- if Inst.Parent /= null then +-- Error_C (Inst.Parent); +-- Put_Err ("."); +-- end if; +-- case Inst.Kind is +-- when Ghdl_Name_Architecture => +-- Put_Err ("("); +-- Put_Err (Inst.Name.all); +-- Put_Err (")"); +-- when others => +-- if Inst.Name /= null then +-- Put_Err (Inst.Name.all); +-- end if; +-- end case; +-- end Error_C; + + procedure Error_E (Str : String := "") is + begin + Put_Err (Str); + Newline_Err; + Cont := False; + Fatal_Error; + end Error_E; + + procedure Error_C_Std (Str : Std_String_Uncons) + is + subtype Str_Subtype is String (1 .. Str'Length); + begin + Error_C (Str_Subtype (Str)); + end Error_C_Std; + + procedure Error (Str : String) is + begin + Error_H; + Put_Err (Str); + Newline_Err; + Fatal_Error; + end Error; + + procedure Info (Str : String) is + begin + Put_Err (Progname); + Put_Err (":info: "); + Put_Err (Str); + Newline_Err; + end Info; + + procedure Internal_Error (Msg : String) is + begin + Put_Err (Progname); + Put_Err (":internal error: "); + Put_Err (Msg); + Newline_Err; + Fatal_Error; + end Internal_Error; + + procedure Grt_Overflow_Error is + begin + Error ("overflow detected"); + end Grt_Overflow_Error; +end Grt.Errors; diff --git a/src/grt/grt-errors.ads b/src/grt/grt-errors.ads new file mode 100644 index 000000000..c797a71bd --- /dev/null +++ b/src/grt/grt-errors.ads @@ -0,0 +1,84 @@ +-- GHDL Run Time (GRT) - Error handling. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Hooks; + +package Grt.Errors is + pragma Preelaborate (Grt.Errors); + + -- Multi-call error procedure. + -- Start and continue with Error_C, finish by an Error_E. + procedure Error_C (Str : String); + procedure Error_C (N : Integer); + procedure Error_C (Str : Ghdl_C_String); + procedure Error_C_Std (Str : Std_String_Uncons); + --procedure Error_C (Inst : Ghdl_Instance_Name_Acc); + procedure Error_E (Str : String := ""); + -- procedure Error_E_Std (Str : Std_String_Uncons); + pragma No_Return (Error_E); + + -- Multi-call report procedure. Do not exit at end. + procedure Report_H (Str : String := ""); + procedure Report_C (Str : Ghdl_C_String); + procedure Report_C (Str : String); + procedure Report_C (N : Integer); + procedure Report_Now_C; + procedure Report_E (Str : String); + procedure Report_E (Str : Std_String_Ptr); + + -- Complete error message. + procedure Error (Str : String); + + -- Internal error. The message must contain the subprogram name which + -- has called this procedure. + procedure Internal_Error (Msg : String); + pragma No_Return (Internal_Error); + + -- Display a message which is not an error. + procedure Info (Str : String); + + -- Display an error message for an overflow. + procedure Grt_Overflow_Error; + + -- Called at end of error message. Central point for failures. + procedure Fatal_Error; + pragma No_Return (Fatal_Error); + pragma Export (C, Fatal_Error, "__ghdl_fatal"); + + Exit_Status : Integer := 0; + procedure Exit_Simulation; + + -- Hook called in case of error. + Error_Hook : Grt.Hooks.Proc_Hook_Type := null; + + -- If true, an error is expected and the exit status is inverted. + Expect_Failure : Boolean := False; + +private + pragma Export (C, Grt_Overflow_Error, "grt_overflow_error"); + + pragma No_Return (Error); +end Grt.Errors; + diff --git a/src/grt/grt-files.adb b/src/grt/grt-files.adb new file mode 100644 index 000000000..30d51cf43 --- /dev/null +++ b/src/grt/grt-files.adb @@ -0,0 +1,452 @@ +-- GHDL Run Time (GRT) - VHDL files subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Table; +with System; use System; +pragma Elaborate_All (Grt.Table); + +package body Grt.Files is + subtype C_Files is Grt.Stdio.FILEs; + + Auto_Flush : constant Boolean := False; + + type File_Entry_Type is record + Stream : C_Files; + Signature : Ghdl_C_String; + Is_Text : Boolean; + Is_Alive : Boolean; + end record; + + package Files_Table is new Grt.Table + (Table_Component_Type => File_Entry_Type, + Table_Index_Type => Ghdl_File_Index, + Table_Low_Bound => 1, + Table_Initial => 2); + + function Get_File (Index : Ghdl_File_Index) return C_Files + is + begin + if Index not in Files_Table.First .. Files_Table.Last then + Internal_Error ("get_file: bad file index"); + end if; + return Files_Table.Table (Index).Stream; + end Get_File; + + procedure Check_File_Mode (Index : Ghdl_File_Index; Is_Text : Boolean) + is + begin + if Files_Table.Table (Index).Is_Text /= Is_Text then + Internal_Error ("check_file_mode: bad file mode"); + end if; + end Check_File_Mode; + + function Create_File (Is_Text : Boolean; Sig : Ghdl_C_String) + return Ghdl_File_Index is + begin + Files_Table.Append ((Stream => NULL_Stream, + Signature => Sig, + Is_Text => Is_Text, + Is_Alive => True)); + return Files_Table.Last; + end Create_File; + + procedure Destroy_File (Is_Text : Boolean; Index : Ghdl_File_Index) is + begin + if Get_File (Index) /= NULL_Stream then + Internal_Error ("destroy_file"); + end if; + Check_File_Mode (Index, Is_Text); + Files_Table.Table (Index).Is_Alive := False; + if Index = Files_Table.Last then + while Files_Table.Last >= Files_Table.First + and then Files_Table.Table (Files_Table.Last).Is_Alive = False + loop + Files_Table.Decrement_Last; + end loop; + end if; + end Destroy_File; + + procedure File_Error (File : Ghdl_File_Index) + is + pragma Unreferenced (File); + begin + Internal_Error ("file: IO error"); + end File_Error; + + function Ghdl_Text_File_Elaborate return Ghdl_File_Index is + begin + return Create_File (True, null); + end Ghdl_Text_File_Elaborate; + + function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index + is + begin + return Create_File (False, Sig); + end Ghdl_File_Elaborate; + + procedure Ghdl_Text_File_Finalize (File : Ghdl_File_Index) is + begin + Destroy_File (True, File); + end Ghdl_Text_File_Finalize; + + procedure Ghdl_File_Finalize (File : Ghdl_File_Index) is + begin + Destroy_File (False, File); + end Ghdl_File_Finalize; + + function Ghdl_File_Endfile (File : Ghdl_File_Index) return Boolean + is + Stream : C_Files; + C : int; + begin + Stream := Get_File (File); + if feof (Stream) /= 0 then + return True; + end if; + C := fgetc (Stream); + if C < 0 then + return True; + end if; + if ungetc (C, Stream) /= C then + Error ("internal error: ungetc"); + end if; + return False; + end Ghdl_File_Endfile; + + Sig_Header : constant String := "#GHDL-BINARY-FILE-0.0" & Nl; + + function File_Open (File : Ghdl_File_Index; + Mode : Ghdl_I32; + Str : Std_String_Ptr) + return Ghdl_I32 + is + Name : String (1 .. Integer (Str.Bounds.Dim_1.Length) + 1); + Str_Mode : String (1 .. 3); + F : C_Files; + Sig : Ghdl_C_String; + Sig_Len : Natural; + begin + F := Get_File (File); + + if F /= NULL_Stream then + -- File was already open. + return Status_Error; + end if; + + -- Copy file name and convert it to a C string (NUL terminated). + for I in 1 .. Str.Bounds.Dim_1.Length loop + Name (Natural (I)) := Str.Base (I - 1); + end loop; + Name (Name'Last) := NUL; + + if Name = "STD_INPUT" & NUL then + if Mode /= Read_Mode then + return Mode_Error; + end if; + F := stdin; + elsif Name = "STD_OUTPUT" & NUL then + if Mode /= Write_Mode then + return Mode_Error; + end if; + F := stdout; + else + case Mode is + when Read_Mode => + Str_Mode (1) := 'r'; + when Write_Mode => + Str_Mode (1) := 'w'; + when Append_Mode => + Str_Mode (1) := 'a'; + when others => + -- Bad mode, cannot happen. + Internal_Error ("file_open: bad open mode"); + end case; + if Files_Table.Table (File).Is_Text then + Str_Mode (2) := NUL; + else + Str_Mode (2) := 'b'; + Str_Mode (3) := NUL; + end if; + F := fopen (Name'Address, Str_Mode'Address); + if F = NULL_Stream then + return Name_Error; + end if; + end if; + Sig := Files_Table.Table (File).Signature; + if Sig /= null then + Sig_Len := strlen (Sig); + case Mode is + when Write_Mode => + if fwrite (Sig_Header'Address, 1, Sig_Header'Length, F) + /= Sig_Header'Length + then + File_Error (File); + end if; + if fwrite (Sig (1)'Address, 1, size_t (Sig_Len), F) + /= size_t (Sig_Len) + then + File_Error (File); + end if; + when Read_Mode => + declare + Hdr : String (1 .. Sig_Header'Length); + Sig_Buf : String (1 .. Sig_Len); + begin + if fread (Hdr'Address, 1, Hdr'Length, F) /= Hdr'Length then + File_Error (File); + end if; + if Hdr /= Sig_Header then + File_Error (File); + end if; + if fread (Sig_Buf'Address, 1, Sig_Buf'Length, F) + /= Sig_Buf'Length + then + File_Error (File); + end if; + if Sig_Buf /= Sig (1 .. Sig_Len) then + File_Error (File); + end if; + end; + when Append_Mode => + null; + when others => + null; + end case; + end if; + Files_Table.Table (File).Stream := F; + return Open_Ok; + end File_Open; + + procedure Ghdl_Text_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + is + Res : Ghdl_I32; + begin + Check_File_Mode (File, True); + + Res := File_Open (File, Mode, Str); + + if Res /= Open_Ok then + Error_C ("open: cannot open text file "); + Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1)); + Error_E; + end if; + end Ghdl_Text_File_Open; + + procedure Ghdl_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + is + Res : Ghdl_I32; + begin + Check_File_Mode (File, False); + + Res := File_Open (File, Mode, Str); + + if Res /= Open_Ok then + Error_C ("open: cannot open file "); + Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1)); + Error_E; + end if; + end Ghdl_File_Open; + + function Ghdl_Text_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32 + is + begin + Check_File_Mode (File, True); + return File_Open (File, Mode, Str); + end Ghdl_Text_File_Open_Status; + + function Ghdl_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32 + is + begin + Check_File_Mode (File, False); + return File_Open (File, Mode, Str); + end Ghdl_File_Open_Status; + + procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr) + is + Res : C_Files; + R : size_t; + R1 : int; + pragma Unreferenced (R, R1); + begin + Res := Get_File (File); + Check_File_Mode (File, True); + if Res = NULL_Stream then + Error ("write to a non-opened file"); + end if; + -- FIXME: check mode. + R := fwrite (Str.Base (0)'Address, + size_t (Str.Bounds.Dim_1.Length), 1, Res); + -- FIXME: check r + -- Write '\n'. + R1 := fputc (Character'Pos (Nl), Res); + if Auto_Flush then + fflush (Res); + end if; + end Ghdl_Text_Write; + + procedure Ghdl_Write_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type) + is + Res : C_Files; + R : size_t; + begin + Res := Get_File (File); + Check_File_Mode (File, False); + if Res = NULL_Stream then + Error ("write to a non-opened file"); + end if; + -- FIXME: check mode. + R := fwrite (System.Address (Ptr), size_t (Length), 1, Res); + if R /= 1 then + Error ("write_scalar failed"); + end if; + if Auto_Flush then + fflush (Res); + end if; + end Ghdl_Write_Scalar; + + procedure Ghdl_Read_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type) + is + Res : C_Files; + R : size_t; + begin + Res := Get_File (File); + Check_File_Mode (File, False); + if Res = NULL_Stream then + Error ("write to a non-opened file"); + end if; + -- FIXME: check mode. + R := fread (System.Address (Ptr), size_t (Length), 1, Res); + if R /= 1 then + Error ("read_scalar failed"); + end if; + end Ghdl_Read_Scalar; + + function Ghdl_Text_Read_Length (File : Ghdl_File_Index; + Str : Std_String_Ptr) + return Std_Integer + is + Stream : C_Files; + C : int; + Len : Ghdl_Index_Type; + begin + Stream := Get_File (File); + Check_File_Mode (File, True); + Len := Str.Bounds.Dim_1.Length; + -- Read until EOL (or EOF). + -- Store as much as possible. + for I in Ghdl_Index_Type loop + C := fgetc (Stream); + if C < 0 then + Error ("read: end of file reached"); + return Std_Integer (I); + end if; + if I < Len then + Str.Base (I) := Character'Val (C); + end if; + -- End of line is '\n' or LF or character # 10. + if C = 10 then + return Std_Integer (I + 1); + end if; + end loop; + return 0; + end Ghdl_Text_Read_Length; + + procedure Ghdl_Untruncated_Text_Read + (Res : Ghdl_Untruncated_Text_Read_Result_Acc; + File : Ghdl_File_Index; + Str : Std_String_Ptr) + is + Stream : C_Files; + Len : int; + Idx : Ghdl_Index_Type; + begin + Stream := Get_File (File); + Check_File_Mode (File, True); + Len := int (Str.Bounds.Dim_1.Length); + if fgets (Str.Base (0)'Address, Len, Stream) = Null_Address then + Internal_Error ("ghdl_untruncated_text_read: end of file"); + end if; + -- Compute the length. + for I in Ghdl_Index_Type loop + if Str.Base (I) = NUL then + Idx := I; + exit; + end if; + end loop; + Res.Len := Std_Integer (Idx); + end Ghdl_Untruncated_Text_Read; + + procedure File_Close (File : Ghdl_File_Index; Is_Text : Boolean) + is + Stream : C_Files; + begin + Stream := Get_File (File); + Check_File_Mode (File, Is_Text); + -- LRM 3.4.1 File Operations + -- If F is not associated with an external file, then FILE_CLOSE has + -- no effect. + if Stream = NULL_Stream then + return; + end if; + if fclose (Stream) /= 0 then + Internal_Error ("file_close: fclose error"); + end if; + Files_Table.Table (File).Stream := NULL_Stream; + end File_Close; + + procedure Ghdl_Text_File_Close (File : Ghdl_File_Index) is + begin + File_Close (File, True); + end Ghdl_Text_File_Close; + + procedure Ghdl_File_Close (File : Ghdl_File_Index) is + begin + File_Close (File, False); + end Ghdl_File_Close; + + procedure Ghdl_File_Flush (File : Ghdl_File_Index) + is + Stream : C_Files; + begin + Stream := Get_File (File); + if Stream = NULL_Stream then + return; + end if; + fflush (Stream); + end Ghdl_File_Flush; +end Grt.Files; + diff --git a/src/grt/grt-files.ads b/src/grt/grt-files.ads new file mode 100644 index 000000000..14f998468 --- /dev/null +++ b/src/grt/grt-files.ads @@ -0,0 +1,123 @@ +-- GHDL Run Time (GRT) - VHDL files subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Interfaces; + +package Grt.Files is + type Ghdl_File_Index is new Interfaces.Integer_32; + + -- File open mode. + Read_Mode : constant Ghdl_I32 := 0; + Write_Mode : constant Ghdl_I32 := 1; + Append_Mode : constant Ghdl_I32 := 2; + + -- file_open_status. + Open_Ok : constant Ghdl_I32 := 0; + Status_Error : constant Ghdl_I32 := 1; + Name_Error : constant Ghdl_I32 := 2; + Mode_Error : constant Ghdl_I32 := 3; + + -- General files. + function Ghdl_File_Endfile (File : Ghdl_File_Index) return Boolean; + + -- Elaboration. + function Ghdl_Text_File_Elaborate return Ghdl_File_Index; + function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index; + + -- Finalization. + procedure Ghdl_Text_File_Finalize (File : Ghdl_File_Index); + procedure Ghdl_File_Finalize (File : Ghdl_File_Index); + + -- Subprograms. + procedure Ghdl_Text_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr); + function Ghdl_Text_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32; + + procedure Ghdl_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr); + function Ghdl_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32; + + procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr); + procedure Ghdl_Write_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type); + + procedure Ghdl_Read_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type); + + function Ghdl_Text_Read_Length + (File : Ghdl_File_Index; Str : Std_String_Ptr) return Std_Integer; + + type Ghdl_Untruncated_Text_Read_Result is record + Len : Std_Integer; + end record; + + type Ghdl_Untruncated_Text_Read_Result_Acc is + access Ghdl_Untruncated_Text_Read_Result; + + procedure Ghdl_Untruncated_Text_Read + (Res : Ghdl_Untruncated_Text_Read_Result_Acc; + File : Ghdl_File_Index; + Str : Std_String_Ptr); + + procedure Ghdl_Text_File_Close (File : Ghdl_File_Index); + procedure Ghdl_File_Close (File : Ghdl_File_Index); + + procedure Ghdl_File_Flush (File : Ghdl_File_Index); +private + pragma Export (Ada, Ghdl_File_Endfile, "__ghdl_file_endfile"); + + pragma Export (C, Ghdl_Text_File_Elaborate, "__ghdl_text_file_elaborate"); + pragma Export (C, Ghdl_File_Elaborate, "__ghdl_file_elaborate"); + + pragma Export (C, Ghdl_Text_File_Finalize, "__ghdl_text_file_finalize"); + pragma Export (C, Ghdl_File_Finalize, "__ghdl_file_finalize"); + + pragma Export (C, Ghdl_Text_File_Open, "__ghdl_text_file_open"); + pragma Export (C, Ghdl_Text_File_Open_Status, + "__ghdl_text_file_open_status"); + + pragma Export (C, Ghdl_File_Open, "__ghdl_file_open"); + pragma Export (C, Ghdl_File_Open_Status, "__ghdl_file_open_status"); + + pragma Export (C, Ghdl_Text_Write, "__ghdl_text_write"); + pragma Export (C, Ghdl_Write_Scalar, "__ghdl_write_scalar"); + + pragma Export (C, Ghdl_Read_Scalar, "__ghdl_read_scalar"); + + pragma Export (C, Ghdl_Text_Read_Length, "__ghdl_text_read_length"); + pragma Export (C, Ghdl_Untruncated_Text_Read, + "std__textio__untruncated_text_read"); + + pragma Export (C, Ghdl_Text_File_Close, "__ghdl_text_file_close"); + pragma Export (C, Ghdl_File_Close, "__ghdl_file_close"); + + pragma Export (C, Ghdl_File_Flush, "__ghdl_file_flush"); +end Grt.Files; diff --git a/src/grt/grt-hooks.adb b/src/grt/grt-hooks.adb new file mode 100644 index 000000000..6a77aaf01 --- /dev/null +++ b/src/grt/grt-hooks.adb @@ -0,0 +1,161 @@ +-- GHDL Run Time (GRT) - Hooks. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package body Grt.Hooks is + type Hooks_Cell; + type Hooks_Cell_Acc is access Hooks_Cell; + type Hooks_Cell is record + Hooks : Hooks_Acc; + Next : Hooks_Cell_Acc; + end record; + + First_Hooks : Hooks_Cell_Acc := null; + Last_Hooks : Hooks_Cell_Acc := null; + + procedure Register_Hooks (Hooks : Hooks_Acc) + is + Cell : Hooks_Cell_Acc; + begin + Cell := new Hooks_Cell'(Hooks => Hooks, + Next => null); + if Last_Hooks = null then + First_Hooks := Cell; + else + Last_Hooks.Next := Cell; + end if; + Last_Hooks := Cell; + end Register_Hooks; + + type Hook_Cell; + type Hook_Cell_Acc is access Hook_Cell; + type Hook_Cell is record + Hook : Proc_Hook_Type; + Next : Hook_Cell_Acc; + end record; + + -- Chain of cycle hooks. + Cycle_Hook : Hook_Cell_Acc := null; + Last_Cycle_Hook : Hook_Cell_Acc := null; + + procedure Register_Cycle_Hook (Proc : Proc_Hook_Type) + is + Cell : Hook_Cell_Acc; + begin + Cell := new Hook_Cell'(Hook => Proc, + Next => null); + if Cycle_Hook = null then + Cycle_Hook := Cell; + else + Last_Cycle_Hook.Next := Cell; + end if; + Last_Cycle_Hook := Cell; + end Register_Cycle_Hook; + + procedure Call_Cycle_Hooks + is + Cell : Hook_Cell_Acc; + begin + Cell := Cycle_Hook; + while Cell /= null loop + Cell.Hook.all; + Cell := Cell.Next; + end loop; + end Call_Cycle_Hooks; + + function Call_Option_Hooks (Opt : String) return Boolean + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Option /= null + and then Cell.Hooks.Option.all (Opt) + then + return True; + end if; + Cell := Cell.Next; + end loop; + return False; + end Call_Option_Hooks; + + procedure Call_Help_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Help /= null then + Cell.Hooks.Help.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Help_Hooks; + + procedure Call_Init_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Init /= null then + Cell.Hooks.Init.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Init_Hooks; + + procedure Call_Start_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Start /= null then + Cell.Hooks.Start.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Start_Hooks; + + procedure Call_Finish_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Finish /= null then + Cell.Hooks.Finish.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Finish_Hooks; + + procedure Proc_Hook_Nil is + begin + null; + end Proc_Hook_Nil; +end Grt.Hooks; + + diff --git a/src/grt/grt-hooks.ads b/src/grt/grt-hooks.ads new file mode 100644 index 000000000..20846c7f8 --- /dev/null +++ b/src/grt/grt-hooks.ads @@ -0,0 +1,70 @@ +-- GHDL Run Time (GRT) - Hooks. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +package Grt.Hooks is + pragma Preelaborate (Grt.Hooks); + + type Option_Hook_Type is access function (Opt : String) return Boolean; + type Proc_Hook_Type is access procedure; + + type Hooks_Type is record + -- Called for every unknown command line argument. + -- Return TRUE if handled. + Option : Option_Hook_Type; + + -- Display command line help. + Help : Proc_Hook_Type; + + -- Called at initialization (after decoding options). + Init : Proc_Hook_Type; + + -- Called just after elaboration. + Start : Proc_Hook_Type; + + -- Called at the end of execution. + Finish : Proc_Hook_Type; + end record; + + type Hooks_Acc is access constant Hooks_Type; + + -- Registers hook. + procedure Register_Hooks (Hooks : Hooks_Acc); + + -- Register an hook which will call PROC after every non-delta cycles. + procedure Register_Cycle_Hook (Proc : Proc_Hook_Type); + + -- Call hooks. + function Call_Option_Hooks (Opt : String) return Boolean; + procedure Call_Help_Hooks; + procedure Call_Init_Hooks; + procedure Call_Start_Hooks; + procedure Call_Finish_Hooks; + + -- Call non-delta cycles hooks. + procedure Call_Cycle_Hooks; + pragma Inline_Always (Call_Cycle_Hooks); + + -- Nil procedure. + procedure Proc_Hook_Nil; +end Grt.Hooks; diff --git a/src/grt/grt-images.adb b/src/grt/grt-images.adb new file mode 100644 index 000000000..342c98f2a --- /dev/null +++ b/src/grt/grt-images.adb @@ -0,0 +1,387 @@ +-- GHDL Run Time (GRT) - 'image subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Ada.Unchecked_Conversion; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; +with Grt.Processes; use Grt.Processes; +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Errors; use Grt.Errors; + +package body Grt.Images is + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Basep); + + function To_Std_String_Boundp is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Boundp); + + procedure Set_String_Bounds (Res : Std_String_Ptr; Len : Ghdl_Index_Type) + is + begin + Res.Bounds := To_Std_String_Boundp + (Ghdl_Stack2_Allocate (Std_String_Bound'Size / System.Storage_Unit)); + Res.Bounds.Dim_1 := (Left => 1, + Right => Std_Integer (Len), + Dir => Dir_To, + Length => Len); + end Set_String_Bounds; + + procedure Return_String (Res : Std_String_Ptr; Str : String) + is + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Str'Length)); + for I in 0 .. Str'Length - 1 loop + Res.Base (Ghdl_Index_Type (I)) := Str (Str'First + I); + end loop; + Set_String_Bounds (Res, Str'Length); + end Return_String; + + procedure Return_Enum + (Res : Std_String_Ptr; Rti : Ghdl_Rti_Access; Index : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + Str : Ghdl_C_String; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str := Enum_Rti.Names (Index); + Return_String (Res, Str (1 .. strlen (Str))); + end Return_Enum; + + procedure Ghdl_Image_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access) + is + begin + Return_Enum (Res, Rti, Ghdl_B1'Pos (Val)); + end Ghdl_Image_B1; + + procedure Ghdl_Image_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access) + is + begin + Return_Enum (Res, Rti, Ghdl_E8'Pos (Val)); + end Ghdl_Image_E8; + + procedure Ghdl_Image_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access) + is + begin + Return_Enum (Res, Rti, Ghdl_E32'Pos (Val)); + end Ghdl_Image_E32; + + procedure Ghdl_Image_I32 (Res : Std_String_Ptr; Val : Ghdl_I32) + is + Str : String (1 .. 11); + First : Natural; + begin + To_String (Str, First, Val); + Return_String (Res, Str (First .. Str'Last)); + end Ghdl_Image_I32; + + procedure Ghdl_Image_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access) + is + Str : String (1 .. 21); + First : Natural; + Phys : constant Ghdl_Rtin_Type_Physical_Acc + := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Unit_Len : Natural; + begin + To_String (Str, First, Val); + Unit_Name := Get_Physical_Unit_Name (Phys.Units (0)); + Unit_Len := strlen (Unit_Name); + declare + L : constant Natural := Str'Last + 1 - First; + Str2 : String (1 .. L + 1 + Unit_Len); + begin + Str2 (1 .. L) := Str (First .. Str'Last); + Str2 (L + 1) := ' '; + Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len); + Return_String (Res, Str2); + end; + end Ghdl_Image_P64; + + procedure Ghdl_Image_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access) + is + Str : String (1 .. 11); + First : Natural; + Phys : constant Ghdl_Rtin_Type_Physical_Acc + := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Unit_Len : Natural; + begin + To_String (Str, First, Val); + Unit_Name := Get_Physical_Unit_Name (Phys.Units (0)); + Unit_Len := strlen (Unit_Name); + declare + L : constant Natural := Str'Last + 1 - First; + Str2 : String (1 .. L + 1 + Unit_Len); + begin + Str2 (1 .. L) := Str (First .. Str'Last); + Str2 (L + 1) := ' '; + Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len); + Return_String (Res, Str2); + end; + end Ghdl_Image_P32; + + procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) + is + Str : String (1 .. 24); + P : Natural; + begin + To_String (Str, P, Val); + Return_String (Res, Str (1 .. P)); + end Ghdl_Image_F64; + + procedure Ghdl_To_String_I32 (Res : Std_String_Ptr; Val : Ghdl_I32) + renames Ghdl_Image_I32; + procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) + renames Ghdl_Image_F64; + + procedure Ghdl_To_String_F64_Digits + (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32) + is + Str : String_Real_Digits; + P : Natural; + begin + To_String (Str, P, Val, Nbr_Digits); + Return_String (Res, Str (1 .. P)); + end Ghdl_To_String_F64_Digits; + + procedure Ghdl_To_String_F64_Format + (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr) + is + C_Format : String (1 .. Positive (Format.Bounds.Dim_1.Length + 1)); + Str : Grt.Vstrings.String_Real_Format; + P : Natural; + begin + for I in 1 .. C_Format'Last - 1 loop + C_Format (I) := Format.Base (Ghdl_Index_Type (I - 1)); + end loop; + C_Format (C_Format'Last) := NUL; + + To_String (Str, P, Val, To_Ghdl_C_String (C_Format'Address)); + Return_String (Res, Str (1 .. P)); + end Ghdl_To_String_F64_Format; + + subtype Log_Base_Type is Ghdl_Index_Type range 3 .. 4; + Hex_Chars : constant array (Natural range 0 .. 15) of Character := + "0123456789ABCDEF"; + + procedure Ghdl_BV_To_String (Res : Std_String_Ptr; + Val : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type; + Log_Base : Log_Base_Type) + is + Res_Len : constant Ghdl_Index_Type := (Len + Log_Base - 1) / Log_Base; + Pos : Ghdl_Index_Type; + V : Natural; + Sh : Natural range 0 .. 4; + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Res_Len)); + V := 0; + Sh := 0; + Pos := Res_Len - 1; + for I in reverse 1 .. Len loop + V := V + Std_Bit'Pos (Val (I - 1)) * (2 ** Sh); + Sh := Sh + 1; + if Sh = Natural (Log_Base) or else I = 1 then + Res.Base (Pos) := Hex_Chars (V); + Pos := Pos - 1; + Sh := 0; + V := 0; + end if; + end loop; + Set_String_Bounds (Res, Res_Len); + end Ghdl_BV_To_String; + + procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type) is + begin + Ghdl_BV_To_String (Res, Base, Len, 3); + end Ghdl_BV_To_Ostring; + + procedure Ghdl_BV_To_Hstring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type) is + begin + Ghdl_BV_To_String (Res, Base, Len, 4); + end Ghdl_BV_To_Hstring; + + procedure To_String_Enum + (Res : Std_String_Ptr; Rti : Ghdl_Rti_Access; Index : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + Str : Ghdl_C_String; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str := Enum_Rti.Names (Index); + if Str (1) = ''' then + Return_String (Res, Str (2 .. 2)); + else + Return_String (Res, Str (1 .. strlen (Str))); + end if; + end To_String_Enum; + + procedure Ghdl_To_String_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_B1'Pos (Val)); + end Ghdl_To_String_B1; + + procedure Ghdl_To_String_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_E8'Pos (Val)); + end Ghdl_To_String_E8; + + procedure Ghdl_To_String_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_E32'Pos (Val)); + end Ghdl_To_String_E32; + + procedure Ghdl_To_String_Char (Res : Std_String_Ptr; Val : Std_Character) is + begin + Return_String (Res, (1 => Val)); + end Ghdl_To_String_Char; + + procedure Ghdl_To_String_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access) + renames Ghdl_Image_P32; + + procedure Ghdl_To_String_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access) + renames Ghdl_Image_P64; + + procedure Ghdl_Time_To_String_Unit + (Res : Std_String_Ptr; + Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access) + is + Str : Grt.Vstrings.String_Time_Unit; + First : Natural; + Phys : constant Ghdl_Rtin_Type_Physical_Acc + := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Unit_Len : Natural; + begin + Unit_Name := null; + for I in 1 .. Phys.Nbr loop + if Get_Physical_Unit_Value (Phys.Units (I - 1), Rti) = Ghdl_I64 (Unit) + then + Unit_Name := Get_Physical_Unit_Name (Phys.Units (I - 1)); + exit; + end if; + end loop; + if Unit_Name = null then + Error ("no unit for to_string"); + end if; + Grt.Vstrings.To_String (Str, First, Ghdl_I64 (Val), Ghdl_I64 (Unit)); + Unit_Len := strlen (Unit_Name); + declare + L : constant Natural := Str'Last + 1 - First; + Str2 : String (1 .. L + 1 + Unit_Len); + begin + Str2 (1 .. L) := Str (First .. Str'Last); + Str2 (L + 1) := ' '; + Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len); + Return_String (Res, Str2); + end; + end Ghdl_Time_To_String_Unit; + + procedure Ghdl_Array_Char_To_String_B1 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_B1_Array_Base_Ptr := To_Ghdl_B1_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_B1'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_B1; + + procedure Ghdl_Array_Char_To_String_E8 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_E8_Array_Base_Ptr := To_Ghdl_E8_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_E8'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_E8; + + procedure Ghdl_Array_Char_To_String_E32 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_E32_Array_Base_Ptr := + To_Ghdl_E32_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_E32'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_E32; + +-- procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) +-- is +-- -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1) +-- -- + exp_digits (4) -> 24. +-- Str : String (1 .. 25); + +-- procedure Snprintf_G (Str : System.Address; +-- Size : Integer; +-- Arg : Ghdl_F64); +-- pragma Import (C, Snprintf_G, "__ghdl_snprintf_g"); + +-- function strlen (Str : System.Address) return Integer; +-- pragma Import (C, strlen); +-- begin +-- Snprintf_G (Str'Address, Str'Length, Val); +-- Return_String (Res, Str (1 .. strlen (Str'Address))); +-- end Ghdl_Image_F64; + +end Grt.Images; diff --git a/src/grt/grt-images.ads b/src/grt/grt-images.ads new file mode 100644 index 000000000..cd8911091 --- /dev/null +++ b/src/grt/grt-images.ads @@ -0,0 +1,110 @@ +-- GHDL Run Time (GRT) - 'image subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Images is + -- For all images procedures, the result is allocated on the secondary + -- stack. + + procedure Ghdl_Image_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_I32 (Res : Std_String_Ptr; Val : Ghdl_I32); + procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64); + procedure Ghdl_Image_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access); + + procedure Ghdl_To_String_I32 (Res : Std_String_Ptr; Val : Ghdl_I32); + procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64); + procedure Ghdl_To_String_F64_Digits + (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32); + procedure Ghdl_To_String_F64_Format + (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr); + procedure Ghdl_To_String_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_Char + (Res : Std_String_Ptr; Val : Std_Character); + procedure Ghdl_To_String_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access); + procedure Ghdl_Time_To_String_Unit + (Res : Std_String_Ptr; + Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_B1 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_E8 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_E32 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + + procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type); + procedure Ghdl_BV_To_Hstring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type); +private + pragma Export (Ada, Ghdl_Image_B1, "__ghdl_image_b1"); + pragma Export (C, Ghdl_Image_E8, "__ghdl_image_e8"); + pragma Export (C, Ghdl_Image_E32, "__ghdl_image_e32"); + pragma Export (C, Ghdl_Image_I32, "__ghdl_image_i32"); + pragma Export (C, Ghdl_Image_F64, "__ghdl_image_f64"); + pragma Export (C, Ghdl_Image_P64, "__ghdl_image_p64"); + pragma Export (C, Ghdl_Image_P32, "__ghdl_image_p32"); + + pragma Export (C, Ghdl_To_String_I32, "__ghdl_to_string_i32"); + pragma Export (C, Ghdl_To_String_F64, "__ghdl_to_string_f64"); + pragma Export (C, Ghdl_To_String_F64_Digits, "__ghdl_to_string_f64_digits"); + pragma Export (C, Ghdl_To_String_F64_Format, "__ghdl_to_string_f64_format"); + pragma Export (Ada, Ghdl_To_String_B1, "__ghdl_to_string_b1"); + pragma Export (C, Ghdl_To_String_E8, "__ghdl_to_string_e8"); + pragma Export (C, Ghdl_To_String_E32, "__ghdl_to_string_e32"); + pragma Export (C, Ghdl_To_String_Char, "__ghdl_to_string_char"); + pragma Export (C, Ghdl_To_String_P32, "__ghdl_to_string_p32"); + pragma Export (C, Ghdl_To_String_P64, "__ghdl_to_string_p64"); + pragma Export (C, Ghdl_Time_To_String_Unit, "__ghdl_time_to_string_unit"); + pragma Export (C, Ghdl_Array_Char_To_String_B1, + "__ghdl_array_char_to_string_b1"); + pragma Export (C, Ghdl_Array_Char_To_String_E8, + "__ghdl_array_char_to_string_e8"); + pragma Export (C, Ghdl_Array_Char_To_String_E32, + "__ghdl_array_char_to_string_e32"); + pragma Export (C, Ghdl_BV_To_Ostring, "__ghdl_bv_to_ostring"); + pragma Export (C, Ghdl_BV_To_Hstring, "__ghdl_bv_to_hstring"); +end Grt.Images; diff --git a/src/grt/grt-lib.adb b/src/grt/grt-lib.adb new file mode 100644 index 000000000..d2b095c67 --- /dev/null +++ b/src/grt/grt-lib.adb @@ -0,0 +1,298 @@ +-- GHDL Run Time (GRT) - misc subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; +with Grt.Options; + +package body Grt.Lib is + --procedure Memcpy (Dst : Address; Src : Address; Size : Size_T); + --pragma Import (C, Memcpy); + + procedure Ghdl_Memcpy + (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type) + is + procedure Memmove + (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type); + pragma Import (C, Memmove); + begin + Memmove (Dest, Src, Size); + end Ghdl_Memcpy; + + procedure Do_Report (Msg : String; + Str : Std_String_Ptr; + Default_Str : String; + Severity : Integer; + Loc : Ghdl_Location_Ptr) + is + Level : constant Integer := Severity mod 256; + begin + Report_H; + Report_C (Loc.Filename); + Report_C (":"); + Report_C (Loc.Line); + Report_C (":"); + Report_C (Loc.Col); + Report_C (":@"); + Report_Now_C; + Report_C (":("); + Report_C (Msg); + Report_C (" "); + case Level is + when Note_Severity => + Report_C ("note"); + when Warning_Severity => + Report_C ("warning"); + when Error_Severity => + Report_C ("error"); + when Failure_Severity => + Report_C ("failure"); + when others => + Report_C ("???"); + end case; + Report_C ("): "); + if Str /= null then + Report_E (Str); + else + Report_E (Default_Str); + end if; + if Level >= Grt.Options.Severity_Level then + Error_C (Msg); + Error_E (" failed"); + end if; + end Do_Report; + + procedure Ghdl_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) + is + begin + Do_Report ("assertion", Str, "Assertion violation", Severity, Loc); + end Ghdl_Assert_Failed; + + procedure Ghdl_Ieee_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) + is + use Grt.Options; + begin + if Ieee_Asserts = Disable_Asserts + or else (Ieee_Asserts = Disable_Asserts_At_Time_0 and Current_Time = 0) + then + return; + else + Do_Report ("assertion", Str, "Assertion violation", Severity, Loc); + end if; + end Ghdl_Ieee_Assert_Failed; + + procedure Ghdl_Psl_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is + begin + Do_Report ("psl assertion", Str, "Assertion violation", Severity, Loc); + end Ghdl_Psl_Assert_Failed; + + procedure Ghdl_Psl_Cover + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is + begin + Do_Report ("psl cover", Str, "sequence covered", Severity, Loc); + end Ghdl_Psl_Cover; + + procedure Ghdl_Psl_Cover_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is + begin + Do_Report ("psl cover failure", + Str, "sequence not covered", Severity, Loc); + end Ghdl_Psl_Cover_Failed; + + procedure Ghdl_Report + (Str : Std_String_Ptr; + Severity : Integer; + Loc : Ghdl_Location_Ptr) + is + begin + Do_Report ("report", Str, "Assertion violation", Severity, Loc); + end Ghdl_Report; + + procedure Ghdl_Program_Error (Filename : Ghdl_C_String; + Line : Ghdl_I32; + Code : Ghdl_Index_Type) + is + begin + case Code is + when 1 => + Error_C ("missing return in function"); + when 2 => + Error_C ("block already configured"); + when 3 => + Error_C ("bad configuration"); + when others => + Error_C ("unknown error code "); + Error_C (Integer (Code)); + end case; + Error_C (" at "); + if Filename = null then + Error_C ("*unknown*"); + else + Error_C (Filename); + end if; + Error_C (":"); + Error_C (Integer(Line)); + Error_E (""); + end Ghdl_Program_Error; + + procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String; + Line: Ghdl_I32) + is + begin + Error_C ("bound check failure at "); + Error_C (Filename); + Error_C (":"); + Error_C (Integer (Line)); + Error_E (""); + end Ghdl_Bound_Check_Failed_L1; + + function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32) + return Ghdl_I32 + is + pragma Suppress (Overflow_Check); + + R : Ghdl_I32; + Res : Ghdl_I32; + P : Ghdl_I32; + T : Ghdl_I64; + begin + if E < 0 then + Error ("negative exponent"); + end if; + Res := 1; + P := V; + R := E; + loop + if R mod 2 = 1 then + T := Ghdl_I64 (Res) * Ghdl_I64 (P); + Res := Ghdl_I32 (T); + if Ghdl_I64 (Res) /= T then + Error ("overflow in exponentiation"); + end if; + end if; + R := R / 2; + exit when R = 0; + P := P * P; + end loop; + return Res; + end Ghdl_Integer_Exp; + + function C_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr; + pragma Import (C, C_Malloc, "malloc"); + + function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr is + begin + return C_Malloc (Size); + end Ghdl_Malloc; + + function Ghdl_Malloc0 (Size : Ghdl_Index_Type) return Ghdl_Ptr + is + procedure Memset (Ptr : Ghdl_Ptr; C : Integer; Size : Ghdl_Index_Type); + pragma Import (C, Memset); + + Res : Ghdl_Ptr; + begin + Res := C_Malloc (Size); + Memset (Res, 0, Size); + return Res; + end Ghdl_Malloc0; + + procedure Ghdl_Deallocate (Ptr : Ghdl_Ptr) + is + procedure C_Free (Ptr : Ghdl_Ptr); + pragma Import (C, C_Free, "free"); + begin + C_Free (Ptr); + end Ghdl_Deallocate; + + function Ghdl_Real_Exp (X : Ghdl_Real; Exp : Ghdl_I32) + return Ghdl_Real + is + R : Ghdl_I32; + Res : Ghdl_Real; + P : Ghdl_Real; + begin + Res := 1.0; + P := X; + R := Exp; + if R >= 0 then + loop + if R mod 2 = 1 then + Res := Res * P; + end if; + R := R / 2; + exit when R = 0; + P := P * P; + end loop; + return Res; + else + R := -R; + loop + if R mod 2 = 1 then + Res := Res * P; + end if; + R := R / 2; + exit when R = 0; + P := P * P; + end loop; + if Res = 0.0 then + Error ("division per 0.0"); + return 0.0; + end if; + return 1.0 / Res; + end if; + end Ghdl_Real_Exp; + + function Ghdl_Get_Resolution_Limit return Std_Time is + begin + return 1; + end Ghdl_Get_Resolution_Limit; + + procedure Ghdl_Control_Simulation + (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer) is + begin + Report_H; + -- Report_C (Grt.Options.Progname); + Report_C ("simulation "); + if Stop then + Report_C ("stopped"); + else + Report_C ("finished"); + end if; + Report_C (" @"); + Report_Now_C; + if Has_Status then + Report_C (" with status "); + Report_C (Integer (Status)); + end if; + Report_E (""); + if Has_Status then + Exit_Status := Integer (Status); + end if; + Exit_Simulation; + end Ghdl_Control_Simulation; + +end Grt.Lib; diff --git a/src/grt/grt-lib.ads b/src/grt/grt-lib.ads new file mode 100644 index 000000000..4dac2c8d2 --- /dev/null +++ b/src/grt/grt-lib.ads @@ -0,0 +1,127 @@ +-- GHDL Run Time (GRT) - misc subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Lib is + pragma Preelaborate (Grt.Lib); + + procedure Ghdl_Memcpy + (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type); + + procedure Ghdl_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + procedure Ghdl_Ieee_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + procedure Ghdl_Psl_Assert_Failed + (Str : Std_String_Ptr; + Severity : Integer; + Loc : Ghdl_Location_Ptr); + + -- Called when a sequence is covered (in a cover directive) + procedure Ghdl_Psl_Cover + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + procedure Ghdl_Psl_Cover_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + procedure Ghdl_Report + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + Note_Severity : constant Integer := 0; + Warning_Severity : constant Integer := 1; + Error_Severity : constant Integer := 2; + Failure_Severity : constant Integer := 3; + + procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String; + Line: Ghdl_I32); + + -- Program error has occured: + -- * configuration of an already configured block. + procedure Ghdl_Program_Error (Filename : Ghdl_C_String; + Line : Ghdl_I32; + Code : Ghdl_Index_Type); + + function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32) + return Ghdl_I32; + + function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr; + + -- Allocate and clear SIZE bytes. + function Ghdl_Malloc0 (Size : Ghdl_Index_Type) return Ghdl_Ptr; + + procedure Ghdl_Deallocate (Ptr : Ghdl_Ptr); + + function Ghdl_Real_Exp (X : Ghdl_Real; Exp : Ghdl_I32) + return Ghdl_Real; + + type Ghdl_Std_Ulogic_Boolean_Array_Type is array (Ghdl_E8 range 0 .. 8) + of Ghdl_B1; + + Ghdl_Std_Ulogic_To_Boolean_Array : + constant Ghdl_Std_Ulogic_Boolean_Array_Type := (False, -- U + False, -- X + False, -- 0 + True, -- 1 + False, -- Z + False, -- W + False, -- L + True, -- H + False -- - + ); + + function Ghdl_Get_Resolution_Limit return Std_Time; + procedure Ghdl_Control_Simulation + (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer); +private + pragma Export (C, Ghdl_Memcpy, "__ghdl_memcpy"); + + pragma Export (C, Ghdl_Assert_Failed, "__ghdl_assert_failed"); + pragma Export (C, Ghdl_Ieee_Assert_Failed, "__ghdl_ieee_assert_failed"); + pragma Export (C, Ghdl_Psl_Assert_Failed, "__ghdl_psl_assert_failed"); + pragma Export (C, Ghdl_Psl_Cover, "__ghdl_psl_cover"); + pragma Export (C, Ghdl_Psl_Cover_Failed, "__ghdl_psl_cover_failed"); + pragma Export (C, Ghdl_Report, "__ghdl_report"); + + pragma Export (C, Ghdl_Bound_Check_Failed_L1, + "__ghdl_bound_check_failed_l1"); + pragma Export (C, Ghdl_Program_Error, "__ghdl_program_error"); + + pragma Export (C, Ghdl_Malloc, "__ghdl_malloc"); + pragma Export (C, Ghdl_Malloc0, "__ghdl_malloc0"); + pragma Export (C, Ghdl_Deallocate, "__ghdl_deallocate"); + + pragma Export (C, Ghdl_Integer_Exp, "__ghdl_integer_exp"); + pragma Export (C, Ghdl_Real_Exp, "__ghdl_real_exp"); + + pragma Export (C, Ghdl_Std_Ulogic_To_Boolean_Array, + "__ghdl_std_ulogic_to_boolean_array"); + + pragma Export (C, Ghdl_Get_Resolution_Limit, + "__ghdl_get_resolution_limit"); + pragma Export (Ada, Ghdl_Control_Simulation, + "__ghdl_control_simulation"); +end Grt.Lib; diff --git a/src/grt/grt-main.adb b/src/grt/grt-main.adb new file mode 100644 index 000000000..116ea7b2e --- /dev/null +++ b/src/grt/grt-main.adb @@ -0,0 +1,190 @@ +-- GHDL Run Time (GRT) - entry point. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Types; use Grt.Types; +with Grt.Errors; +with Grt.Stacks; +with Grt.Processes; +with Grt.Signals; +with Grt.Options; use Grt.Options; +with Grt.Stats; +with Grt.Hooks; +with Grt.Disp_Signals; +with Grt.Disp; +with Grt.Modules; + +-- The following packages are not referenced in this package. +-- These are subprograms called only from GHDL generated code. +-- They are with'ed in order to be present in the binary. +pragma Warnings (Off); +with Grt.Files; +with Grt.Types; +with Grt.Lib; +with Grt.Shadow_Ieee; +with Grt.Images; +with Grt.Values; +with Grt.Names; +pragma Warnings (On); + +package body Grt.Main is + procedure Ghdl_Elaborate; + pragma Import (C, Ghdl_Elaborate, "__ghdl_ELABORATE"); + + -- Wrapper around elaboration just to return 0. + function Ghdl_Elaborate_Wrapper return Integer is + begin + Ghdl_Elaborate; + return 0; + end Ghdl_Elaborate_Wrapper; + + procedure Disp_Stats_Hook (Code : Integer); + pragma Convention (C, Disp_Stats_Hook); + + procedure Disp_Stats_Hook (Code : Integer) + is + pragma Unreferenced (Code); + begin + Stats.End_Simulation; + Stats.Disp_Stats; + end Disp_Stats_Hook; + + procedure Check_Flag_String + is + Err : Boolean; + begin + -- The conditions may be statically known. + pragma Warnings (Off); + + Err := False; + if (Std_Integer'Size = 32 and Flag_String (3) /= 'i') + or else (Std_Integer'Size = 64 and Flag_String (3) /= 'I') + then + Err := True; + end if; + if (Std_Time'Size = 32 and Flag_String (4) /= 't') + or else (Std_Time'Size = 64 and Flag_String (4) /= 'T') + then + Err := True; + end if; + + pragma Warnings (On); + + if Err then + Grt.Errors.Error + ("GRT is not consistent with the flags used for your design"); + end if; + end Check_Flag_String; + + procedure Run + is + use Grt.Errors; + Stop : Boolean; + Status : Integer; + begin + -- Register modules. + -- They may insert hooks. + Grt.Modules.Register_Modules; + + -- If the time resolution is to be set by the user, select a default + -- resolution. Options may override it. + if Flag_String (5) = '?' then + Set_Time_Resolution ('n'); + end if; + + -- Decode options. + Grt.Options.Decode (Stop); + + -- Check coherency between GRT and GHDL generated code. + Check_Flag_String; + + -- Early stop (for options such as --help). + if Stop then + return; + end if; + + -- Internal initializations. + Grt.Stacks.Stack_Init; + + Grt.Hooks.Call_Init_Hooks; + + Grt.Processes.Init; + + Grt.Signals.Init; + + if Flag_Stats then + Stats.Start_Elaboration; + end if; + + -- Elaboration. Run through longjump to catch errors. + if Grt.Processes.Run_Through_Longjump (Ghdl_Elaborate_Wrapper'Access) < 0 + then + Grt.Errors.Error ("error during elaboration"); + return; + end if; + + if Flag_Stats then + Stats.Start_Order; + end if; + + Grt.Hooks.Call_Start_Hooks; + + if not Flag_No_Run then + Grt.Signals.Order_All_Signals; + + if Grt.Options.Disp_Signals_Map then + Grt.Disp_Signals.Disp_Signals_Map; + end if; + if Grt.Options.Disp_Signals_Table then + Grt.Disp_Signals.Disp_Signals_Table; + end if; + if Disp_Signals_Order then + Grt.Disp.Disp_Signals_Order; + end if; + if Disp_Sensitivity then + Grt.Disp_Signals.Disp_All_Sensitivity; + end if; + + -- Do the simulation. + Status := Grt.Processes.Simulation; + end if; + + if Flag_Stats then + Disp_Stats_Hook (0); + end if; + + if Expect_Failure then + if Status >= 0 then + Expect_Failure := False; + Error ("error expected, but none occured"); + end if; + else + if Status < 0 then + Error ("simulation failed"); + end if; + end if; + end Run; + +end Grt.Main; diff --git a/src/grt/grt-main.ads b/src/grt/grt-main.ads new file mode 100644 index 000000000..4f78477f2 --- /dev/null +++ b/src/grt/grt-main.ads @@ -0,0 +1,29 @@ +-- GHDL Run Time (GRT) - entry point. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package Grt.Main is + -- Elaborate and simulate the design. + procedure Run; +end Grt.Main; diff --git a/src/grt/grt-modules.adb b/src/grt/grt-modules.adb new file mode 100644 index 000000000..e5304f04d --- /dev/null +++ b/src/grt/grt-modules.adb @@ -0,0 +1,47 @@ +-- GHDL Run Time (GRT) - Modules. +-- Copyright (C) 2005 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Vcd; +with Grt.Vcdz; +with Grt.Vpi; +with Grt.Waves; +with Grt.Vital_Annotate; +with Grt.Disp_Tree; +with Grt.Disp_Rti; + +package body Grt.Modules is + procedure Register_Modules is + begin + -- List of modules to be registered. + Grt.Disp_Tree.Register; + Grt.Vcd.Register; + Grt.Vcdz.Register; + Grt.Waves.Register; + Grt.Vpi.Register; + Grt.Vital_Annotate.Register; + Grt.Disp_Rti.Register; + end Register_Modules; +end Grt.Modules; diff --git a/src/grt/grt-modules.ads b/src/grt/grt-modules.ads new file mode 100644 index 000000000..23c7d6e7a --- /dev/null +++ b/src/grt/grt-modules.ads @@ -0,0 +1,29 @@ +-- GHDL Run Time (GRT) - Modules. +-- Copyright (C) 2005 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package Grt.Modules is + -- Register optional modules. + procedure Register_Modules; +end Grt.Modules; diff --git a/src/grt/grt-names.adb b/src/grt/grt-names.adb new file mode 100644 index 000000000..e7928f75c --- /dev/null +++ b/src/grt/grt-names.adb @@ -0,0 +1,105 @@ +-- GHDL Run Time (GRT) - 'name* subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +--with Grt.Errors; use Grt.Errors; +with Ada.Unchecked_Conversion; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Processes; use Grt.Processes; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; +with Grt.Vstrings; use Grt.Vstrings; + +package body Grt.Names is + function To_Str_String_Boundp is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Boundp); + + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => String_Ptr, Target => Std_String_Basep); + + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Basep); + + procedure Get_Name (Res : Std_String_Ptr; + Ctxt : Rti_Context; + Name : Ghdl_Str_Len_Ptr; + Is_Path : Boolean) + is + procedure Memcpy (Dst : Address; Src : Address; Len : Integer); + pragma Import (C, Memcpy); + + Bounds : Std_String_Boundp; + Len : Natural; + + Rstr : Rstring; + R_Len : Natural; + begin + if Ctxt.Block /= null then + Prepend (Rstr, ':'); + Get_Path_Name (Rstr, Ctxt, ':', not Is_Path); + R_Len := Length (Rstr); + Len := R_Len + Name.Len; + else + Len := Name.Len; + end if; + + Bounds := To_Str_String_Boundp + (Ghdl_Stack2_Allocate (Std_String_Bound'Size / System.Storage_Unit)); + Bounds.Dim_1.Left := 1; + Bounds.Dim_1.Right := Ghdl_I32 (Len); + Bounds.Dim_1.Dir := Dir_To; + Bounds.Dim_1.Length := Ghdl_Index_Type (Len); + Res.Bounds := Bounds; + if Ctxt.Block /= null then + Res.Base := To_Std_String_Basep + (Ghdl_Stack2_Allocate (Ghdl_Index_Type (Len))); + Memcpy (Res.Base (0)'Address, Get_Address (Rstr), R_Len); + Memcpy (Res.Base (Ghdl_Index_Type (R_Len))'Address, + Name.Str (1)'Address, + Name.Len); + Free (Rstr); + else + Res.Base := To_Std_String_Basep (Name.Str); + end if; + end Get_Name; + + procedure Ghdl_Get_Path_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr) + is + begin + Get_Name (Res, (Base, Ctxt), Name, True); + end Ghdl_Get_Path_Name; + + procedure Ghdl_Get_Instance_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr) + is + begin + Get_Name (Res, (Base, Ctxt), Name, False); + end Ghdl_Get_Instance_Name; + +end Grt.Names; diff --git a/src/grt/grt-names.ads b/src/grt/grt-names.ads new file mode 100644 index 000000000..e0c284231 --- /dev/null +++ b/src/grt/grt-names.ads @@ -0,0 +1,42 @@ +-- GHDL Run Time (GRT) - 'name* subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Names is + procedure Ghdl_Get_Path_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr); + + procedure Ghdl_Get_Instance_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr); +private + pragma Export (C, Ghdl_Get_Path_Name, "__ghdl_get_path_name"); + pragma Export (C, Ghdl_Get_Instance_Name, "__ghdl_get_instance_name"); +end Grt.Names; diff --git a/src/grt/grt-options.adb b/src/grt/grt-options.adb new file mode 100644 index 000000000..df1eb4ec8 --- /dev/null +++ b/src/grt/grt-options.adb @@ -0,0 +1,507 @@ +-- GHDL Run Time (GRT) - command line options. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Interfaces; use Interfaces; +with Grt.Errors; use Grt.Errors; +with Grt.Astdio; +with Grt.Hooks; + +package body Grt.Options is + + Std_Standard_Time_Fs : Std_Time; + Std_Standard_Time_Ps : Std_Time; + Std_Standard_Time_Ns : Std_Time; + Std_Standard_Time_Us : Std_Time; + Std_Standard_Time_Ms : Std_Time; + Std_Standard_Time_Sec : Std_Time; + Std_Standard_Time_Min : Std_Time; + Std_Standard_Time_Hr : Std_Time; + pragma Export (C, Std_Standard_Time_Fs, "std__standard__time__BT__fs"); + pragma Weak_External (Std_Standard_Time_Fs); + pragma Export (C, Std_Standard_Time_Ps, "std__standard__time__BT__ps"); + pragma Weak_External (Std_Standard_Time_Ps); + pragma Export (C, Std_Standard_Time_Ns, "std__standard__time__BT__ns"); + pragma Weak_External (Std_Standard_Time_Ns); + pragma Export (C, Std_Standard_Time_Us, "std__standard__time__BT__us"); + pragma Weak_External (Std_Standard_Time_Us); + pragma Export (C, Std_Standard_Time_Ms, "std__standard__time__BT__ms"); + pragma Weak_External (Std_Standard_Time_Ms); + pragma Export (C, Std_Standard_Time_Sec, "std__standard__time__BT__sec"); + pragma Weak_External (Std_Standard_Time_Sec); + pragma Export (C, Std_Standard_Time_Min, "std__standard__time__BT__min"); + pragma Weak_External (Std_Standard_Time_Min); + pragma Export (C, Std_Standard_Time_Hr, "std__standard__time__BT__hr"); + pragma Weak_External (Std_Standard_Time_Hr); + + procedure Set_Time_Resolution (Res : Character) + is + begin + Std_Standard_Time_Hr := 0; + case Res is + when 'f' => + Std_Standard_Time_Fs := 1; + Std_Standard_Time_Ps := 1000; + Std_Standard_Time_Ns := 1000_000; + Std_Standard_Time_Us := 1000_000_000; + Std_Standard_Time_Ms := Std_Time'Last; + Std_Standard_Time_Sec := Std_Time'Last; + Std_Standard_Time_Min := Std_Time'Last; + Std_Standard_Time_Hr := Std_Time'Last; + when 'p' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 1; + Std_Standard_Time_Ns := 1000; + Std_Standard_Time_Us := 1000_000; + Std_Standard_Time_Ms := 1000_000_000; + Std_Standard_Time_Sec := Std_Time'Last; + Std_Standard_Time_Min := Std_Time'Last; + Std_Standard_Time_Hr := Std_Time'Last; + when 'n' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 1; + Std_Standard_Time_Us := 1000; + Std_Standard_Time_Ms := 1000_000; + Std_Standard_Time_Sec := 1000_000_000; + Std_Standard_Time_Min := Std_Time'Last; + Std_Standard_Time_Hr := Std_Time'Last; + when 'u' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 1; + Std_Standard_Time_Ms := 1000; + Std_Standard_Time_Sec := 1000_000; + Std_Standard_Time_Min := 60_000_000; + Std_Standard_Time_Hr := Std_Time'Last; + when 'm' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 1; + Std_Standard_Time_Sec := 1000; + Std_Standard_Time_Min := 60_000; + Std_Standard_Time_Hr := 3600_000; + when 's' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 0; + Std_Standard_Time_Sec := 1; + Std_Standard_Time_Min := 60; + Std_Standard_Time_Hr := 3600; + when 'M' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 0; + Std_Standard_Time_Sec := 0; + Std_Standard_Time_Min := 1; + Std_Standard_Time_Hr := 60; + when 'h' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 0; + Std_Standard_Time_Sec := 0; + Std_Standard_Time_Min := 0; + Std_Standard_Time_Hr := 1; + when others => + Error ("bad time resolution"); + end case; + end Set_Time_Resolution; + + procedure Help + is + use Grt.Astdio; + procedure P (Str : String) renames Put_Line; + Prog_Name : Ghdl_C_String; + begin + if Argc > 0 then + Prog_Name := Argv (0); + Put ("Usage: "); + Put (Prog_Name (1 .. strlen (Prog_Name))); + Put (" [OPTIONS]"); + New_Line; + end if; + + P ("Options are:"); + P (" --help, -h disp this help"); + P (" --assert-level=LEVEL stop simulation if assert at LEVEL"); + P (" LEVEL is note,warning,error,failure,none"); + P (" --ieee-asserts=POLICY enable or disable asserts from IEEE"); + P (" POLICY is enable,disable,disable-at-0"); + P (" --stop-time=X stop the simulation at time X"); + P (" X is expressed as a time value, without spaces: 1ns, ps..."); + P (" --stop-delta=X stop the simulation cycle after X delta"); + P (" --expect-failure invert exit status"); + P (" --stack-size=X set the stack size of non-sensitized processes"); + P (" --stack-max-size=X set the maximum stack size"); + P (" --no-run do not simulate, only elaborate"); + -- P (" --threads=N use N threads for simulation"); + Grt.Hooks.Call_Help_Hooks; + P ("trace options:"); + P (" --disp-time disp time as simulation advances"); + P (" --trace-signals disp signals after each cycle"); + P (" --trace-processes disp process name before each cycle"); + P (" --stats display run-time statistics"); + P ("debug options:"); + P (" --disp-order disp signals order"); + P (" --disp-sources disp sources while displaying signals"); + P (" --disp-sig-types disp signal types"); + P (" --disp-signals-map disp map bw declared sigs and internal sigs"); + P (" --disp-signals-table disp internal signals"); + P (" --checks do internal checks after each process run"); + P (" --activity=LEVEL watch activity of LEVEL signals"); + P (" LEVEL is all, min (default) or none (unsafe)"); + end Help; + + -- Extract from STR a number. + -- First, all leading blanks are skipped. + -- Then, all next digits are eaten. + -- The position of the first non digit or one past the upper bound is + -- returned into POS. + -- If there is no digits, OK is set to false, else to true. + procedure Extract_Integer + (Str : String; + Ok : out Boolean; + Result : out Integer_64; + Pos : out Natural) + is + begin + Pos := Str'First; + -- Skip blanks. + while Pos <= Str'Last and then Str (Pos) = ' ' loop + Pos := Pos + 1; + end loop; + Ok := False; + Result := 0; + loop + exit when Pos > Str'Last or else Str (Pos) not in '0' .. '9'; + Ok := True; + Result := Result * 10 + + (Character'Pos (Str (Pos)) - Character'Pos ('0')); + Pos := Pos + 1; + end loop; + end Extract_Integer; + + function Extract_Size (Str : String; Option_Name : String) return Natural + is + Ok : Boolean; + Val : Integer_64; + Pos : Natural; + begin + Extract_Integer (Str, Ok, Val, Pos); + if not Ok then + Val := 1; + end if; + if Pos > Str'Last then + -- No suffix. + if Val > Integer_64(Natural'Last) then + Error_C ("Size exceeds limit for option "); + Error_E (Option_Name); + else + return Natural (Val); + end if; + end if; + if Pos = Str'Last + or else (Pos + 1 = Str'Last + and then (Str (Pos + 1) = 'b' or Str (Pos + 1) = 'o')) + then + if Str (Pos) = 'k' or Str (Pos) = 'K' then + return Natural (Val) * 1024; + elsif Str (Pos) = 'm' or Str (Pos) = 'M' then + return Natural (Val) * 1024 * 1024; + end if; + end if; + Error_C ("bad memory unit for option "); + Error_E (Option_Name); + end Extract_Size; + + function To_Lower (C : Character) return Character is + begin + if C in 'A' .. 'Z' then + return Character'Val (Character'Pos (C) + 32); + else + return C; + end if; + end To_Lower; + + procedure Decode_Option + (Option : String; Status : out Decode_Option_Status) + is + pragma Assert (Option'First = 1); + Len : constant Natural := Option'Last; + begin + Status := Decode_Option_Ok; + if Option = "--" then + Status := Decode_Option_Last; + elsif Option = "--help" or else Option = "-h" then + Help; + Status := Decode_Option_Help; + elsif Option = "--disp-time" then + Disp_Time := True; + elsif Option = "--trace-signals" then + Trace_Signals := True; + Disp_Time := True; + elsif Option = "--trace-processes" then + Trace_Processes := True; + Disp_Time := True; + elsif Option = "--disp-order" then + Disp_Signals_Order := True; + elsif Option = "--checks" then + Checks := True; + elsif Option = "--disp-sources" then + Disp_Sources := True; + elsif Option = "--disp-sig-types" then + Disp_Sig_Types := True; + elsif Option = "--disp-signals-map" then + Disp_Signals_Map := True; + elsif Option = "--disp-signals-table" then + Disp_Signals_Table := True; + elsif Option = "--disp-sensitivity" then + Disp_Sensitivity := True; + elsif Option = "--stats" then + Flag_Stats := True; + elsif Option = "--no-run" then + Flag_No_Run := True; + elsif Len > 18 and then Option (1 .. 18) = "--time-resolution=" then + declare + Res : Character; + Unit : String (1 .. 3); + begin + Res := '?'; + if Len >= 20 then + Unit (1) := To_Lower (Option (19)); + Unit (2) := To_Lower (Option (20)); + if Len = 20 then + if Unit (1 .. 2) = "fs" then + Res := 'f'; + elsif Unit (1 .. 2) = "ps" then + Res := 'p'; + elsif Unit (1 .. 2) = "ns" then + Res := 'n'; + elsif Unit (1 .. 2) = "us" then + Res := 'u'; + elsif Unit (1 .. 2) = "ms" then + Res := 'm'; + elsif Unit (1 .. 2) = "hr" then + Res := 'h'; + end if; + elsif Len = 21 then + Unit (3) := To_Lower (Option (21)); + if Unit = "min" then + Res := 'M'; + elsif Unit = "sec" then + Res := 's'; + end if; + end if; + end if; + if Res = '?' then + Error_C ("bad unit for '"); + Error_C (Option); + Error_E ("'"); + else + if Flag_String (5) = '-' then + Error ("time resolution is ignored"); + elsif Flag_String (5) = '?' then + if Stop_Time /= Std_Time'Last then + Error ("time resolution must be set " + & "before --stop-time"); + else + Set_Time_Resolution (Res); + end if; + elsif Flag_String (5) /= Res then + Error ("time resolution is fixed during analysis"); + end if; + end if; + end; + elsif Len > 12 and then Option (1 .. 12) = "--stop-time=" then + declare + Ok : Boolean; + Pos : Natural; + Time : Integer_64; + Unit : String (1 .. 3); + begin + Extract_Integer (Option (13 .. Len), Ok, Time, Pos); + if not Ok then + Time := 1; + end if; + if (Len - Pos + 1) not in 2 .. 3 then + Error_C ("bad unit for '"); + Error_C (Option); + Error_E ("'"); + return; + end if; + Unit (1) := To_Lower (Option (Pos)); + Unit (2) := To_Lower (Option (Pos + 1)); + if Len = Pos + 2 then + Unit (3) := To_Lower (Option (Pos + 2)); + else + Unit (3) := ' '; + end if; + if Unit = "fs " then + null; + elsif Unit = "ps " then + Time := Time * (10 ** 3); + elsif Unit = "ns " then + Time := Time * (10 ** 6); + elsif Unit = "us " then + Time := Time * (10 ** 9); + elsif Unit = "ms " then + Time := Time * (10 ** 12); + elsif Unit = "sec" then + Time := Time * (10 ** 15); + elsif Unit = "min" then + Time := Time * (10 ** 15) * 60; + elsif Unit = "hr " then + Time := Time * (10 ** 15) * 3600; + else + Error_C ("bad unit name for '"); + Error_C (Option); + Error_E ("'"); + end if; + Stop_Time := Std_Time (Time); + end; + elsif Len > 13 and then Option (1 .. 13) = "--stop-delta=" then + declare + Ok : Boolean; + Pos : Natural; + Time : Integer_64; + begin + Extract_Integer (Option (14 .. Len), Ok, Time, Pos); + if not Ok or else Pos <= Len then + Error_C ("bad value in '"); + Error_C (Option); + Error_E ("'"); + else + if Time > Integer_64 (Integer'Last) then + Stop_Delta := Integer'Last; + else + Stop_Delta := Integer (Time); + end if; + end if; + end; + elsif Len > 15 and then Option (1 .. 15) = "--assert-level=" then + if Option (16 .. Len) = "note" then + Severity_Level := Note_Severity; + elsif Option (16 .. Len) = "warning" then + Severity_Level := Warning_Severity; + elsif Option (16 .. Len) = "error" then + Severity_Level := Error_Severity; + elsif Option (16 .. Len) = "failure" then + Severity_Level := Failure_Severity; + elsif Option (16 .. Len) = "none" then + Severity_Level := 4; + else + Error ("bad argument for --assert-level option, try --help"); + end if; + elsif Len > 15 and then Option (1 .. 15) = "--ieee-asserts=" then + if Option (16 .. Len) = "disable" then + Ieee_Asserts := Disable_Asserts; + elsif Option (16 .. Len) = "enable" then + Ieee_Asserts := Enable_Asserts; + elsif Option (16 .. Len) = "disable-at-0" then + Ieee_Asserts := Disable_Asserts_At_Time_0; + else + Error ("bad argument for --ieee-asserts option, try --help"); + end if; + elsif Option = "--expect-failure" then + Expect_Failure := True; + elsif Len >= 13 and then Option (1 .. 13) = "--stack-size=" then + Stack_Size := Extract_Size + (Option (14 .. Len), "--stack-size"); + if Stack_Size > Stack_Max_Size then + Stack_Max_Size := Stack_Size; + end if; + elsif Len >= 17 and then Option (1 .. 17) = "--stack-max-size=" then + Stack_Max_Size := Extract_Size + (Option (18 .. Len), "--stack-size"); + if Stack_Size > Stack_Max_Size then + Stack_Size := Stack_Max_Size; + end if; + elsif Len >= 11 and then Option (1 .. 11) = "--activity=" then + if Option (12 .. Len) = "none" then + Flag_Activity := Activity_None; + elsif Option (12 .. Len) = "min" then + Flag_Activity := Activity_Minimal; + elsif Option (12 .. Len) = "all" then + Flag_Activity := Activity_All; + else + Error ("bad argument for --activity, try --help"); + end if; + elsif Len > 10 and then Option (1 .. 10) = "--threads=" then + declare + Ok : Boolean; + Pos : Natural; + Val : Integer_64; + begin + Extract_Integer (Option (11 .. Len), Ok, Val, Pos); + if not Ok or else Pos <= Len then + Error_C ("bad value in '"); + Error_C (Option); + Error_E ("'"); + else + Nbr_Threads := Integer (Val); + end if; + end; + elsif not Grt.Hooks.Call_Option_Hooks (Option) then + Error_C ("unknown option '"); + Error_C (Option); + Error_E ("', try --help"); + end if; + end Decode_Option; + + procedure Decode (Stop : out Boolean) + is + Arg : Ghdl_C_String; + Len : Natural; + Status : Decode_Option_Status; + begin + Stop := False; + Last_Opt := Argc - 1; + for I in 1 .. Argc - 1 loop + Arg := Argv (I); + Len := strlen (Arg); + declare + Argument : constant String := Arg (1 .. Len); + begin + Decode_Option (Argument, Status); + case Status is + when Decode_Option_Last => + Last_Opt := I; + exit; + when Decode_Option_Help => + Stop := True; + when Decode_Option_Ok => + null; + end case; + end; + end loop; + end Decode; +end Grt.Options; diff --git a/src/grt/grt-options.ads b/src/grt/grt-options.ads new file mode 100644 index 000000000..88b1f5084 --- /dev/null +++ b/src/grt/grt-options.ads @@ -0,0 +1,154 @@ +-- GHDL Run Time (GRT) - command line options. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Lib; use Grt.Lib; + +package Grt.Options is + pragma Preelaborate (Grt.Options); + + -- Name of the program, set by argv[0]. + -- Must be set before calling DECODE. + Progname : Ghdl_C_String; + + -- Arguments. + -- This mimics argc/argv of 'main'. + -- These must be set before calling DECODE. + Argc : Integer; + + type Argv_Array_Type is array (Natural) of Ghdl_C_String; + type Argv_Type is access Argv_Array_Type; + + Argv : Argv_Type; + + -- Last option decoded. + -- Following arguments are reserved for the program. + Last_Opt : Integer; + + -- Consistent flags used for analysis. + -- Format is "VVitr", where: + -- 'VV' is the version (87, 93 or 08). + -- 'i' is the integer size ('i' for 32 bits, 'I' for 64 bits). + -- 't' is the time size ('t' for 32 bits, 'T' for 64 bits). + -- 'r' is the resolution ('?' for to be set by the user, '-' for any). + Flag_String : constant String (1 .. 5); + pragma Import (C, Flag_String, "__ghdl_flag_string"); + + -- Display options help. + -- Should not be called directly. + procedure Help; + + -- Status from Decode_Option. + type Decode_Option_Status is + ( + -- Last option, next arguments aren't options. + Decode_Option_Last, + + -- --help option, program shouldn't run. + Decode_Option_Help, + + -- Option was successfuly decoded. + Decode_Option_Ok); + + -- Decode option Option and set Status. + procedure Decode_Option + (Option : String; Status : out Decode_Option_Status); + + -- Decode command line options. + -- If STOP is true, there nothing must happen (set by --help). + procedure Decode (Stop : out Boolean); + + -- Set by --disp-time (and --trace-signals, --trace-processes) to display + -- time and deltas. + Disp_Time : Boolean := False; + + -- Set by --trace-signals, to display signals after each cycle. + Trace_Signals : Boolean := False; + + -- Set by --trace-processes, to display process name before being run. + Trace_Processes : Boolean := False; + + -- Set by --disp-sig-types, to display signals and they types. + Disp_Sig_Types : Boolean := False; + + Disp_Sources : Boolean := False; + Disp_Signals_Map : Boolean := False; + Disp_Signals_Table : Boolean := False; + Disp_Sensitivity : Boolean := False; + + -- Set by --disp-order to diplay evaluation order of signals. + Disp_Signals_Order : Boolean := False; + + -- Set by --stats to display statistics. + Flag_Stats : Boolean := False; + + -- Set by --checks to do internal checks. + Checks : Boolean := False; + + -- Level at which an assert stop the simulation. + Severity_Level : Integer := Failure_Severity; + + -- How assertions are handled. + type Assert_Handling is + (Enable_Asserts, + Disable_Asserts_At_Time_0, + Disable_Asserts); + + -- Handling of assertions from IEEE library. + Ieee_Asserts : Assert_Handling := Enable_Asserts; + + -- Set by --stop-time=XXX to stop the simulation at or just after XXX. + -- (unit is fs in fact). + Stop_Time : Std_Time := Std_Time'Last; + + -- Set by --stop-delta=XXX to stop the simulation after XXX delta cycles. + Stop_Delta : Natural := 5000; + + -- The default stack size for non-sensitized processes. + Stack_Size : Natural := 8 * 1024; + + -- The maximum stack size for non-sensitized processes. + Stack_Max_Size : Natural := 128 * 1024; + + -- Set by --no-run + -- If set, do not simulate, only elaborate. + Flag_No_Run : Boolean := False; + + type Activity_Mode is (Activity_All, Activity_Minimal, Activity_None); + Flag_Activity : Activity_Mode := Activity_Minimal; + + -- Set by --thread= + -- Number of threads used to do the simulation. + -- 1 mean no additionnal threads, 0 means as many threads as number of + -- CPUs. + Nbr_Threads : Natural := 1; + + -- Set the time resolution. + -- Only call this subprogram if you are allowed to set the time resolution. + procedure Set_Time_Resolution (Res : Character); +private + pragma Export (C, Stack_Size); + pragma Export (C, Stack_Max_Size); + pragma Export (C, Nbr_Threads, "grt_nbr_threads"); +end Grt.Options; diff --git a/src/grt/grt-processes.adb b/src/grt/grt-processes.adb new file mode 100644 index 000000000..64db682e2 --- /dev/null +++ b/src/grt/grt-processes.adb @@ -0,0 +1,1042 @@ +-- GHDL Run Time (GRT) - processes. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Table; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Disp; +with Grt.Astdio; +with Grt.Errors; use Grt.Errors; +with Grt.Options; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Utils; +with Grt.Hooks; +with Grt.Disp_Signals; +with Grt.Stats; +with Grt.Threads; use Grt.Threads; +pragma Elaborate_All (Grt.Table); + +package body Grt.Processes is + Last_Time : constant Std_Time := Std_Time'Last; + + -- Identifier for a process. + type Process_Id is new Integer; + + -- Table of processes. + package Process_Table is new Grt.Table + (Table_Component_Type => Process_Acc, + Table_Index_Type => Process_Id, + Table_Low_Bound => 1, + Table_Initial => 16); + + type Finalizer_Type is record + -- Subprogram containing process code. + Subprg : Proc_Acc; + + -- Instance (THIS parameter) for the subprogram. + This : Instance_Acc; + end record; + + -- List of finalizer. + package Finalizer_Table is new Grt.Table + (Table_Component_Type => Finalizer_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 2); + + -- List of processes to be resume at next cycle. + type Process_Acc_Array is array (Natural range <>) of Process_Acc; + type Process_Acc_Array_Acc is access Process_Acc_Array; + + Resume_Process_Table : Process_Acc_Array_Acc; + Last_Resume_Process : Natural := 0; + Postponed_Resume_Process_Table : Process_Acc_Array_Acc; + Last_Postponed_Resume_Process : Natural := 0; + + -- Number of postponed processes. + Nbr_Postponed_Processes : Natural := 0; + Nbr_Non_Postponed_Processes : Natural := 0; + + -- Number of resumed processes. + Nbr_Resumed_Processes : Natural := 0; + + -- Earliest time out within non-sensitized processes. + Process_First_Timeout : Std_Time := Last_Time; + Process_Timeout_Chain : Process_Acc := null; + + procedure Init is + begin + null; + end Init; + + function Get_Nbr_Processes return Natural is + begin + return Natural (Process_Table.Last); + end Get_Nbr_Processes; + + function Get_Nbr_Sensitized_Processes return Natural + is + Res : Natural := 0; + begin + for I in Process_Table.First .. Process_Table.Last loop + if Process_Table.Table (I).State = State_Sensitized then + Res := Res + 1; + end if; + end loop; + return Res; + end Get_Nbr_Sensitized_Processes; + + function Get_Nbr_Resumed_Processes return Natural is + begin + return Nbr_Resumed_Processes; + end Get_Nbr_Resumed_Processes; + + procedure Process_Register (This : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Rti_Context; + State : Process_State; + Postponed : Boolean) + is + Stack : Stack_Type; + P : Process_Acc; + begin + if State /= State_Sensitized and then not One_Stack then + Stack := Stack_Create (Proc, This); + if Stack = Null_Stack then + Internal_Error ("cannot allocate stack: memory exhausted"); + end if; + else + Stack := Null_Stack; + end if; + P := new Process_Type'(Subprg => Proc, + This => This, + Rti => Ctxt, + Sensitivity => null, + Resumed => False, + Postponed => Postponed, + State => State, + Timeout => Bad_Time, + Timeout_Chain_Next => null, + Timeout_Chain_Prev => null, + Stack => Stack); + Process_Table.Append (P); + -- Used to create drivers. + Set_Current_Process (P); + if Postponed then + Nbr_Postponed_Processes := Nbr_Postponed_Processes + 1; + else + Nbr_Non_Postponed_Processes := Nbr_Non_Postponed_Processes + 1; + end if; + end Process_Register; + + procedure Ghdl_Process_Register + (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address) + is + begin + Process_Register (Instance, Proc, (Addr, Ctxt), State_Ready, False); + end Ghdl_Process_Register; + + procedure Ghdl_Sensitized_Process_Register + (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address) + is + begin + Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, False); + end Ghdl_Sensitized_Process_Register; + + procedure Ghdl_Postponed_Process_Register + (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address) + is + begin + Process_Register (Instance, Proc, (Addr, Ctxt), State_Ready, True); + end Ghdl_Postponed_Process_Register; + + procedure Ghdl_Postponed_Sensitized_Process_Register + (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address) + is + begin + Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, True); + end Ghdl_Postponed_Sensitized_Process_Register; + + procedure Verilog_Process_Register (This : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Rti_Context) + is + P : Process_Acc; + begin + P := new Process_Type'(Rti => Ctxt, + Sensitivity => null, + Resumed => False, + Postponed => False, + State => State_Sensitized, + Timeout => Bad_Time, + Timeout_Chain_Next => null, + Timeout_Chain_Prev => null, + Subprg => Proc, + This => This, + Stack => Null_Stack); + Process_Table.Append (P); + -- Used to create drivers. + Set_Current_Process (P); + end Verilog_Process_Register; + + procedure Ghdl_Initial_Register (Instance : Instance_Acc; + Proc : Proc_Acc) + is + begin + Verilog_Process_Register (Instance, Proc, Null_Context); + end Ghdl_Initial_Register; + + procedure Ghdl_Always_Register (Instance : Instance_Acc; + Proc : Proc_Acc) + is + begin + Verilog_Process_Register (Instance, Proc, Null_Context); + end Ghdl_Always_Register; + + procedure Ghdl_Process_Add_Sensitivity (Sig : Ghdl_Signal_Ptr) + is + begin + Resume_Process_If_Event + (Sig, Process_Table.Table (Process_Table.Last)); + end Ghdl_Process_Add_Sensitivity; + + procedure Ghdl_Finalize_Register (Instance : Instance_Acc; + Proc : Proc_Acc) + is + begin + Finalizer_Table.Append (Finalizer_Type'(Proc, Instance)); + end Ghdl_Finalize_Register; + + procedure Call_Finalizers is + El : Finalizer_Type; + begin + for I in Finalizer_Table.First .. Finalizer_Table.Last loop + El := Finalizer_Table.Table (I); + El.Subprg.all (El.This); + end loop; + end Call_Finalizers; + + procedure Resume_Process (Proc : Process_Acc) + is + begin + if not Proc.Resumed then + Proc.Resumed := True; + if Proc.Postponed then + Last_Postponed_Resume_Process := Last_Postponed_Resume_Process + 1; + Postponed_Resume_Process_Table (Last_Postponed_Resume_Process) + := Proc; + else + Last_Resume_Process := Last_Resume_Process + 1; + Resume_Process_Table (Last_Resume_Process) := Proc; + end if; + end if; + end Resume_Process; + + function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type) + return System.Address + is + begin + return Grt.Stack2.Allocate (Get_Stack2, Size); + end Ghdl_Stack2_Allocate; + + function Ghdl_Stack2_Mark return Mark_Id + is + St2 : Stack2_Ptr := Get_Stack2; + begin + if St2 = Null_Stack2_Ptr then + St2 := Grt.Stack2.Create; + Set_Stack2 (St2); + end if; + return Grt.Stack2.Mark (St2); + end Ghdl_Stack2_Mark; + + procedure Ghdl_Stack2_Release (Mark : Mark_Id) is + begin + Grt.Stack2.Release (Get_Stack2, Mark); + end Ghdl_Stack2_Release; + + procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr) + is + Proc : constant Process_Acc := Get_Current_Process; + El : Action_List_Acc; + begin + El := new Action_List'(Dynamic => True, + Next => Sig.Event_List, + Proc => Proc, + Prev => null, + Sig => Sig, + Chain => Proc.Sensitivity); + if Sig.Event_List /= null and then Sig.Event_List.Dynamic then + Sig.Event_List.Prev := El; + end if; + Sig.Event_List := El; + Proc.Sensitivity := El; + end Ghdl_Process_Wait_Add_Sensitivity; + + procedure Update_Process_First_Timeout (Proc : Process_Acc) is + begin + if Proc.Timeout < Process_First_Timeout then + Process_First_Timeout := Proc.Timeout; + end if; + Proc.Timeout_Chain_Next := Process_Timeout_Chain; + Proc.Timeout_Chain_Prev := null; + if Process_Timeout_Chain /= null then + Process_Timeout_Chain.Timeout_Chain_Prev := Proc; + end if; + Process_Timeout_Chain := Proc; + end Update_Process_First_Timeout; + + procedure Remove_Process_From_Timeout_Chain (Proc : Process_Acc) is + begin + -- Remove Proc from the timeout list. + if Proc.Timeout_Chain_Prev /= null then + Proc.Timeout_Chain_Prev.Timeout_Chain_Next := + Proc.Timeout_Chain_Next; + elsif Process_Timeout_Chain = Proc then + -- Only if Proc is in the chain. + Process_Timeout_Chain := Proc.Timeout_Chain_Next; + end if; + if Proc.Timeout_Chain_Next /= null then + Proc.Timeout_Chain_Next.Timeout_Chain_Prev := + Proc.Timeout_Chain_Prev; + Proc.Timeout_Chain_Next := null; + end if; + -- Be sure a second call won't corrupt the chain. + Proc.Timeout_Chain_Prev := null; + end Remove_Process_From_Timeout_Chain; + + procedure Ghdl_Process_Wait_Set_Timeout (Time : Std_Time) + is + Proc : constant Process_Acc := Get_Current_Process; + begin + if Time < 0 then + -- LRM93 8.1 + Error ("negative timeout clause"); + end if; + Proc.Timeout := Current_Time + Time; + Update_Process_First_Timeout (Proc); + end Ghdl_Process_Wait_Set_Timeout; + + function Ghdl_Process_Wait_Has_Timeout return Boolean + is + Proc : constant Process_Acc := Get_Current_Process; + begin + -- Note: in case of timeout, the timeout is removed when process is + -- woken up. + return Proc.State = State_Timeout; + end Ghdl_Process_Wait_Has_Timeout; + + procedure Ghdl_Process_Wait_Wait + is + Proc : constant Process_Acc := Get_Current_Process; + begin + if Proc.State = State_Sensitized then + Error ("wait statement in a sensitized process"); + end if; + -- Suspend this process. + Proc.State := State_Wait; +-- if Cur_Proc.Timeout = Bad_Time then +-- Cur_Proc.Timeout := Std_Time'Last; +-- end if; + end Ghdl_Process_Wait_Wait; + + function Ghdl_Process_Wait_Suspend return Boolean + is + Proc : constant Process_Acc := Get_Current_Process; + begin + Ghdl_Process_Wait_Wait; + if One_Stack then + Internal_Error ("wait_suspend"); + else + Stack_Switch (Get_Main_Stack, Proc.Stack); + end if; + return Ghdl_Process_Wait_Has_Timeout; + end Ghdl_Process_Wait_Suspend; + + procedure Free is new Ada.Unchecked_Deallocation + (Action_List, Action_List_Acc); + + procedure Ghdl_Process_Wait_Close + is + Proc : constant Process_Acc := Get_Current_Process; + El : Action_List_Acc; + N_El : Action_List_Acc; + begin + -- Remove the sensitivity. + El := Proc.Sensitivity; + Proc.Sensitivity := null; + while El /= null loop + pragma Assert (El.Proc = Get_Current_Process); + if El.Prev = null then + El.Sig.Event_List := El.Next; + else + pragma Assert (El.Prev.Dynamic); + El.Prev.Next := El.Next; + end if; + if El.Next /= null and then El.Next.Dynamic then + El.Next.Prev := El.Prev; + end if; + N_El := El.Chain; + Free (El); + El := N_El; + end loop; + + -- Remove Proc from the timeout list. + Remove_Process_From_Timeout_Chain (Proc); + + -- This is necessary when the process has been woken-up by an event + -- before the timeout triggers. + if Process_First_Timeout = Proc.Timeout then + -- Remove the timeout. + Proc.Timeout := Bad_Time; + + declare + Next_Timeout : Std_Time; + P : Process_Acc; + begin + Next_Timeout := Last_Time; + P := Process_Timeout_Chain; + while P /= null loop + case P.State is + when State_Delayed + | State_Wait => + if P.Timeout > 0 + and then P.Timeout < Next_Timeout + then + Next_Timeout := P.Timeout; + end if; + when others => + null; + end case; + P := P.Timeout_Chain_Next; + end loop; + Process_First_Timeout := Next_Timeout; + end; + else + -- Remove the timeout. + Proc.Timeout := Bad_Time; + end if; + Proc.State := State_Ready; + end Ghdl_Process_Wait_Close; + + procedure Ghdl_Process_Wait_Exit + is + Proc : constant Process_Acc := Get_Current_Process; + begin + if Proc.State = State_Sensitized then + Error ("wait statement in a sensitized process"); + end if; + -- Mark this process as dead, in order to kill it. + -- It cannot be killed now, since this code is still in the process. + Proc.State := State_Dead; + + -- Suspend this process. + if not One_Stack then + Stack_Switch (Get_Main_Stack, Proc.Stack); + end if; + end Ghdl_Process_Wait_Exit; + + procedure Ghdl_Process_Wait_Timeout (Time : Std_Time) + is + Proc : constant Process_Acc := Get_Current_Process; + begin + if Proc.State = State_Sensitized then + Error ("wait statement in a sensitized process"); + end if; + if Time < 0 then + -- LRM93 8.1 + Error ("negative timeout clause"); + end if; + Proc.Timeout := Current_Time + Time; + Proc.State := State_Wait; + Update_Process_First_Timeout (Proc); + -- Suspend this process. + if One_Stack then + Internal_Error ("wait_timeout"); + else + Stack_Switch (Get_Main_Stack, Proc.Stack); + end if; + -- Clean-up. + Proc.Timeout := Bad_Time; + Remove_Process_From_Timeout_Chain (Proc); + Proc.State := State_Ready; + end Ghdl_Process_Wait_Timeout; + + -- Verilog. + procedure Ghdl_Process_Delay (Del : Ghdl_U32) + is + Proc : constant Process_Acc := Get_Current_Process; + begin + Proc.Timeout := Current_Time + Std_Time (Del); + Proc.State := State_Delayed; + Update_Process_First_Timeout (Proc); + end Ghdl_Process_Delay; + + -- Protected object lock. + -- Note: there is no real locks, since the kernel is single threading. + -- Multi lock is allowed, and rules are just checked. + type Object_Lock is record + -- The owner of the lock. + -- Nul_Process_Id means the lock is free. + Process : Process_Acc; + -- Number of times the lock has been acquired. + Count : Natural; + end record; + + type Object_Lock_Acc is access Object_Lock; + type Object_Lock_Acc_Acc is access Object_Lock_Acc; + + function To_Lock_Acc_Acc is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Object_Lock_Acc_Acc); + + procedure Ghdl_Protected_Enter (Obj : System.Address) + is + Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all; + begin + if Lock.Process = null then + if Lock.Count /= 0 then + Internal_Error ("protected_enter"); + end if; + Lock.Process := Get_Current_Process; + Lock.Count := 1; + else + if Lock.Process /= Get_Current_Process then + Internal_Error ("protected_enter(2)"); + end if; + Lock.Count := Lock.Count + 1; + end if; + end Ghdl_Protected_Enter; + + procedure Ghdl_Protected_Leave (Obj : System.Address) + is + Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all; + begin + if Lock.Process /= Get_Current_Process then + Internal_Error ("protected_leave(1)"); + end if; + + if Lock.Count = 0 then + Internal_Error ("protected_leave(2)"); + end if; + Lock.Count := Lock.Count - 1; + if Lock.Count = 0 then + Lock.Process := null; + end if; + end Ghdl_Protected_Leave; + + procedure Ghdl_Protected_Init (Obj : System.Address) + is + Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj); + begin + Lock.all := new Object_Lock'(Process => null, Count => 0); + end Ghdl_Protected_Init; + + procedure Ghdl_Protected_Fini (Obj : System.Address) + is + procedure Deallocate is new Ada.Unchecked_Deallocation + (Object => Object_Lock, Name => Object_Lock_Acc); + + Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj); + begin + if Lock.all.Count /= 0 or Lock.all.Process /= null then + Internal_Error ("protected_fini"); + end if; + Deallocate (Lock.all); + end Ghdl_Protected_Fini; + + function Compute_Next_Time return Std_Time + is + Res : Std_Time; + begin + -- f) The time of the next simulation cycle, Tn, is determined by + -- setting it to the earliest of + -- 1) TIME'HIGH + Res := Std_Time'Last; + + -- 2) The next time at which a driver becomes active, or + Res := Std_Time'Min (Res, Grt.Signals.Find_Next_Time); + + if Res = Current_Time then + return Res; + end if; + + -- 3) The next time at which a process resumes. + if Process_First_Timeout < Res then + -- No signals to be updated. + Grt.Signals.Flush_Active_List; + + Res := Process_First_Timeout; + end if; + + return Res; + end Compute_Next_Time; + + procedure Disp_Process_Name (Stream : Grt.Stdio.FILEs; Proc : Process_Acc) + is + begin + Grt.Rtis_Utils.Put (Stream, Proc.Rti); + end Disp_Process_Name; + + procedure Disp_All_Processes + is + use Grt.Stdio; + use Grt.Astdio; + begin + for I in Process_Table.First .. Process_Table.Last loop + declare + Proc : constant Process_Acc := Process_Table.Table (I); + begin + Disp_Process_Name (stdout, Proc); + New_Line (stdout); + Put (stdout, " State: "); + case Proc.State is + when State_Sensitized => + Put (stdout, "sensitized"); + when State_Wait => + Put (stdout, "wait"); + if Proc.Timeout /= Bad_Time then + Put (stdout, " until "); + Put_Time (stdout, Proc.Timeout); + end if; + when State_Ready => + Put (stdout, "ready"); + when State_Timeout => + Put (stdout, "timeout"); + when State_Delayed => + Put (stdout, "delayed"); + when State_Dead => + Put (stdout, "dead"); + end case; +-- Put (stdout, ": time: "); +-- Put_U64 (stdout, Proc.Stats_Time); +-- Put (stdout, ", runs: "); +-- Put_U32 (stdout, Proc.Stats_Run); + New_Line (stdout); + end; + end loop; + end Disp_All_Processes; + + pragma Unreferenced (Disp_All_Processes); + + -- Run resumed processes. + -- If POSTPONED is true, resume postponed processes, else resume + -- non-posponed processes. + -- Returns one of these values: + -- No process has been run. + Run_None : constant Integer := 1; + -- At least one process was run. + Run_Resumed : constant Integer := 2; + -- Simulation is finished. + Run_Finished : constant Integer := 3; + -- Failure, simulation should stop. + Run_Failure : constant Integer := -1; + + Mt_Last : Natural; + Mt_Table : Process_Acc_Array_Acc; + Mt_Index : aliased Natural; + + procedure Run_Processes_Threads + is + Proc : Process_Acc; + Idx : Natural; + begin + loop + -- Atomically get a process to be executed + Idx := Grt.Threads.Atomic_Inc (Mt_Index'Access); + if Idx > Mt_Last then + return; + end if; + Proc := Mt_Table (Idx); + + if Grt.Options.Trace_Processes then + Grt.Astdio.Put ("run process "); + Disp_Process_Name (Stdio.stdout, Proc); + Grt.Astdio.Put (" ["); + Grt.Astdio.Put (Stdio.stdout, To_Address (Proc.This)); + Grt.Astdio.Put ("]"); + Grt.Astdio.New_Line; + end if; + if not Proc.Resumed then + Internal_Error ("run non-resumed process"); + end if; + Proc.Resumed := False; + Set_Current_Process (Proc); + if Proc.State = State_Sensitized or else One_Stack then + Proc.Subprg.all (Proc.This); + else + Stack_Switch (Proc.Stack, Get_Main_Stack); + end if; + if Grt.Options.Checks then + Ghdl_Signal_Internal_Checks; + Grt.Stack2.Check_Empty (Get_Stack2); + end if; + end loop; + end Run_Processes_Threads; + + function Run_Processes (Postponed : Boolean) return Integer + is + Table : Process_Acc_Array_Acc; + Last : Natural; + begin + if Options.Flag_Stats then + Stats.Start_Processes; + end if; + + if Postponed then + Table := Postponed_Resume_Process_Table; + Last := Last_Postponed_Resume_Process; + Last_Postponed_Resume_Process := 0; + else + Table := Resume_Process_Table; + Last := Last_Resume_Process; + Last_Resume_Process := 0; + end if; + Nbr_Resumed_Processes := Nbr_Resumed_Processes + Last; + + if Options.Nbr_Threads = 1 then + for I in 1 .. Last loop + declare + Proc : constant Process_Acc := Table (I); + begin + if not Proc.Resumed then + Internal_Error ("run non-resumed process"); + end if; + if Grt.Options.Trace_Processes then + Grt.Astdio.Put ("run process "); + Disp_Process_Name (Stdio.stdout, Proc); + Grt.Astdio.Put (" ["); + Grt.Astdio.Put (Stdio.stdout, To_Address (Proc.This)); + Grt.Astdio.Put ("]"); + Grt.Astdio.New_Line; + end if; + + Proc.Resumed := False; + Set_Current_Process (Proc); + if Proc.State = State_Sensitized or else One_Stack then + Proc.Subprg.all (Proc.This); + else + Stack_Switch (Proc.Stack, Get_Main_Stack); + end if; + if Grt.Options.Checks then + Ghdl_Signal_Internal_Checks; + Grt.Stack2.Check_Empty (Get_Stack2); + end if; + end; + end loop; + else + Mt_Last := Last; + Mt_Table := Table; + Mt_Index := 1; + Threads.Run_Parallel (Run_Processes_Threads'Access); + end if; + + if Last >= 1 then + return Run_Resumed; + else + return Run_None; + end if; + end Run_Processes; + + function Initialization_Phase return Integer + is + Status : Integer; + begin + -- Allocate processes arrays. + Resume_Process_Table := + new Process_Acc_Array (1 .. Nbr_Non_Postponed_Processes); + Postponed_Resume_Process_Table := + new Process_Acc_Array (1 .. Nbr_Postponed_Processes); + + -- LRM93 12.6.4 + -- At the beginning of initialization, the current time, Tc, is assumed + -- to be 0 ns. + Current_Time := 0; + + -- The initialization phase consists of the following steps: + -- - The driving value and the effective value of each explicitly + -- declared signal are computed, and the current value of the signal + -- is set to the effective value. This value is assumed to have been + -- the value of the signal for an infinite length of time prior to + -- the start of the simulation. + Init_Signals; + + -- - The value of each implicit signal of the form S'Stable(T) or + -- S'Quiet(T) is set to true. The value of each implicit signal of + -- the form S'Delayed is set to the initial value of its prefix, S. + -- GHDL: already done when the signals are created. + null; + + -- - The value of each implicit GUARD signal is set to the result of + -- evaluating the corresponding guard expression. + null; + + for I in Process_Table.First .. Process_Table.Last loop + Resume_Process (Process_Table.Table (I)); + end loop; + + -- - Each nonpostponed process in the model is executed until it + -- suspends. + Status := Run_Processes (Postponed => False); + if Status = Run_Failure then + return Run_Failure; + end if; + + -- - Each postponed process in the model is executed until it suspends. + Status := Run_Processes (Postponed => True); + if Status = Run_Failure then + return Run_Failure; + end if; + + -- - The time of the next simulation cycle (which in this case is the + -- first simulation cycle), Tn, is calculated according to the rules + -- of step f of the simulation cycle, below. + Current_Time := Compute_Next_Time; + + -- Clear current_delta, will be set by Simulation_Cycle. + Current_Delta := 0; + + return Run_Resumed; + end Initialization_Phase; + + -- Launch a simulation cycle. + -- Set FINISHED to true if this is the last cycle. + function Simulation_Cycle return Integer + is + Tn : Std_Time; + Status : Integer; + begin + -- LRM93 12.6.4 + -- A simulation cycle consists of the following steps: + -- + -- a) The current time, Tc is set equal to Tn. Simulation is complete + -- when Tn = TIME'HIGH and there are no active drivers or process + -- resumptions at Tn. + -- GHDL: this is done at the last step of the cycle. + null; + + -- b) Each active explicit signal in the model is updated. (Events + -- may occur on signals as a result). + -- c) Each implicit signal in the model is updated. (Events may occur + -- on signals as a result.) + if Options.Flag_Stats then + Stats.Start_Update; + end if; + Update_Signals; + if Options.Flag_Stats then + Stats.Start_Resume; + end if; + + -- d) For each process P, if P is currently sensitive to a signal S and + -- if an event has occured on S in this simulation cycle, then P + -- resumes. + if Current_Time = Process_First_Timeout then + Tn := Last_Time; + declare + Proc : Process_Acc; + begin + Proc := Process_Timeout_Chain; + while Proc /= null loop + case Proc.State is + when State_Sensitized => + null; + when State_Delayed => + if Proc.Timeout = Current_Time then + Proc.Timeout := Bad_Time; + Resume_Process (Proc); + Proc.State := State_Sensitized; + elsif Proc.Timeout > 0 and then Proc.Timeout < Tn then + Tn := Proc.Timeout; + end if; + when State_Wait => + if Proc.Timeout = Current_Time then + Proc.Timeout := Bad_Time; + Resume_Process (Proc); + Proc.State := State_Timeout; + elsif Proc.Timeout > 0 and then Proc.Timeout < Tn then + Tn := Proc.Timeout; + end if; + when State_Timeout + | State_Ready => + Internal_Error ("process in timeout"); + when State_Dead => + null; + end case; + Proc := Proc.Timeout_Chain_Next; + end loop; + end; + Process_First_Timeout := Tn; + end if; + + -- e) Each nonpostponed that has resumed in the current simulation cycle + -- is executed until it suspends. + Status := Run_Processes (Postponed => False); + if Status = Run_Failure then + return Run_Failure; + end if; + + -- f) The time of the next simulation cycle, Tn, is determined by + -- setting it to the earliest of + -- 1) TIME'HIGH + -- 2) The next time at which a driver becomes active, or + -- 3) The next time at which a process resumes. + -- If Tn = Tc, then the next simulation cycle (if any) will be a + -- delta cycle. + if Options.Flag_Stats then + Stats.Start_Next_Time; + end if; + Tn := Compute_Next_Time; + + -- g) If the next simulation cycle will be a delta cycle, the remainder + -- of the step is skipped. + -- Otherwise, each postponed process that has resumed but has not + -- been executed since its last resumption is executed until it + -- suspends. Then Tn is recalculated according to the rules of + -- step f. It is an error if the execution of any postponed + -- process causes a delta cycle to occur immediatly after the + -- current simulation cycle. + if Tn = Current_Time then + if Current_Time = Last_Time and then Status = Run_None then + return Run_Finished; + else + Current_Delta := Current_Delta + 1; + return Run_Resumed; + end if; + else + Current_Delta := 0; + if Nbr_Postponed_Processes /= 0 then + Status := Run_Processes (Postponed => True); + end if; + if Status = Run_Resumed then + Flush_Active_List; + if Options.Flag_Stats then + Stats.Start_Next_Time; + end if; + Tn := Compute_Next_Time; + if Tn = Current_Time then + Error ("postponed process causes a delta cycle"); + end if; + elsif Status = Run_Failure then + return Run_Failure; + end if; + Current_Time := Tn; + return Run_Resumed; + end if; + end Simulation_Cycle; + + function Simulation return Integer + is + use Options; + Status : Integer; + begin + if Nbr_Threads /= 1 then + Threads.Init; + end if; + +-- if Disp_Sig_Types then +-- Grt.Disp.Disp_Signals_Type; +-- end if; + + Status := Run_Through_Longjump (Initialization_Phase'Access); + if Status /= Run_Resumed then + return -1; + end if; + + Nbr_Delta_Cycles := 0; + Nbr_Cycles := 0; + if Trace_Signals then + Grt.Disp_Signals.Disp_All_Signals; + end if; + + if Current_Time /= 0 then + -- This is the end of a cycle. This can happen when the time is not + -- zero after initialization. + Cycle_Time := 0; + Grt.Hooks.Call_Cycle_Hooks; + end if; + + loop + Cycle_Time := Current_Time; + if Disp_Time then + Grt.Disp.Disp_Now; + end if; + Status := Run_Through_Longjump (Simulation_Cycle'Access); + exit when Status < 0; + if Trace_Signals then + Grt.Disp_Signals.Disp_All_Signals; + end if; + + -- Statistics. + if Current_Delta = 0 then + Nbr_Cycles := Nbr_Cycles + 1; + else + Nbr_Delta_Cycles := Nbr_Delta_Cycles + 1; + end if; + + exit when Status = Run_Finished; + if Current_Delta = 0 then + Grt.Hooks.Call_Cycle_Hooks; + end if; + + if Current_Delta >= Stop_Delta then + Error ("simulation stopped by --stop-delta"); + exit; + end if; + if Current_Time > Stop_Time then + if Current_Time /= Last_Time then + Info ("simulation stopped by --stop-time"); + end if; + exit; + end if; + end loop; + + if Nbr_Threads /= 1 then + Threads.Finish; + end if; + + Call_Finalizers; + + Grt.Hooks.Call_Finish_Hooks; + + if Status = Run_Failure then + return -1; + else + return Exit_Status ; + end if; + end Simulation; + +end Grt.Processes; diff --git a/src/grt/grt-processes.ads b/src/grt/grt-processes.ads new file mode 100644 index 000000000..22326eb5e --- /dev/null +++ b/src/grt/grt-processes.ads @@ -0,0 +1,260 @@ +-- GHDL Run Time (GRT) - processes. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; +with Grt.Stack2; use Grt.Stack2; +with Grt.Types; use Grt.Types; +with Grt.Signals; use Grt.Signals; +with Grt.Stacks; use Grt.Stacks; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; +with Grt.Stdio; + +package Grt.Processes is + pragma Suppress (All_Checks); + + -- Internal initialisations. + procedure Init; + + -- Do the VHDL simulation. + -- Return 0 in case of success (end of time reached). + function Simulation return Integer; + + -- Number of delta cycles. + Nbr_Delta_Cycles : Integer; + -- Number of non-delta cycles. + Nbr_Cycles : Integer; + + -- If true, the simulation should be stopped. + Break_Simulation : Boolean; + + -- If true, there is one stack for all processes. Non-sensitized + -- processes must save their state. + One_Stack : Boolean := False; + + type Process_Type is private; + -- type Process_Acc is access all Process_Type; + + -- Return the identifier of the current process. + -- During the elaboration, this is the identifier of the last process + -- being elaborated. So, this function can be used to create signal + -- drivers. + + -- Return the total number of processes and number of sensitized processes. + -- Used for statistics. + function Get_Nbr_Processes return Natural; + function Get_Nbr_Sensitized_Processes return Natural; + + -- Total number of resumed processes. + function Get_Nbr_Resumed_Processes return Natural; + + -- Disp the name of process PROC. + procedure Disp_Process_Name (Stream : Grt.Stdio.FILEs; Proc : Process_Acc); + + -- Register a process during elaboration. + -- This procedure is called by vhdl elaboration code. + procedure Ghdl_Process_Register (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + procedure Ghdl_Sensitized_Process_Register (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + procedure Ghdl_Postponed_Process_Register (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + procedure Ghdl_Postponed_Sensitized_Process_Register + (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + + -- For verilog processes. + procedure Ghdl_Finalize_Register (Instance : Instance_Acc; + Proc : Proc_Acc); + + procedure Ghdl_Initial_Register (Instance : Instance_Acc; + Proc : Proc_Acc); + procedure Ghdl_Always_Register (Instance : Instance_Acc; + Proc : Proc_Acc); + + -- Add a simple signal in the sensitivity of the last registered + -- (sensitized) process. + procedure Ghdl_Process_Add_Sensitivity (Sig : Ghdl_Signal_Ptr); + + -- Resume a process. + procedure Resume_Process (Proc : Process_Acc); + + -- Wait without timeout or sensitivity: wait; + procedure Ghdl_Process_Wait_Exit; + -- Wait for a timeout (without sensitivity): wait for X; + procedure Ghdl_Process_Wait_Timeout (Time : Std_Time); + + -- Full wait statement: + -- 1. Call Ghdl_Process_Wait_Set_Timeout (if there is a timeout) + -- 2. Call Ghdl_Process_Wait_Add_Sensitivity (for each signal) + -- 3. Call Ghdl_Process_Wait_Suspend, go to 4 if it returns true (timeout) + -- Evaluate the condition and go to 4 if true + -- Else, restart 3 + -- 4. Call Ghdl_Process_Wait_Close + + -- Add a timeout for a wait. + procedure Ghdl_Process_Wait_Set_Timeout (Time : Std_Time); + -- Add a sensitivity for a wait. + procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr); + -- Wait until timeout or sensitivity. + -- Return TRUE in case of timeout. + function Ghdl_Process_Wait_Suspend return Boolean; + -- Finish a wait statement. + procedure Ghdl_Process_Wait_Close; + + -- For one stack setups, wait_suspend is decomposed into the suspension + -- procedure and the function to get resume status. + procedure Ghdl_Process_Wait_Wait; + function Ghdl_Process_Wait_Has_Timeout return Boolean; + + -- Verilog. + procedure Ghdl_Process_Delay (Del : Ghdl_U32); + + -- Secondary stack. + function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type) + return System.Address; + function Ghdl_Stack2_Mark return Mark_Id; + procedure Ghdl_Stack2_Release (Mark : Mark_Id); + + -- Protected variables. + procedure Ghdl_Protected_Enter (Obj : System.Address); + procedure Ghdl_Protected_Leave (Obj : System.Address); + procedure Ghdl_Protected_Init (Obj : System.Address); + procedure Ghdl_Protected_Fini (Obj : System.Address); + + type Run_Handler is access function return Integer; + + -- Run HAND through a wrapper that catch some errors (in particular on + -- windows). Returns < 0 in case of error. + function Run_Through_Longjump (Hand : Run_Handler) return Integer; + pragma Import (Ada, Run_Through_Longjump, "__ghdl_run_through_longjump"); + +private + -- State of a process. + type Process_State is + ( + -- Sensitized process. Its state cannot change. + State_Sensitized, + + -- Non-sensitized process, ready to run. + State_Ready, + + -- Verilog process, being suspended. + State_Delayed, + + -- Non-sensitized process being suspended. + State_Wait, + + -- Non-sensitized process being awaked by a wait timeout. This state + -- is transcient. + -- This is necessary so that the process will exit immediately from the + -- wait statements without checking if the wait condition is true. + State_Timeout, + + -- Non-sensitized process waiting until end. + State_Dead); + + type Process_Type is record + -- Stack for the process. + -- This must be the first field of the record (and this is the only + -- part visible). + -- Must be NULL_STACK for sensitized processes. + Stack : Stacks.Stack_Type; + + -- Subprogram containing process code. + Subprg : Proc_Acc; + + -- Instance (THIS parameter) for the subprogram. + This : Instance_Acc; + + -- Name of the process. + Rti : Rtis_Addr.Rti_Context; + + -- True if the process is resumed and will be run at next cycle. + Resumed : Boolean; + + -- True if the process is postponed. + Postponed : Boolean; + + State : Process_State; + + -- Timeout value for wait. + Timeout : Std_Time; + + -- Sensitivity list while the (non-sensitized) process is waiting. + Sensitivity : Action_List_Acc; + + Timeout_Chain_Next : Process_Acc; + Timeout_Chain_Prev : Process_Acc; + end record; + + pragma Export (C, Ghdl_Process_Register, + "__ghdl_process_register"); + pragma Export (C, Ghdl_Sensitized_Process_Register, + "__ghdl_sensitized_process_register"); + pragma Export (C, Ghdl_Postponed_Process_Register, + "__ghdl_postponed_process_register"); + pragma Export (C, Ghdl_Postponed_Sensitized_Process_Register, + "__ghdl_postponed_sensitized_process_register"); + + pragma Export (C, Ghdl_Finalize_Register, "__ghdl_finalize_register"); + + pragma Export (C, Ghdl_Always_Register, "__ghdl_always_register"); + pragma Export (C, Ghdl_Initial_Register, "__ghdl_initial_register"); + + pragma Export (C, Ghdl_Process_Add_Sensitivity, + "__ghdl_process_add_sensitivity"); + + pragma Export (C, Ghdl_Process_Wait_Exit, + "__ghdl_process_wait_exit"); + pragma Export (C, Ghdl_Process_Wait_Timeout, + "__ghdl_process_wait_timeout"); + pragma Export (C, Ghdl_Process_Wait_Add_Sensitivity, + "__ghdl_process_wait_add_sensitivity"); + pragma Export (C, Ghdl_Process_Wait_Set_Timeout, + "__ghdl_process_wait_set_timeout"); + pragma Export (Ada, Ghdl_Process_Wait_Suspend, + "__ghdl_process_wait_suspend"); + pragma Export (C, Ghdl_Process_Wait_Close, + "__ghdl_process_wait_close"); + + pragma Export (C, Ghdl_Process_Delay, "__ghdl_process_delay"); + + pragma Export (C, Ghdl_Stack2_Allocate, "__ghdl_stack2_allocate"); + pragma Export (C, Ghdl_Stack2_Mark, "__ghdl_stack2_mark"); + pragma Export (C, Ghdl_Stack2_Release, "__ghdl_stack2_release"); + + pragma Export (C, Ghdl_Protected_Enter, "__ghdl_protected_enter"); + pragma Export (C, Ghdl_Protected_Leave, "__ghdl_protected_leave"); + pragma Export (C, Ghdl_Protected_Init, "__ghdl_protected_init"); + pragma Export (C, Ghdl_Protected_Fini, "__ghdl_protected_fini"); +end Grt.Processes; diff --git a/src/grt/grt-readline.ads b/src/grt/grt-readline.ads new file mode 100644 index 000000000..1a3083981 --- /dev/null +++ b/src/grt/grt-readline.ads @@ -0,0 +1,30 @@ +-- Although being part of GRT, the readline binding should be independent of +-- it (for easier reuse). + +with System; use System; + +package Grt.Readline is + subtype Fat_String is String (Positive); + type Char_Ptr is access Fat_String; + pragma Convention (C, Char_Ptr); + -- A C string (which is NUL terminated) is represented as a (thin) access + -- to a fat string (a string whose range is 1 .. integer'Last). + -- The use of an access to a constrained array allows a representation + -- compatible with C. Indexing of object of that type is safe only for + -- indexes until the NUL character. + + function Readline (Prompt : Char_Ptr) return Char_Ptr; + function Readline (Prompt : Address) return Char_Ptr; + pragma Import (C, Readline); + + procedure Free (Buf : Char_Ptr); + pragma Import (C, Free); + + procedure Add_History (Line : Char_Ptr); + pragma Import (C, Add_History); + + function Strlen (Str : Char_Ptr) return Natural; + pragma Import (C, Strlen); + + pragma Linker_Options ("-lreadline"); +end Grt.Readline; diff --git a/src/grt/grt-rtis.adb b/src/grt/grt-rtis.adb new file mode 100644 index 000000000..26d976459 --- /dev/null +++ b/src/grt/grt-rtis.adb @@ -0,0 +1,45 @@ +-- GHDL Run Time (GRT) - Run Time Informations. +-- Copyright (C) 2013 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package body Grt.Rtis is + procedure Ghdl_Rti_Add_Package (Pkg : Ghdl_Rti_Access) is + begin + Ghdl_Rti_Top.Children (Ghdl_Rti_Top.Nbr_Child) := Pkg; + Ghdl_Rti_Top.Nbr_Child := Ghdl_Rti_Top.Nbr_Child + 1; + end Ghdl_Rti_Add_Package; + + procedure Ghdl_Rti_Add_Top (Max_Pkg : Ghdl_Index_Type; + Pkgs : Ghdl_Rti_Arr_Acc; + Top : Ghdl_Rti_Access; + Instance : Address) + is + pragma Unreferenced (Max_Pkg); + begin + Ghdl_Rti_Top.Parent := Top; + Ghdl_Rti_Top.Children := Pkgs; + Ghdl_Rti_Top_Instance := Instance; + end Ghdl_Rti_Add_Top; + +end Grt.Rtis; diff --git a/src/grt/grt-rtis.ads b/src/grt/grt-rtis.ads new file mode 100644 index 000000000..6bb76597e --- /dev/null +++ b/src/grt/grt-rtis.ads @@ -0,0 +1,379 @@ +-- GHDL Run Time (GRT) - Run Time Informations. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Types; use Grt.Types; +with Ada.Unchecked_Conversion; + +package Grt.Rtis is + pragma Preelaborate (Grt.Rtis); + + type Ghdl_Rtik is + (Ghdl_Rtik_Top, + Ghdl_Rtik_Library, -- use scalar + Ghdl_Rtik_Package, + Ghdl_Rtik_Package_Body, + Ghdl_Rtik_Entity, + Ghdl_Rtik_Architecture, + Ghdl_Rtik_Process, + Ghdl_Rtik_Block, + Ghdl_Rtik_If_Generate, + Ghdl_Rtik_For_Generate, + Ghdl_Rtik_Instance, --10 + Ghdl_Rtik_Constant, + Ghdl_Rtik_Iterator, + Ghdl_Rtik_Variable, + Ghdl_Rtik_Signal, + Ghdl_Rtik_File, -- 15 + Ghdl_Rtik_Port, + Ghdl_Rtik_Generic, + Ghdl_Rtik_Alias, + Ghdl_Rtik_Guard, + Ghdl_Rtik_Component, -- 20 + Ghdl_Rtik_Attribute, + Ghdl_Rtik_Type_B1, -- Enum + Ghdl_Rtik_Type_E8, + Ghdl_Rtik_Type_E32, + Ghdl_Rtik_Type_I32, -- 25 Scalar + Ghdl_Rtik_Type_I64, + Ghdl_Rtik_Type_F64, + Ghdl_Rtik_Type_P32, + Ghdl_Rtik_Type_P64, + Ghdl_Rtik_Type_Access, + Ghdl_Rtik_Type_Array, + Ghdl_Rtik_Type_Record, + Ghdl_Rtik_Type_File, + Ghdl_Rtik_Subtype_Scalar, + Ghdl_Rtik_Subtype_Array, + Ghdl_Rtik_Subtype_Unconstrained_Array, + Ghdl_Rtik_Subtype_Record, + Ghdl_Rtik_Subtype_Access, + Ghdl_Rtik_Type_Protected, + Ghdl_Rtik_Element, + Ghdl_Rtik_Unit64, + Ghdl_Rtik_Unitptr, + Ghdl_Rtik_Attribute_Transaction, + Ghdl_Rtik_Attribute_Quiet, + Ghdl_Rtik_Attribute_Stable, + Ghdl_Rtik_Error); + for Ghdl_Rtik'Size use 8; + + type Ghdl_Rti_Depth is range 0 .. 255; + for Ghdl_Rti_Depth'Size use 8; + + type Ghdl_Rti_U8 is mod 2 ** 8; + for Ghdl_Rti_U8'Size use 8; + + -- This structure is common to all RTI nodes. + type Ghdl_Rti_Common is record + -- Kind of the RTI, list is above. + Kind : Ghdl_Rtik; + + Depth : Ghdl_Rti_Depth; + + -- * array types and subtypes, record types, protected types: + -- bit 0: set for complex type + -- bit 1: set for anonymous type definition + -- bit 2: set only for physical type with non-static units (time) + -- * signals: + -- bit 0-3: mode (1: linkage, 2: buffer, 3 : out, 4 : inout, 5: in) + -- bit 4-5: kind (0 : none, 1 : register, 2 : bus) + -- bit 6: set if has 'active attributes + Mode : Ghdl_Rti_U8; + + -- * Types and subtypes definition: + -- maximum depth of all RTIs referenced. + -- * Others: + -- 0 + Max_Depth : Ghdl_Rti_Depth; + end record; + + type Ghdl_Rti_Access is access all Ghdl_Rti_Common; + + -- Fat array of rti accesses. + type Ghdl_Rti_Array is array (Ghdl_Index_Type) of Ghdl_Rti_Access; + type Ghdl_Rti_Arr_Acc is access Ghdl_Rti_Array; + + subtype Ghdl_Rti_Loc is Integer_Address; + Null_Rti_Loc : constant Ghdl_Rti_Loc := 0; + + type Ghdl_C_String_Array is array (Ghdl_Index_Type) of Ghdl_C_String; + type Ghdl_C_String_Array_Ptr is access Ghdl_C_String_Array; + + type Ghdl_Rtin_Block is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Loc : Ghdl_Rti_Loc; + Parent : Ghdl_Rti_Access; + Size : Ghdl_Index_Type; + Nbr_Child : Ghdl_Index_Type; + Children : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Block_Acc is access Ghdl_Rtin_Block; + function To_Ghdl_Rtin_Block_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Block_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Block_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Object is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Loc : Ghdl_Rti_Loc; + Obj_Type : Ghdl_Rti_Access; + end record; + type Ghdl_Rtin_Object_Acc is access Ghdl_Rtin_Object; + function To_Ghdl_Rtin_Object_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Object_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Object_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Instance is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Loc : Ghdl_Rti_Loc; + Parent : Ghdl_Rti_Access; + Instance : Ghdl_Rti_Access; + end record; + type Ghdl_Rtin_Instance_Acc is access Ghdl_Rtin_Instance; + function To_Ghdl_Rtin_Instance_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Instance_Acc); + + -- Must be kept in sync with grt.types.mode_signal_type. + Ghdl_Rti_Signal_Mode_Mask : constant Ghdl_Rti_U8 := 15; + Ghdl_Rti_Signal_Mode_None : constant Ghdl_Rti_U8 := 0; + Ghdl_Rti_Signal_Mode_Linkage : constant Ghdl_Rti_U8 := 1; + Ghdl_Rti_Signal_Mode_Buffer : constant Ghdl_Rti_U8 := 2; + Ghdl_Rti_Signal_Mode_Out : constant Ghdl_Rti_U8 := 3; + Ghdl_Rti_Signal_Mode_Inout : constant Ghdl_Rti_U8 := 4; + Ghdl_Rti_Signal_Mode_In : constant Ghdl_Rti_U8 := 5; + + Ghdl_Rti_Signal_Kind_Mask : constant Ghdl_Rti_U8 := 3 * 16; + Ghdl_Rti_Signal_Kind_Offset : constant Ghdl_Rti_U8 := 1 * 16; + Ghdl_Rti_Signal_Kind_No : constant Ghdl_Rti_U8 := 0 * 16; + Ghdl_Rti_Signal_Kind_Register : constant Ghdl_Rti_U8 := 1 * 16; + Ghdl_Rti_Signal_Kind_Bus : constant Ghdl_Rti_U8 := 2 * 16; + + Ghdl_Rti_Signal_Has_Active : constant Ghdl_Rti_U8 := 64; + + type Ghdl_Rtin_Component is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbr_Child : Ghdl_Index_Type; + Children : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Component_Acc is access Ghdl_Rtin_Component; + function To_Ghdl_Rtin_Component_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Component_Acc); + + type Ghdl_Rtin_Type_Enum is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbr : Ghdl_Index_Type; + -- Characters are represented as 'X', identifiers are represented as is, + -- extended identifiers are represented as is too. + Names : Ghdl_C_String_Array_Ptr; + end record; + type Ghdl_Rtin_Type_Enum_Acc is access Ghdl_Rtin_Type_Enum; + function To_Ghdl_Rtin_Type_Enum_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Enum_Acc); + + type Ghdl_Rtin_Type_Scalar is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + end record; + type Ghdl_Rtin_Type_Scalar_Acc is access Ghdl_Rtin_Type_Scalar; + function To_Ghdl_Rtin_Type_Scalar_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Scalar_Acc); + + type Ghdl_Rtin_Subtype_Scalar is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Basetype : Ghdl_Rti_Access; + Range_Loc : Ghdl_Rti_Loc; + end record; + type Ghdl_Rtin_Subtype_Scalar_Acc is access Ghdl_Rtin_Subtype_Scalar; + function To_Ghdl_Rtin_Subtype_Scalar_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Scalar_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Subtype_Scalar_Acc, Target => Ghdl_Rti_Access); + + -- True if the type is complex, set in Mode field. + Ghdl_Rti_Type_Complex_Mask : constant Ghdl_Rti_U8 := 1; + Ghdl_Rti_Type_Complex : constant Ghdl_Rti_U8 := 1; + + -- True if the type is anonymous + Ghdl_Rti_Type_Anonymous_Mask : constant Ghdl_Rti_U8 := 2; + Ghdl_Rti_Type_Anonymous : constant Ghdl_Rti_U8 := 2; + + type Ghdl_Rtin_Type_Array is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Element : Ghdl_Rti_Access; + Nbr_Dim : Ghdl_Index_Type; + Indexes : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Type_Array_Acc is access Ghdl_Rtin_Type_Array; + function To_Ghdl_Rtin_Type_Array_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Array_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Type_Array_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Subtype_Array is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Basetype : Ghdl_Rtin_Type_Array_Acc; + Bounds : Ghdl_Rti_Loc; + Valsize : Ghdl_Rti_Loc; + Sigsize : Ghdl_Rti_Loc; + end record; + type Ghdl_Rtin_Subtype_Array_Acc is access Ghdl_Rtin_Subtype_Array; + function To_Ghdl_Rtin_Subtype_Array_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Array_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Subtype_Array_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Type_Fileacc is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Base : Ghdl_Rti_Access; + end record; + type Ghdl_Rtin_Type_Fileacc_Acc is access Ghdl_Rtin_Type_Fileacc; + function To_Ghdl_Rtin_Type_Fileacc_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Fileacc_Acc); + + type Ghdl_Rtin_Element is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Eltype : Ghdl_Rti_Access; + Val_Off : Ghdl_Index_Type; + Sig_Off : Ghdl_Index_Type; + end record; + type Ghdl_Rtin_Element_Acc is access Ghdl_Rtin_Element; + function To_Ghdl_Rtin_Element_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Element_Acc); + + type Ghdl_Rtin_Type_Record is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbrel : Ghdl_Index_Type; + Elements : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Type_Record_Acc is access Ghdl_Rtin_Type_Record; + function To_Ghdl_Rtin_Type_Record_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Record_Acc); + + type Ghdl_Rtin_Unit64 is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Value : Ghdl_I64; + end record; + type Ghdl_Rtin_Unit64_Acc is access Ghdl_Rtin_Unit64; + function To_Ghdl_Rtin_Unit64_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unit64_Acc); + + type Ghdl_Rtin_Unitptr is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Addr : Ghdl_Value_Ptr; + end record; + type Ghdl_Rtin_Unitptr_Acc is access Ghdl_Rtin_Unitptr; + function To_Ghdl_Rtin_Unitptr_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unitptr_Acc); + + -- Mode field is set to 4 if units value is per address. Otherwise, + -- mode is 0. + type Ghdl_Rtin_Type_Physical is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbr : Ghdl_Index_Type; + Units : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Type_Physical_Acc is access Ghdl_Rtin_Type_Physical; + function To_Ghdl_Rtin_Type_Physical_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Physical_Acc); + + -- Instance linkage. + + -- At the beginning of a component structure (or the object for a direct + -- instantiation), there is a Ghdl_Component_Link_Type record. + -- These record contains a pointer to the instance (down link), + -- and RTIS to the statement and its parent (up link). + type Ghdl_Component_Link_Type; + type Ghdl_Component_Link_Acc is access Ghdl_Component_Link_Type; + + -- At the beginning of an entity structure, there is a Ghdl_Link_Type, + -- which contains the RTI for the architecture (down-link) and a pointer + -- to the instantiation object (up-link). + type Ghdl_Entity_Link_Type is record + Rti : Ghdl_Rti_Access; + Parent : Ghdl_Component_Link_Acc; + end record; + + type Ghdl_Entity_Link_Acc is access Ghdl_Entity_Link_Type; + + function To_Ghdl_Entity_Link_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Entity_Link_Acc); + + type Ghdl_Component_Link_Type is record + Instance : Ghdl_Entity_Link_Acc; + Stmt : Ghdl_Rti_Access; + end record; + + function To_Ghdl_Component_Link_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Component_Link_Acc); + + -- TOP rti. + Ghdl_Rti_Top : Ghdl_Rtin_Block := + (Common => (Ghdl_Rtik_Top, 0, 0, 0), + Name => null, + Loc => Null_Rti_Loc, + Parent => null, + Size => 0, + Nbr_Child => 0, + Children => null); + + -- Address of the top instance. + Ghdl_Rti_Top_Instance : Address; + + -- Instances have a pointer to their RTI at offset 0. + type Ghdl_Rti_Acc_Acc is access Ghdl_Rti_Access; + function To_Ghdl_Rti_Acc_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Rti_Acc_Acc); + + function To_Address is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Address); + + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Rti_Access); + + procedure Ghdl_Rti_Add_Top (Max_Pkg : Ghdl_Index_Type; + Pkgs : Ghdl_Rti_Arr_Acc; + Top : Ghdl_Rti_Access; + Instance : Address); + pragma Export (C, Ghdl_Rti_Add_Top, "__ghdl_rti_add_top"); + + -- Register a package + procedure Ghdl_Rti_Add_Package (Pkg : Ghdl_Rti_Access); + pragma Export (C, Ghdl_Rti_Add_Package, "__ghdl_rti_add_package"); +end Grt.Rtis; diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb new file mode 100644 index 000000000..70a0e2118 --- /dev/null +++ b/src/grt/grt-rtis_addr.adb @@ -0,0 +1,299 @@ +-- GHDL Run Time (GRT) - RTI address handling. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; + +package body Grt.Rtis_Addr is + function "+" (L : Address; R : Ghdl_Rti_Loc) return Address + is + begin + return To_Address (To_Integer (L) + R); + end "+"; + + function "+" (L : Address; R : Ghdl_Index_Type) return Address + is + begin + return To_Address (To_Integer (L) + Integer_Address (R)); + end "+"; + + function "-" (L : Address; R : Ghdl_Rti_Loc) return Address + is + begin + return To_Address (To_Integer (L) - R); + end "-"; + + function Align (L : Address; R : Ghdl_Rti_Loc) return Address + is + Nad : Integer_Address; + begin + Nad := To_Integer (L + (R - 1)); + return To_Address (Nad - (Nad mod R)); + end Align; + + function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context + is + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Ctxt.Block.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + return (Base => Ctxt.Base - Blk.Loc, + Block => Blk.Parent); + when Ghdl_Rtik_Architecture => + if Blk.Loc /= Null_Rti_Loc then + Internal_Error ("get_parent_context(3)"); + end if; + return (Base => Ctxt.Base + Blk.Loc, + Block => Blk.Parent); + when Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate => + declare + Nbase : Address; + Parent : Ghdl_Rti_Access; + Blk1 : Ghdl_Rtin_Block_Acc; + begin + -- Read the pointer to the parent. + -- This is the first field. + Nbase := To_Addr_Acc (Ctxt.Base).all; + -- Since the parent may be a grant-parent, adjust + -- the base. + Parent := Blk.Parent; + loop + case Parent.Kind is + when Ghdl_Rtik_Architecture + | Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate => + exit; + when Ghdl_Rtik_Block => + Blk1 := To_Ghdl_Rtin_Block_Acc (Parent); + Nbase := Nbase + Blk1.Loc; + Parent := Blk1.Parent; + when others => + Internal_Error ("get_parent_context(2)"); + end case; + end loop; + return (Base => Nbase, + Block => Blk.Parent); + end; + when others => + Internal_Error ("get_parent_context(1)"); + end case; + end Get_Parent_Context; + + procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc; + Ctxt : out Rti_Context; + Stmt : out Ghdl_Rti_Access) + is + Obj : Ghdl_Rtin_Instance_Acc; + begin + if Link.Parent = null then + -- Top entity. + Stmt := null; + Ctxt := (Base => Null_Address, Block => null); + else + Stmt := Link.Parent.Stmt; + Obj := To_Ghdl_Rtin_Instance_Acc (Stmt); + Ctxt := (Base => Link.Parent.all'Address - Obj.Loc, + Block => Obj.Parent); + end if; + end Get_Instance_Link; + + function Loc_To_Addr (Depth : Ghdl_Rti_Depth; + Loc : Ghdl_Rti_Loc; + Ctxt : Rti_Context) + return Address + is + Cur_Ctxt : Rti_Context; + Nctxt : Rti_Context; + begin + if Depth = 0 then + return To_Address (Loc); + elsif Ctxt.Block.Depth = Depth then + --Addr := Base + Storage_Offset (Obj.Loc.Off); + return Ctxt.Base + Loc; + else + if Ctxt.Block.Depth < Depth then + Internal_Error ("loc_to_addr"); + end if; + Cur_Ctxt := Ctxt; + loop + Nctxt := Get_Parent_Context (Cur_Ctxt); + if Nctxt.Block.Depth = Depth then + return Nctxt.Base + Loc; + end if; + Cur_Ctxt := Nctxt; + end loop; + end if; + end Loc_To_Addr; + + function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access) + return Ghdl_Index_Type + is + begin + case Base_Type.Kind is + when Ghdl_Rtik_Type_B1 => + return Rng.B1.Len; + when Ghdl_Rtik_Type_E8 => + return Rng.E8.Len; + when Ghdl_Rtik_Type_E32 => + return Rng.E32.Len; + when Ghdl_Rtik_Type_I32 => + return Rng.I32.Len; + when others => + Internal_Error ("range_to_length"); + end case; + end Range_To_Length; + + function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context) + return Ghdl_Index_Type + is + Iter_Type : Ghdl_Rtin_Subtype_Scalar_Acc; + Rng : Ghdl_Range_Ptr; + begin + Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc + (To_Ghdl_Rtin_Object_Acc (Blk.Children (0)).Obj_Type); + if Iter_Type.Common.Kind /= Ghdl_Rtik_Subtype_Scalar then + Internal_Error ("get_for_generate_length(1)"); + end if; + Rng := To_Ghdl_Range_Ptr + (Loc_To_Addr (Iter_Type.Common.Depth, Iter_Type.Range_Loc, Ctxt)); + return Range_To_Length (Rng, Iter_Type.Basetype); + end Get_For_Generate_Length; + + procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc; + Ctxt : Rti_Context; + Sub_Ctxt : out Rti_Context) + is + Inst_Addr : Address; + Inst_Base : Address; + begin + -- Address of the field containing the address of the instance. + Inst_Addr := Ctxt.Base + Inst.Loc; + -- Read sub instance address. + Inst_Base := To_Addr_Acc (Inst_Addr).all; + -- Read instance RTI. + if Inst_Base = Null_Address then + Sub_Ctxt := (Base => Null_Address, Block => null); + else + Sub_Ctxt := (Base => Inst_Base, + Block => To_Ghdl_Rti_Acc_Acc (Inst_Base).all); + end if; + end Get_Instance_Context; + + procedure Bound_To_Range (Bounds_Addr : Address; + Def : Ghdl_Rtin_Type_Array_Acc; + Res : out Ghdl_Range_Array) + is + Bounds : Address; + + procedure Align (A : Ghdl_Index_Type) is + begin + Bounds := Align (Bounds, Ghdl_Rti_Loc (A)); + end Align; + + procedure Update (S : Ghdl_Index_Type) is + begin + Bounds := Bounds + (S / Storage_Unit); + end Update; + + Idx_Def : Ghdl_Rti_Access; + begin + if Res'Length /= Def.Nbr_Dim or else Res'First /= 0 then + Internal_Error ("disp_rti.bound_to_range"); + end if; + + Bounds := Bounds_Addr; + + for I in 0 .. Def.Nbr_Dim - 1 loop + Idx_Def := Def.Indexes (I); + + if Bounds = Null_Address then + Res (I) := null; + else + Idx_Def := Get_Base_Type (Idx_Def); + case Idx_Def.Kind is + when Ghdl_Rtik_Type_I32 => + Align (Ghdl_Range_I32'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_I32'Size); + when Ghdl_Rtik_Type_E8 => + Align (Ghdl_Range_E8'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_E8'Size); + when Ghdl_Rtik_Type_E32 => + Align (Ghdl_Range_E32'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_E32'Size); + when others => + -- Bounds are not known anymore. + Bounds := Null_Address; + end case; + end if; + end loop; + end Bound_To_Range; + + function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access + is + begin + case Atype.Kind is + when Ghdl_Rtik_Subtype_Scalar => + return To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype; + when Ghdl_Rtik_Subtype_Array => + return To_Ghdl_Rti_Access + (To_Ghdl_Rtin_Subtype_Array_Acc (Atype).Basetype); + when Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + return Atype; + when others => + Internal_Error ("rtis_addr.get_base_type"); + end case; + end Get_Base_Type; + + function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean + is + begin + return (Atype.Mode and Ghdl_Rti_Type_Complex_Mask) + = Ghdl_Rti_Type_Complex; + end Rti_Complex_Type; + + function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean + is + begin + return (Atype.Mode and Ghdl_Rti_Type_Anonymous_Mask) + = Ghdl_Rti_Type_Anonymous; + end Rti_Anonymous_Type; + + function Get_Top_Context return Rti_Context + is + Ctxt : Rti_Context; + begin + Ctxt := (Base => Ghdl_Rti_Top_Instance, + Block => Ghdl_Rti_Top.Parent); + return Ctxt; + end Get_Top_Context; + +end Grt.Rtis_Addr; diff --git a/src/grt/grt-rtis_addr.ads b/src/grt/grt-rtis_addr.ads new file mode 100644 index 000000000..3fa2792af --- /dev/null +++ b/src/grt/grt-rtis_addr.ads @@ -0,0 +1,110 @@ +-- GHDL Run Time (GRT) - RTI address handling. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Ada.Unchecked_Conversion; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +-- Addresses handling. +package Grt.Rtis_Addr is + function "+" (L : Address; R : Ghdl_Rti_Loc) return Address; + function "+" (L : Address; R : Ghdl_Index_Type) return Address; + + function "-" (L : Address; R : Ghdl_Rti_Loc) return Address; + + function Align (L : Address; R : Ghdl_Rti_Loc) return Address; + + -- An RTI context contains a pointer (BASE) to or into an instance. + -- BLOCK describes data being pointed. If a reference is made to a field + -- described by a parent of BLOCK, BASE must be modified. + type Rti_Context is record + Base : Address; + Block : Ghdl_Rti_Access; + end record; + + Null_Context : constant Rti_Context; + + -- Access to an address. + type Addr_Acc is access Address; + function To_Addr_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Addr_Acc); + + type Ghdl_Index_Acc is access Ghdl_Index_Type; + function To_Ghdl_Index_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Index_Acc); + + -- Get the parent context of CTXT. + -- The parent of an architecture is its entity. + function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context; + + -- From an entity link, extract context and instantiation statement. + procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc; + Ctxt : out Rti_Context; + Stmt : out Ghdl_Rti_Access); + + -- Convert a location to an address. + function Loc_To_Addr (Depth : Ghdl_Rti_Depth; + Loc : Ghdl_Rti_Loc; + Ctxt : Rti_Context) + return Address; + + -- Get the length of for_generate BLK. + function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context) + return Ghdl_Index_Type; + + -- Get the context of instance INST. + procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc; + Ctxt : Rti_Context; + Sub_Ctxt : out Rti_Context); + + -- Extract range of every dimension from bounds. + procedure Bound_To_Range (Bounds_Addr : Address; + Def : Ghdl_Rtin_Type_Array_Acc; + Res : out Ghdl_Range_Array); + + function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access) + return Ghdl_Index_Type; + + -- Get the base type of ATYPE. + function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access; + + -- Return true iff ATYPE is anonymous. + -- Valid only on type and subtype definitions. + function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean; + pragma Inline (Rti_Anonymous_Type); + + -- Return true iff ATYPE is complex. + -- Valid only on type and subtype definitions. + function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean; + pragma Inline (Rti_Complex_Type); + + -- Get the top context. + function Get_Top_Context return Rti_Context; + +private + Null_Context : constant Rti_Context := (Base => Null_Address, + Block => null); +end Grt.Rtis_Addr; diff --git a/src/grt/grt-rtis_binding.ads b/src/grt/grt-rtis_binding.ads new file mode 100644 index 000000000..7e90eeafc --- /dev/null +++ b/src/grt/grt-rtis_binding.ads @@ -0,0 +1,67 @@ +-- GHDL Run Time (GRT) - Well known RTIs. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Rtis; use Grt.Rtis; + +-- Set RTI_ptr defined in grt.rtis_types. + +package Grt.Rtis_Binding is + pragma Preelaborate (Grt.Rtis_Binding); + + -- Define and set bit and boolean RTIs. + Std_Standard_Bit_RTI : aliased Ghdl_Rti_Common; + + Std_Standard_Boolean_RTI : aliased Ghdl_Rti_Common; + + pragma Import (C, Std_Standard_Bit_RTI, + "std__standard__bit__RTI"); + + pragma Import (C, Std_Standard_Boolean_RTI, + "std__standard__boolean__RTI"); + + Std_Standard_Bit_RTI_Ptr : Ghdl_Rti_Access + := Std_Standard_Bit_RTI'Access; + + Std_Standard_Boolean_RTI_Ptr : Ghdl_Rti_Access + := Std_Standard_Boolean_RTI'Access; + + pragma Export (C, Std_Standard_Bit_RTI_Ptr, + "std__standard__bit__RTI_ptr"); + + pragma Export (C, Std_Standard_Boolean_RTI_Ptr, + "std__standard__boolean__RTI_ptr"); + + + -- Define and set Resolved_Resolv_Ptr. + procedure Ieee_Std_Logic_1164_Resolved_RESOLV; + pragma Import (C, Ieee_Std_Logic_1164_Resolved_RESOLV, + "ieee__std_logic_1164__resolved_RESOLV"); + + Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address := + Ieee_Std_Logic_1164_Resolved_RESOLV'Address; + pragma Export (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr, + "ieee__std_logic_1164__resolved_RESOLV_ptr"); + +end Grt.Rtis_Binding; diff --git a/src/grt/grt-rtis_types.adb b/src/grt/grt-rtis_types.adb new file mode 100644 index 000000000..f22a309bc --- /dev/null +++ b/src/grt/grt-rtis_types.adb @@ -0,0 +1,118 @@ +-- GHDL Run Time (GRT) - Well known RTI types. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Astdio; +with Grt.Avhpi; use Grt.Avhpi; + +package body Grt.Rtis_Types is + + procedure Avhpi_Error (Err : AvhpiErrorT) + is + use Grt.Astdio; + pragma Unreferenced (Err); + begin + Put_Line ("grt.rtis_utils.Avhpi_Error!"); + end Avhpi_Error; + + -- Extract std_ulogic type. + procedure Search_Types (Pack : VhpiHandleT) + is + Decl_It : VhpiHandleT; + Decl : VhpiHandleT; + + Error : AvhpiErrorT; + Name : String (1 .. 16); + Name_Len : Natural; + Rti : Ghdl_Rti_Access; + begin + Vhpi_Get_Str (VhpiLibLogicalNameP, Pack, Name, Name_Len); + if not (Name_Len = 4 and then Name (1 .. 4)= "ieee") then + return; + end if; + + Vhpi_Iterator (VhpiDecls, Pack, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + -- Extract packages. + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + if Vhpi_Get_Kind (Decl) = VhpiEnumTypeDeclK then + Vhpi_Get_Str (VhpiNameP, Decl, Name, Name_Len); + Rti := Avhpi_Get_Rti (Decl); + if Name_Len = 10 and then Name (1 .. 10) = "std_ulogic" then + Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr := Rti; + end if; + end if; + end loop; + end Search_Types; + + procedure Search_Packages + is + Pack : VhpiHandleT; + Pack_It : VhpiHandleT; + + Error : AvhpiErrorT; + Name : String (1 .. 16); + Name_Len : Natural; + begin + Get_Package_Inst (Pack_It); + + -- Extract packages. + loop + Vhpi_Scan (Pack_It, Pack, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Vhpi_Get_Str (VhpiNameP, Pack, Name, Name_Len); + if Name_Len = 14 and then Name (1 .. 14) = "std_logic_1164" then + Search_Types (Pack); + end if; + end loop; + end Search_Packages; + + Search_Types_RTI_Done : Boolean := False; + + procedure Search_Types_RTI is + begin + if Search_Types_RTI_Done then + return; + else + Search_Types_RTI_Done := True; + end if; + + Search_Packages; + end Search_Types_RTI; +end Grt.Rtis_Types; diff --git a/src/grt/grt-rtis_types.ads b/src/grt/grt-rtis_types.ads new file mode 100644 index 000000000..f64b17324 --- /dev/null +++ b/src/grt/grt-rtis_types.ads @@ -0,0 +1,55 @@ +-- GHDL Run Time (GRT) - Well known RTI types. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Rtis; use Grt.Rtis; + +-- This package allow access to RTIs of some types. +-- This is used to recognize some VHDL logic types. +-- This is also used by grt.signals to set types of some implicit signals +-- (such as 'stable or 'transation). + +package Grt.Rtis_Types is + -- RTIs for some logic types. + Std_Standard_Bit_RTI_Ptr : Ghdl_Rti_Access; + + Std_Standard_Boolean_RTI_Ptr : Ghdl_Rti_Access; + + -- std_ulogic. + -- A VHDL may not contain ieee.std_logic_1164 package. So, this RTI + -- must be dynamicaly searched. + Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr : Ghdl_Rti_Access := null; + + -- Search RTI for types. + -- If a type is not found, its RTI is set to null. + -- If this procedure has already been called, then this is a noop. + procedure Search_Types_RTI; +private + -- These are set either by grt.rtis_binding or by ghdlrun. + -- This is not very clean... + pragma Import (C, Std_Standard_Bit_RTI_Ptr, + "std__standard__bit__RTI_ptr"); + + pragma Import (C, Std_Standard_Boolean_RTI_Ptr, + "std__standard__boolean__RTI_ptr"); +end Grt.Rtis_Types; diff --git a/src/grt/grt-rtis_utils.adb b/src/grt/grt-rtis_utils.adb new file mode 100644 index 000000000..0d4328e7e --- /dev/null +++ b/src/grt/grt-rtis_utils.adb @@ -0,0 +1,660 @@ +-- GHDL Run Time (GRT) - RTI utilities. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +--with Grt.Disp; use Grt.Disp; +with Grt.Errors; use Grt.Errors; + +package body Grt.Rtis_Utils is + + function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result + is + function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result; + + function Traverse_Blocks_1 (Ctxt : Rti_Context) return Traverse_Result + is + Blk : Ghdl_Rtin_Block_Acc; + + Res : Traverse_Result; + Nctxt : Rti_Context; + Index : Ghdl_Index_Type; + Child : Ghdl_Rti_Access; + begin + Res := Process (Ctxt, Ctxt.Block); + if Res /= Traverse_Ok then + return Res; + end if; + + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + Index := 0; + while Index < Blk.Nbr_Child loop + Child := Blk.Children (Index); + Index := Index + 1; + case Child.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + declare + Nblk : Ghdl_Rtin_Block_Acc; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := (Base => Ctxt.Base + Nblk.Loc, + Block => Child); + Res := Traverse_Blocks_1 (Nctxt); + end; + when Ghdl_Rtik_For_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc; + Length : Ghdl_Index_Type; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := + (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + Length := Get_For_Generate_Length (Nblk, Ctxt); + for I in 1 .. Length loop + Res := Traverse_Blocks_1 (Nctxt); + exit when Res = Traverse_Stop; + Nctxt.Base := Nctxt.Base + Nblk.Size; + end loop; + end; + when Ghdl_Rtik_If_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := + (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + if Nctxt.Base /= Null_Address then + Res := Traverse_Blocks_1 (Nctxt); + end if; + end; + when Ghdl_Rtik_Instance => + Res := Process (Ctxt, Child); + if Res = Traverse_Ok then + declare + Obj : Ghdl_Rtin_Instance_Acc; + begin + Obj := To_Ghdl_Rtin_Instance_Acc (Child); + + Get_Instance_Context (Obj, Ctxt, Nctxt); + if Nctxt /= Null_Context then + Res := Traverse_Instance (Nctxt); + end if; + end; + end if; + when Ghdl_Rtik_Package + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture => + Internal_Error ("traverse_blocks"); + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Res := Process (Ctxt, Child); + when others => + null; + end case; + exit when Res = Traverse_Stop; + end loop; + + return Res; + end Traverse_Blocks_1; + + function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result + is + Blk : Ghdl_Rtin_Block_Acc; + + Res : Traverse_Result; + Nctxt : Rti_Context; + + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + -- The entity. + Res := Traverse_Blocks_1 (Nctxt); + if Res /= Traverse_Stop then + -- The architecture. + Res := Traverse_Blocks_1 (Ctxt); + end if; + when Ghdl_Rtik_Package_Body => + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + Res := Traverse_Blocks_1 (Nctxt); + when others => + Internal_Error ("traverse_blocks"); + end case; + return Res; + end Traverse_Instance; + begin + return Traverse_Instance (Ctxt); + end Traverse_Blocks; + + -- Disp value stored at ADDR and whose type is described by RTI. + procedure Get_Enum_Value + (Vstr : in out Vstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Append (Vstr, Enum_Rti.Names (Val)); + end Get_Enum_Value; + + + procedure Foreach_Scalar (Ctxt : Rti_Context; + Obj_Type : Ghdl_Rti_Access; + Obj_Addr : Address; + Is_Sig : Boolean; + Param : Param_Type) + is + -- Current address. + Addr : Address; + + Name : Vstring; + + procedure Handle_Any (Rti : Ghdl_Rti_Access); + + procedure Handle_Scalar (Rti : Ghdl_Rti_Access) + is + procedure Update (S : Ghdl_Index_Type) is + begin + Addr := Addr + (S / Storage_Unit); + end Update; + begin + Process (Addr, Name, Rti, Param); + + if Is_Sig then + Update (Address'Size); + else + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + Update (32); + when Ghdl_Rtik_Type_E8 => + Update (8); + when Ghdl_Rtik_Type_E32 => + Update (32); + when Ghdl_Rtik_Type_B1 => + Update (8); + when Ghdl_Rtik_Type_F64 => + Update (64); + when Ghdl_Rtik_Type_P64 => + Update (64); + when others => + Internal_Error ("handle_scalar"); + end case; + end if; + end Handle_Scalar; + + procedure Range_Pos_To_Val (Rti : Ghdl_Rti_Access; + Rng : Ghdl_Range_Ptr; + Pos : Ghdl_Index_Type; + Val : out Value_Union) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + case Rng.I32.Dir is + when Dir_To => + Val.I32 := Rng.I32.Left + Ghdl_I32 (Pos); + when Dir_Downto => + Val.I32 := Rng.I32.Left - Ghdl_I32 (Pos); + end case; + when Ghdl_Rtik_Type_E8 => + case Rng.E8.Dir is + when Dir_To => + Val.E8 := Rng.E8.Left + Ghdl_E8 (Pos); + when Dir_Downto => + Val.E8 := Rng.E8.Left - Ghdl_E8 (Pos); + end case; + when Ghdl_Rtik_Type_E32 => + case Rng.E32.Dir is + when Dir_To => + Val.E32 := Rng.E32.Left + Ghdl_E32 (Pos); + when Dir_Downto => + Val.E32 := Rng.E32.Left - Ghdl_E32 (Pos); + end case; + when Ghdl_Rtik_Type_B1 => + case Pos is + when 0 => + Val.B1 := Rng.B1.Left; + when 1 => + Val.B1 := Rng.B1.Right; + when others => + Val.B1 := False; + end case; + when others => + Internal_Error ("grt.rtis_utils.range_pos_to_val"); + end case; + end Range_Pos_To_Val; + + procedure Pos_To_Vstring + (Vstr : in out Vstring; + Rti : Ghdl_Rti_Access; + Rng : Ghdl_Range_Ptr; + Pos : Ghdl_Index_Type) + is + V : Value_Union; + begin + Range_Pos_To_Val (Rti, Rng, Pos, V); + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, V.I32); + Append (Vstr, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value (Vstr, Rti, Ghdl_B1'Pos (V.B1)); + when others => + Append (Vstr, '?'); + end case; + end Pos_To_Vstring; + + procedure Handle_Array_1 (El_Rti : Ghdl_Rti_Access; + Rngs : Ghdl_Range_Array; + Rtis : Ghdl_Rti_Arr_Acc; + Index : Ghdl_Index_Type) + is + Len : Ghdl_Index_Type; + P : Natural; + Base_Type : Ghdl_Rti_Access; + begin + P := Length (Name); + if Index = 0 then + Append (Name, '('); + else + Append (Name, ','); + end if; + + Base_Type := Get_Base_Type (Rtis (Index)); + Len := Range_To_Length (Rngs (Index), Base_Type); + + for I in 1 .. Len loop + Pos_To_Vstring (Name, Base_Type, Rngs (Index), I - 1); + if Index = Rngs'Last then + Append (Name, ')'); + Handle_Any (El_Rti); + else + Handle_Array_1 (El_Rti, Rngs, Rtis, Index + 1); + end if; + Truncate (Name, P + 1); + end loop; + Truncate (Name, P); + end Handle_Array_1; + + procedure Handle_Array (Rti : Ghdl_Rtin_Type_Array_Acc; + Vals : Ghdl_Uc_Array_Acc) + is + Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; + Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); + begin + Bound_To_Range (Vals.Bounds, Rti, Rngs); + Addr := Vals.Base; + Handle_Array_1 (Rti.Element, Rngs, Rti.Indexes, 0); + end Handle_Array; + + procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc) + is + El : Ghdl_Rtin_Element_Acc; + Obj_Addr : Address; + Last_Addr : Address; + P : Natural; + begin + P := Length (Name); + Obj_Addr := Addr; + Last_Addr := Addr; + for I in 1 .. Rti.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); + if Is_Sig then + Addr := Obj_Addr + El.Sig_Off; + else + Addr := Obj_Addr + El.Val_Off; + end if; + if Rti_Complex_Type (El.Eltype) then + Addr := Obj_Addr + To_Ghdl_Index_Acc (Addr).all; + end if; + Append (Name, '.'); + Append (Name, El.Name); + Handle_Any (El.Eltype); + if Addr > Last_Addr then + Last_Addr := Addr; + end if; + Truncate (Name, P); + end loop; + Addr := Last_Addr; + end Handle_Record; + + procedure Handle_Any (Rti : Ghdl_Rti_Access) is + begin + case Rti.Kind is + when Ghdl_Rtik_Subtype_Scalar => + Handle_Scalar (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + Handle_Scalar (Rti); + when Ghdl_Rtik_Type_Array => + Handle_Array (To_Ghdl_Rtin_Type_Array_Acc (Rti), + To_Ghdl_Uc_Array_Acc (Addr)); + when Ghdl_Rtik_Subtype_Array => + declare + St : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); + Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0); + end; +-- when Ghdl_Rtik_Type_File => +-- declare +-- Vptr : Ghdl_Value_Ptr; +-- begin +-- Vptr := To_Ghdl_Value_Ptr (Obj); +-- Put (Stream, "File#"); +-- Put_I32 (Stream, Vptr.I32); +-- -- FIXME: update OBJ (not very useful since never in a +-- -- composite type). +-- end; + when Ghdl_Rtik_Type_Record => + Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti)); + when others => + Internal_Error ("grt.rtis_utils.foreach_scalar.handle_any"); + end case; + end Handle_Any; + begin + if Rti_Complex_Type (Obj_Type) then + Addr := To_Addr_Acc (Obj_Addr).all; + else + Addr := Obj_Addr; + end if; + Handle_Any (Obj_Type); + Free (Name); + end Foreach_Scalar; + + procedure Get_Value (Str : in out Vstring; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access) + is + begin + case Type_Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Append (Str, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value + (Str, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1))); + when Ghdl_Rtik_Type_F64 => + declare + S : String (1 .. 32); + L : Integer; + + function Snprintf_G (Cstr : Address; + Size : Natural; + Arg : Ghdl_F64) + return Integer; + pragma Import (C, Snprintf_G, "__ghdl_snprintf_g"); + + begin + L := Snprintf_G (S'Address, S'Length, Value.F64); + if L < 0 then + -- FIXME. + Append (Str, "?"); + else + Append (Str, S (1 .. L)); + end if; + end; + when Ghdl_Rtik_Type_P32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Append (Str, S (F .. S'Last)); + Append + (Str, Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0))); + end; + when Ghdl_Rtik_Type_P64 => + declare + S : String (1 .. 21); + F : Natural; + begin + To_String (S, F, Value.I64); + Append (Str, S (F .. S'Last)); + Append + (Str, Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0))); + end; + when others => + Internal_Error ("grt.rtis_utils.get_value"); + end case; + end Get_Value; + + procedure Disp_Value (Stream : FILEs; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access) + is + Name : Vstring; + begin + Rtis_Utils.Get_Value (Name, Value, Type_Rti); + Put (Stream, Name); + Free (Name); + end Disp_Value; + + function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access) + return Ghdl_C_String + is + begin + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + return To_Ghdl_Rtin_Unit64_Acc (Unit).Name; + when Ghdl_Rtik_Unitptr => + return To_Ghdl_Rtin_Unitptr_Acc (Unit).Name; + when others => + Internal_Error ("rtis_utils.physical_unit_name"); + end case; + end Get_Physical_Unit_Name; + + function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access; + Type_Rti : Ghdl_Rti_Access) + return Ghdl_I64 is + begin + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + return To_Ghdl_Rtin_Unit64_Acc (Unit).Value; + when Ghdl_Rtik_Unitptr => + case Type_Rti.Kind is + when Ghdl_Rtik_Type_P64 => + return To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64; + when Ghdl_Rtik_Type_P32 => + return Ghdl_I64 + (To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32); + when others => + Internal_Error ("get_physical_unit_value(1)"); + end case; + when others => + Internal_Error ("get_physical_unit_value(2)"); + end case; + end Get_Physical_Unit_Value; + + procedure Get_Enum_Value + (Rstr : in out Rstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Prepend (Rstr, Enum_Rti.Names (Val)); + end Get_Enum_Value; + + + procedure Get_Value (Rstr : in out Rstring; + Addr : Address; + Type_Rti : Ghdl_Rti_Access) + is + Value : constant Ghdl_Value_Ptr := To_Ghdl_Value_Ptr (Addr); + begin + case Type_Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Prepend (Rstr, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value + (Rstr, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1))); + when others => + Internal_Error ("grt.rtis_utils.get_value(rstr)"); + end case; + end Get_Value; + + procedure Get_Path_Name (Rstr : in out Rstring; + Last_Ctxt : Rti_Context; + Sep : Character; + Is_Instance : Boolean := True) + is + Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context; + begin + Ctxt := Last_Ctxt; + loop + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Ctxt.Block.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate => + Prepend (Rstr, Blk.Name); + Prepend (Rstr, Sep); + Ctxt := Get_Parent_Context (Ctxt); + when Ghdl_Rtik_Entity => + declare + Link : Ghdl_Entity_Link_Acc; + begin + Link := To_Ghdl_Entity_Link_Acc (Ctxt.Base); + Ctxt := (Base => Ctxt.Base, + Block => Link.Rti); + if Ctxt.Block = null then + -- Process in an entity. + -- FIXME: check. + Prepend (Rstr, Blk.Name); + return; + end if; + end; + when Ghdl_Rtik_Architecture => + declare + Entity_Ctxt: Rti_Context; + Link : Ghdl_Entity_Link_Acc; + Parent_Inst : Ghdl_Rti_Access; + begin + -- Architecture name. + if Is_Instance then + Prepend (Rstr, ')'); + Prepend (Rstr, Blk.Name); + Prepend (Rstr, '('); + end if; + + Entity_Ctxt := Get_Parent_Context (Ctxt); + + -- Instance parent. + Link := To_Ghdl_Entity_Link_Acc (Entity_Ctxt.Base); + Get_Instance_Link (Link, Ctxt, Parent_Inst); + + -- Add entity name. + if Is_Instance or Parent_Inst = null then + Prepend (Rstr, + To_Ghdl_Rtin_Block_Acc (Entity_Ctxt.Block).Name); + end if; + + if Parent_Inst = null then + -- Top reached. + Prepend (Rstr, Sep); + return; + else + -- Instantiation statement label. + if Is_Instance then + Prepend (Rstr, '@'); + end if; + Prepend (Rstr, + To_Ghdl_Rtin_Object_Acc (Parent_Inst).Name); + Prepend (Rstr, Sep); + end if; + end; + when Ghdl_Rtik_For_Generate => + declare + Iter : Ghdl_Rtin_Object_Acc; + Addr : Address; + begin + Prepend (Rstr, ')'); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); + Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type)); + Prepend (Rstr, '('); + Prepend (Rstr, Blk.Name); + Prepend (Rstr, Sep); + Ctxt := Get_Parent_Context (Ctxt); + end; + when others => + Internal_Error ("grt.rtis_utils.get_path_name"); + end case; + end loop; + end Get_Path_Name; + + procedure Put (Stream : FILEs; Ctxt : Rti_Context) + is + Rstr : Rstring; + begin + Get_Path_Name (Rstr, Ctxt, '.'); + Put (Stream, Rstr); + Free (Rstr); + end Put; + +end Grt.Rtis_Utils; diff --git a/src/grt/grt-rtis_utils.ads b/src/grt/grt-rtis_utils.ads new file mode 100644 index 000000000..10c1a0f28 --- /dev/null +++ b/src/grt/grt-rtis_utils.ads @@ -0,0 +1,92 @@ +-- GHDL Run Time (GRT) - RTI utilities. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Stdio; use Grt.Stdio; + +package Grt.Rtis_Utils is + -- Action to perform after a node was handled by the user function: + -- Traverse_Ok: continue to process. + -- Traverse_Skip: do not traverse children. + -- Traverse_Stop: end of walk. + type Traverse_Result is (Traverse_Ok, Traverse_Skip, Traverse_Stop); + + -- An RTI object is a context and an RTI declaration. + type Rti_Object is record + Obj : Ghdl_Rti_Access; + Ctxt : Rti_Context; + end record; + + -- Traverse all blocks (package, entities, architectures, block, generate, + -- processes). + generic + with function Process (Ctxt : Rti_Context; + Obj : Ghdl_Rti_Access) + return Traverse_Result; + function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result; + + generic + type Param_Type is private; + with procedure Process (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param : Param_Type); + procedure Foreach_Scalar (Ctxt : Rti_Context; + Obj_Type : Ghdl_Rti_Access; + Obj_Addr : Address; + Is_Sig : Boolean; + Param : Param_Type); + + procedure Get_Value (Str : in out Vstring; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access); + + -- Get the name of a physical unit. + function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access) + return Ghdl_C_String; + + -- Get the value of a physical unit. + function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access; + Type_Rti : Ghdl_Rti_Access) + return Ghdl_I64; + + -- Disp a value. + procedure Disp_Value (Stream : FILEs; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access); + + -- Get context as a path name. + -- If IS_INSTANCE is true, the architecture name of entities is added. + procedure Get_Path_Name (Rstr : in out Rstring; + Last_Ctxt : Rti_Context; + Sep : Character; + Is_Instance : Boolean := True); + + -- Disp a context as a path. + procedure Put (Stream : FILEs; Ctxt : Rti_Context); +end Grt.Rtis_Utils; diff --git a/src/grt/grt-sdf.adb b/src/grt/grt-sdf.adb new file mode 100644 index 000000000..73534e3eb --- /dev/null +++ b/src/grt/grt-sdf.adb @@ -0,0 +1,1389 @@ +-- GHDL Run Time (GRT) - SDF parser. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Errors; use Grt.Errors; +with Ada.Characters.Latin_1; +with Ada.Unchecked_Deallocation; +with Grt.Vital_Annotate; + +package body Grt.Sdf is + EOT : constant Character := Character'Val (4); + + type Sdf_Token_Type is + ( + Tok_Oparen, -- ( + Tok_Cparen, -- ) + Tok_Qstring, + Tok_Identifier, + Tok_Rnumber, + Tok_Dnumber, + Tok_Div, -- / + Tok_Dot, -- . + Tok_Cln, -- : + + Tok_Error, + Tok_Eof + ); + + type Sdf_Context_Acc is access Sdf_Context_Type; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => Sdf_Context_Acc, Object => Sdf_Context_Type); + + Sdf_Context : Sdf_Context_Acc; + + -- Current data read from the file. + Buf : String_Access (1 .. Buf_Size) := null; + + -- Length of the buffer, including the EOT. + Buf_Len : Natural; + Pos : Natural; + Line_Start : Integer; + + Sdf_Stream : FILEs := NULL_Stream; + Sdf_Filename : String_Access := null; + Sdf_Line : Natural; + + function Open_Sdf (Filename : String) return Boolean + is + N_Filename : String (1 .. Filename'Length + 1); + Mode : constant String := "rt" & NUL; + begin + N_Filename (1 .. Filename'Length) := Filename; + N_Filename (N_Filename'Last) := NUL; + Sdf_Stream := fopen (N_Filename'Address, Mode'Address); + if Sdf_Stream = NULL_Stream then + Error_C ("cannot open SDF file '"); + Error_C (Filename); + Error_E ("'"); + return False; + end if; + Sdf_Context := new Sdf_Context_Type; + + Sdf_Context.Version := Sdf_Version_Unknown; + + -- Set the timescale to 1 ns. + Sdf_Context.Timescale := 1000; + + Buf := new String (1 .. Buf_Size); + Buf_Len := 1; + Buf (1) := EOT; + Sdf_Line := 1; + Sdf_Filename := new String'(Filename); + Pos := 1; + Line_Start := 1; + return True; + end Open_Sdf; + + procedure Close_Sdf + is + begin + fclose (Sdf_Stream); + Sdf_Stream := NULL_Stream; + Unchecked_Deallocation (Sdf_Context); + Unchecked_Deallocation (Buf); + end Close_Sdf; + + procedure Read_Sdf + is + Res : size_t; + begin + Res := fread (Buf (Pos)'Address, 1, size_t (Read_Size), Sdf_Stream); + Line_Start := Line_Start - Buf_Len + Pos; + Buf_Len := Pos + Natural (Res); + Buf (Buf_Len) := EOT; + end Read_Sdf; + + + Ident_Start : Natural; + Ident_End : Natural; + + procedure Read_Append + is + Len : Natural; + begin + Len := Pos - Ident_Start; + if Ident_Start = 1 or Len >= 1024 then + Error_C ("SDF line "); + Error_C (Sdf_Line); + Error_E (" is too long"); + return; + end if; + Buf (1 .. Len) := Buf (Ident_Start .. Ident_Start + Len - 1); + Pos := Len + 1; + Ident_Start := 1; + Read_Sdf; + end Read_Append; + + procedure Error_Sdf_C is + begin + Error_C (Sdf_Filename.all); + Error_C (":"); + Error_C (Sdf_Line); + Error_C (":"); + Error_C (Pos - Line_Start); + Error_C (": "); + end Error_Sdf_C; + + procedure Error_Sdf (Msg : String) is + begin + Error_Sdf_C; + Error_E (Msg); + end Error_Sdf; + + procedure Error_Bad_Character is + begin + Error_Sdf ("bad character in SDF file"); + end Error_Bad_Character; + + procedure Scan_Identifier + is + begin + Ident_Start := Pos; + loop + Pos := Pos + 1; + case Buf (Pos) is + when 'a' .. 'z' + | 'A' .. 'Z' + | '0' .. '9' + | '_' => + null; + when '\' => + Error_Sdf ("escape character not handled"); + Ident_End := Pos - 1; + return; + when EOT => + Read_Append; + Pos := Pos - 1; + when others => + Ident_End := Pos - 1; + return; + end case; + end loop; + end Scan_Identifier; + + function Ident_Length return Natural is + begin + return Ident_End - Ident_Start + 1; + end Ident_Length; + + function Is_Ident (Str : String) return Boolean + is + begin + if Ident_Length /= Str'Length then + return False; + end if; + return Buf (Ident_Start .. Ident_End) = Str; + end Is_Ident; + + procedure Scan_Qstring + is + begin + Ident_Start := Pos + 1; + loop + Pos := Pos + 1; + case Buf (Pos) is + when EOT => + Read_Append; + when NUL .. Character'Val (3) + | Character'Val (5) .. Character'Val (31) + | Character'Val (127) .. Character'Val (255) => + Error_Bad_Character; + when ' ' + | '!' + | '#' .. '~' => + null; + when '"' => -- " + Ident_End := Pos - 1; + Pos := Pos + 1; + exit; + end case; + end loop; + end Scan_Qstring; + + Scan_Int : Integer; + Scan_Exp : Integer; + + function Scan_Number return Sdf_Token_Type + is + Has_Dot : Boolean; + begin + Has_Dot := False; + Scan_Int := 0; + Scan_Exp := 0; + loop + case Buf (Pos) is + when '0' .. '9' => + Scan_Int := Scan_Int * 10 + + Character'Pos (Buf (Pos)) - Character'Pos ('0'); + if Has_Dot then + Scan_Exp := Scan_Exp - 1; + end if; + Pos := Pos + 1; + when '.' => + if Has_Dot then + Error_Bad_Character; + return Tok_Error; + else + Has_Dot := True; + end if; + Pos := Pos + 1; + when EOT => + if Pos /= Buf_Len then + Error_Bad_Character; + return Tok_Error; + end if; + Pos := 1; + Read_Sdf; + exit when Buf_Len = 1; + when others => + exit; + end case; + end loop; + if Has_Dot then + return Tok_Rnumber; + else + return Tok_Dnumber; + end if; + end Scan_Number; + + procedure Refill_Buf is + begin + Buf (1 .. Buf_Len - Pos) := Buf (Pos .. Buf_Len - 1); + Pos := Buf_Len - Pos + 1; + Read_Sdf; + Pos := 1; + end Refill_Buf; + + procedure Skip_Spaces + is + use Ada.Characters.Latin_1; + begin + -- Fast blanks skipping. + while Buf (Pos) = ' ' loop + Pos := Pos + 1; + end loop; + + loop + -- Be sure there is at least 1 character. + if Pos + 1 >= Buf_Len then + Refill_Buf; + end if; + + case Buf (Pos) is + when EOT => + if Pos /= Buf_Len then + return; + end if; + Pos := 1; + Read_Sdf; + if Buf_Len = 1 then + return; + end if; + when LF => + Pos := Pos + 1; + if Buf (Pos) = CR then + Pos := Pos + 1; + end if; + Line_Start := Pos; + Sdf_Line := Sdf_Line + 1; + when CR => + Pos := Pos + 1; + if Buf (Pos) = LF then + Pos := Pos + 1; + end if; + Line_Start := Pos; + Sdf_Line := Sdf_Line + 1; + when ' ' + | HT => + Pos := Pos + 1; + when '/' => + if Buf (Pos + 1) = '/' then + Pos := Pos + 2; + -- Skip line comment. + loop + exit when Buf (Pos) = CR; + exit when Buf (Pos) = LF; + exit when Buf (Pos) = EOT; + Pos := Pos + 1; + if Pos >= Buf_Len then + Refill_Buf; + end if; + end loop; + else + return; + end if; + when others => + return; + end case; + end loop; + end Skip_Spaces; + + function Get_Token return Sdf_Token_Type + is + use Ada.Characters.Latin_1; + begin + Skip_Spaces; + + -- Be sure there is at least 4 characters. + if Pos + 4 >= Buf_Len then + Refill_Buf; + end if; + + case Buf (Pos) is + when EOT => + if Buf_Len = 1 then + return Tok_Eof; + else + Error_Bad_Character; + return Tok_Error; + end if; + when '"' => -- " + Scan_Qstring; + return Tok_Qstring; + when '/' => + -- Skip_Spaces has already handled line comments. + Pos := Pos + 1; + return Tok_Div; + when '.' => + Pos := Pos + 1; + return Tok_Dot; + when ':' => + Pos := Pos + 1; + return Tok_Cln; + when '(' => + Pos := Pos + 1; + return Tok_Oparen; + when ')' => + Pos := Pos + 1; + return Tok_Cparen; + when 'a' .. 'z' + | 'A' .. 'Z' => + Scan_Identifier; + return Tok_Identifier; + when '0' .. '9' => + return Scan_Number; + when others => + Error_Bad_Character; + return Tok_Error; + end case; + end Get_Token; + + function Is_White_Space (C : Character) return Boolean + is + use Ada.Characters.Latin_1; + begin + case C is + when ' ' + | HT + | CR + | LF => + return True; + when others => + return False; + end case; + end Is_White_Space; + + function Get_Edge_Token return Edge_Type + is + use Ada.Characters.Latin_1; + begin + Skip_Spaces; + + -- Be sure there is at least 4 characters. + if Pos + 4 >= Buf_Len then + Refill_Buf; + end if; + + case Buf (Pos) is + when '0' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = 'z' then + Pos := Pos + 2; + return Edge_0z; + elsif Buf (Pos + 1) = '1' then + Pos := Pos + 2; + return Edge_01; + end if; + end if; + when '1' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = 'z' then + Pos := Pos + 2; + return Edge_1z; + elsif Buf (Pos + 1) = '0' then + Pos := Pos + 2; + return Edge_10; + end if; + end if; + when 'z' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = '0' then + Pos := Pos + 2; + return Edge_Z0; + elsif Buf (Pos + 1) = '1' then + Pos := Pos + 2; + return Edge_Z1; + end if; + end if; + when 'p' => + Scan_Identifier; + if Is_Ident ("posedge") then + return Edge_Posedge; + end if; + when 'n' => + Scan_Identifier; + if Is_Ident ("negedge") then + return Edge_Negedge; + end if; + when others => + null; + end case; + Error_Sdf ("edge_identifier expected"); + return Edge_Error; + end Get_Edge_Token; + + procedure Error_Sdf (Tok : Sdf_Token_Type) + is + begin + case Tok is + when Tok_Qstring => + Error_Sdf ("qstring expected"); + when Tok_Oparen => + Error_Sdf ("'(' expected"); + when Tok_Identifier => + Error_Sdf ("identifier expected"); + when Tok_Cln => + Error_Sdf ("':' (colon) expected"); + when others => + Error_Sdf ("parse error"); + end case; + end Error_Sdf; + + function Expect (Tok : Sdf_Token_Type) return Boolean + is + begin + if Get_Token = Tok then + return True; + end if; + Error_Sdf (Tok); + return False; + end Expect; + + function Expect_Cp_Op_Ident (Tok : Sdf_Token_Type) return Boolean + is + begin + if Tok /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return False; + end if; + if not Expect (Tok_Oparen) + or else not Expect (Tok_Identifier) + then + return False; + end if; + return True; + end Expect_Cp_Op_Ident; + + function Expect_Qstr_Cp_Op_Ident (Str : String) return Boolean + is + Tok : Sdf_Token_Type; + begin + if not Is_Ident (Str) then + return True; + end if; + + Tok := Get_Token; + if Tok = Tok_Qstring then + Tok := Get_Token; + end if; + + return Expect_Cp_Op_Ident (Tok); + end Expect_Qstr_Cp_Op_Ident; + + procedure Start_Generic_Name (Kind : Timing_Generic_Kind) is + begin + Sdf_Context.Kind := Kind; + Sdf_Context.Port_Num := 0; + Sdf_Context.Ports (1).L := Invalid_Dnumber; + Sdf_Context.Ports (2).L := Invalid_Dnumber; + Sdf_Context.Ports (1).Edge := Edge_None; + Sdf_Context.Ports (2).Edge := Edge_None; + end Start_Generic_Name; + + -- Status of a parsing. + -- ERROR: parse error (syntax is not correct) + -- ALTERN: alternate construct parsed (ie simple RNUMBER for tc_rvalue). + -- OPTIONAL: the construct is absent. + -- FOUND: the construct is present. + -- SET: the construct is present and a value was extracted from. + type Parse_Status_Type is + ( + Status_Error, + Status_Altern, + Status_Optional, + Status_Found, + Status_Set + ); + + function Num_To_Time return Ghdl_I64 + is + Res : Ghdl_I64; + begin + Res := Ghdl_I64 (Scan_Int) * Ghdl_I64 (Sdf_Context.Timescale); + while Scan_Exp < 0 loop + Res := Res / 10; + Scan_Exp := Scan_Exp + 1; + end loop; + return Res; + end Num_To_Time; + + -- Parse: REXPRESSION? ')' + procedure Parse_Rexpression + (Status : out Parse_Status_Type; Val : out Ghdl_I64) + is + Tok : Sdf_Token_Type; + + procedure Pr_Rnumber (Mtm : Mtm_Type) + is + begin + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Mtm = Sdf_Mtm then + Val := Num_To_Time; + Status := Status_Set; + elsif Status /= Status_Set then + Status := Status_Found; + end if; + Tok := Get_Token; + end if; + end Pr_Rnumber; + + function Pr_Colon return Boolean + is + begin + if Tok /= Tok_Cln then + Error_Sdf (Tok_Cln); + Status := Status_Error; + return False; + else + Tok := Get_Token; + return True; + end if; + end Pr_Colon; + + begin + Val := 0; + Tok := Get_Token; + Status := Status_Error; + if Tok = Tok_Cparen then + Status := Status_Optional; + return; + end if; + + Pr_Rnumber (Minimum); + + if not Pr_Colon then + return; + end if; + + Pr_Rnumber (Typical); + + if not Pr_Colon then + return; + end if; + + Pr_Rnumber (Maximum); + + if Status = Status_Error then + Error_Sdf ("at least one number required in an rexpression"); + return; + end if; + + if Tok /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + Status := Status_Error; + end if; + end Parse_Rexpression; + + function Expect_Rexpr_Cp_Op_Ident return Boolean + is + Status : Parse_Status_Type; + Val : Ghdl_I64; + begin + Parse_Rexpression (Status, Val); + if Status = Status_Error then + return False; + end if; + if not Expect (Tok_Oparen) + or else not Expect (Tok_Identifier) + then + Error_Sdf (Tok_Identifier); + return False; + end if; + return True; + end Expect_Rexpr_Cp_Op_Ident; + + function To_Lower (C : Character) return Character is + begin + if C >= 'A' and C <= 'Z' then + return Character'Val (Character'Pos (C) + - Character'Pos ('A') + Character'Pos ('a')); + else + return C; + end if; + end To_Lower; + + function Parse_Port_Path1 (Tok : Sdf_Token_Type) return Boolean + is + Port_Spec : Port_Spec_Type + renames Sdf_Context.Ports (Sdf_Context.Port_Num); + Len : Natural; + begin + if Tok /= Tok_Identifier then + Error_Sdf ("port path expected"); + return False; + end if; + Len := 0; + for I in Ident_Start .. Ident_End loop + Len := Len + 1; + Port_Spec.Name (Len) := To_Lower (Buf (I)); + end loop; + Port_Spec.Name_Len := Len; + + -- Parse [ DNUMBER ] + -- | [ DNUMBER : DNUMBER ] + Skip_Spaces; + if Buf (Pos) = '[' then + Port_Spec.R := Invalid_Dnumber; + Pos := Pos + 1; + if Get_Token /= Tok_Dnumber then + Error_Sdf (Tok); + else + Port_Spec.L := Ghdl_I32 (Scan_Int); + end if; + Skip_Spaces; + if Buf (Pos) = ':' then + Pos := Pos + 1; + if Get_Token /= Tok_Dnumber then + Error_Sdf (Tok); + else + Port_Spec.R := Ghdl_I32 (Scan_Int); + end if; + Skip_Spaces; + end if; + if Buf (Pos) /= ']' then + Error_Sdf ("']' expected"); + else + Pos := Pos + 1; + end if; + end if; + + return True; + end Parse_Port_Path1; + + function Parse_Port_Path return Boolean + is + begin + Sdf_Context.Port_Num := Sdf_Context.Port_Num + 1; + return Parse_Port_Path1 (Get_Token); + end Parse_Port_Path; + + function Parse_Port_Spec return Boolean + is + Tok : Sdf_Token_Type; + Edge : Edge_Type; + begin + Sdf_Context.Port_Num := Sdf_Context.Port_Num + 1; + Tok := Get_Token; + if Tok = Tok_Identifier then + return Parse_Port_Path1 (Tok); + elsif Tok /= Tok_Oparen then + Error_Sdf ("port spec expected"); + return False; + end if; + Edge := Get_Edge_Token; + if Edge = Edge_Error then + return False; + end if; + Sdf_Context.Ports (Sdf_Context.Port_Num).Edge := Edge; + if not Parse_Port_Path1 (Get_Token) then + return False; + end if; + if Get_Token /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return False; + end if; + return True; + end Parse_Port_Spec; + + function Parse_Port_Tchk return Boolean renames Parse_Port_Spec; + + -- tc_rvalue ::= ( RNUMBER ) + -- ||= ( rexpression ) + -- Return status_optional for ( ) + function Parse_Tc_Rvalue return Parse_Status_Type + is + Tok : Sdf_Token_Type; + Res : Parse_Status_Type; + begin + -- '(' + if Get_Token /= Tok_Oparen then + Error_Sdf (Tok_Oparen); + return Status_Error; + end if; + Res := Status_Found; + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + Sdf_Context.Timing (1) := Num_To_Time; + Tok := Get_Token; + if Tok = Tok_Cparen then + -- This is a simple RNUMBER. + return Status_Altern; + end if; + if Sdf_Mtm = Minimum then + Res := Status_Set; + end if; + end if; + if Tok = Tok_Cparen then + return Status_Optional; + end if; + if Tok /= Tok_Cln then + Error_Sdf (Tok_Cln); + return Status_Error; + end if; + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Sdf_Mtm = Typical then + Sdf_Context.Timing (1) := Num_To_Time; + Res := Status_Set; + end if; + Tok := Get_Token; + end if; + if Tok /= Tok_Cln then + Error_Sdf (Tok_Cln); + return Status_Error; + end if; + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Sdf_Mtm = Maximum then + Sdf_Context.Timing (1) := Num_To_Time; + Res := Status_Set; + end if; + Tok := Get_Token; + end if; + if Tok /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return Status_Error; + end if; + return Res; + end Parse_Tc_Rvalue; + + function Parse_Simple_Tc_Rvalue return Boolean is + begin + Sdf_Context.Timing_Nbr := 0; + + case Parse_Tc_Rvalue is + when Status_Error + | Status_Optional => + return False; + when Status_Altern => + null; + when Status_Found => + Sdf_Context.Timing_Set (1) := False; + when Status_Set => + Sdf_Context.Timing_Set (1) := True; + end case; + return True; + end Parse_Simple_Tc_Rvalue; + + -- rvalue ::= ( RNUMBER ) + -- ||= rexp_list + -- Parse: rvalue ) + function Parse_Rvalue return Boolean + is + Tok : Sdf_Token_Type; + begin + Sdf_Context.Timing_Nbr := 0; + Sdf_Context.Timing_Set := (others => False); + + case Parse_Tc_Rvalue is + when Status_Error => + return False; + when Status_Altern => + Sdf_Context.Timing_Nbr := 1; + if Get_Token /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + end if; + return True; + when Status_Found + | Status_Optional => + null; + when Status_Set => + Sdf_Context.Timing_Set (1) := True; + end case; + + Sdf_Context.Timing_Nbr := 1; + loop + Tok := Get_Token; + exit when Tok = Tok_Cparen; + if Tok /= Tok_Oparen then + Error_Sdf (Tok_Oparen); + return False; + end if; + + Sdf_Context.Timing_Nbr := Sdf_Context.Timing_Nbr + 1; + declare + Status : Parse_Status_Type; + Val : Ghdl_I64; + begin + Parse_Rexpression (Status, Val); + case Status is + when Status_Error + | Status_Altern => + return False; + when Status_Optional + | Status_Found => + null; + when Status_Set => + Sdf_Context.Timing_Set (Sdf_Context.Timing_Nbr) := True; + Sdf_Context.Timing (Sdf_Context.Timing_Nbr) := Val; + end case; + end; + end loop; + if Boolean'(False) then + -- Do not expand here, since the most used is 01. + case Sdf_Context.Timing_Nbr is + when 1 => + for I in 2 .. 6 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (1); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (1); + end loop; + when 2 => + for I in 3 .. 4 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (1); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (1); + end loop; + for I in 5 .. 6 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (2); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (2); + end loop; + when 3 => + for I in 4 .. 6 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (I - 3); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (I - 3); + end loop; + when 6 + | 12 => + null; + when others => + Error_Sdf ("bad number of rvalue"); + return False; + end case; + end if; + return True; + end Parse_Rvalue; + + function Handle_Generic return Boolean + is + Name : String (1 .. 1024); + Len : Natural; + + procedure Start (Str : String) is + begin + Name (1 .. Str'Length) := Str; + Len := Str'Length; + end Start; + + procedure Add (Str : String) + is + Nlen : Natural; + begin + Len := Len + 1; + Name (Len) := '_'; + Nlen := Len + Str'Length; + Name (Len + 1 .. Nlen) := Str; + Len := Nlen; + end Add; + + procedure Add_Edge (Edge : Edge_Type; Force : Boolean) is + begin + case Edge is + when Edge_Posedge => + Add ("posedge"); + when Edge_Negedge => + Add ("negedge"); + when Edge_01 => + Add ("01"); + when Edge_10 => + Add ("10"); + when Edge_0z => + Add ("0z"); + when Edge_Z1 => + Add ("Z1"); + when Edge_1z => + Add ("1z"); + when Edge_Z0 => + Add ("ZO"); + when Edge_None => + if Force then + Add ("noedge"); + end if; + when Edge_Error => + Add ("?"); + end case; + end Add_Edge; + + Ok : Boolean; + begin + case Sdf_Context.Kind is + when Delay_Iopath => + Start ("tpd"); + when Delay_Port => + Start ("tipd"); + when Timingcheck_Setup => + Start ("tsetup"); + when Timingcheck_Hold => + Start ("thold"); + when Timingcheck_Setuphold => + Start ("tsetup"); + when Timingcheck_Recovery => + Start ("trecovery"); + when Timingcheck_Skew => + Start ("tskew"); + when Timingcheck_Width => + Start ("tpw"); + when Timingcheck_Period => + Start ("tperiod"); + when Timingcheck_Nochange => + Start ("tncsetup"); + end case; + for I in 1 .. Sdf_Context.Port_Num loop + Add (Sdf_Context.Ports (I).Name + (1 .. Sdf_Context.Ports (I).Name_Len)); + end loop; + if Sdf_Context.Kind in Timing_Generic_Full_Condition then + Add_Edge (Sdf_Context.Ports (1).Edge, True); + Add_Edge (Sdf_Context.Ports (2).Edge, False); + elsif Sdf_Context.Kind in Timing_Generic_Simple_Condition then + Add_Edge (Sdf_Context.Ports (1).Edge, False); + end if; + Vital_Annotate.Sdf_Generic (Sdf_Context.all, Name (1 .. Len), Ok); + if not Ok then + Error_Sdf_C; + Error_C ("could not annotate generic "); + Error_E (Name (1 .. Len)); + return False; + end if; + return True; + end Handle_Generic; + + function Parse_Sdf return Boolean + is + Tok : Sdf_Token_Type; + Ok : Boolean; + begin + if Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + or else not Is_Ident ("DELAYFILE") + or else Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("not an SDF file"); + return False; + end if; + + if Is_Ident ("SDFVERSION") then + Tok := Get_Token; + if Tok = Tok_Qstring then + Sdf_Context.Version := Sdf_Version_Bad; + if Ident_Length = 3 and then Buf (Ident_Start + 1) = '.' then + -- Version has the format '"X.Y"' (without simple quote). + if Buf (Ident_Start) = '2' + and then Buf (Ident_Start + 2) = '1' + then + Sdf_Context.Version := Sdf_2_1; + end if; + end if; + Tok := Get_Token; + end if; + + if not Expect_Cp_Op_Ident (Tok) then + return False; + end if; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("DESIGN") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("DATE") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("VENDOR") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("PROGRAM") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("VERSION") then + return False; + end if; + + if Is_Ident ("DIVIDER") then + Tok := Get_Token; + if Tok = Tok_Div or Tok = Tok_Dot then + Tok := Get_Token; + end if; + if not Expect_Cp_Op_Ident (Tok) then + return False; + end if; + end if; + + if Is_Ident ("VOLTAGE") then + if not Expect_Rexpr_Cp_Op_Ident then + return False; + end if; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("PROCESS") then + return False; + end if; + + if Is_Ident ("TEMPERATURE") then + if not Expect_Rexpr_Cp_Op_Ident then + return False; + end if; + end if; + + if Is_Ident ("TIMESCALE") then + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Scan_Exp = 0 and (Scan_Int = 1 + or Scan_Int = 10 + or Scan_Int = 100) + then + Sdf_Context.Timescale := Scan_Int; + else + Error_Sdf ("bad timescale value"); + return False; + end if; + Tok := Get_Token; + if Tok /= Tok_Identifier then + Error_Sdf (Tok_Identifier); + end if; + if Is_Ident ("ps") then + null; + elsif Is_Ident ("ns") then + Sdf_Context.Timescale := Sdf_Context.Timescale * 1000; + elsif Is_Ident ("us") then + Sdf_Context.Timescale := Sdf_Context.Timescale * 1000_000; + else + Error_Sdf ("bad timescale unit"); + return False; + end if; + Tok := Get_Token; + end if; + if not Expect_Cp_Op_Ident (Tok) then + return False; + end if; + end if; + + Vital_Annotate.Sdf_Header (Sdf_Context.all); + + -- Parse cell+ + loop + if not Is_Ident ("CELL") then + Error_Sdf ("CELL expected"); + return False; + end if; + -- Parse celltype + if Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + or else not Is_Ident ("CELLTYPE") + or else Get_Token /= Tok_Qstring + then + Error_Sdf ("CELLTYPE expected"); + return False; + end if; + Sdf_Context.Celltype_Len := Ident_Length; + if Sdf_Context.Celltype_Len > Sdf_Context.Celltype'Length then + Error_Sdf ("CELLTYPE qstring is too long"); + return False; + end if; + for I in Ident_Start .. Ident_End loop + Sdf_Context.Celltype (I - Ident_Start + 1) := To_Lower (Buf (I)); + end loop; + Vital_Annotate.Sdf_Celltype (Sdf_Context.all); + if Get_Token /= Tok_Cparen + or else Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + or else not Is_Ident ("INSTANCE") + then + Error_Sdf ("INSTANCE expected"); + return False; + end if; + -- Parse instance+ + loop + exit when not Is_Ident ("INSTANCE"); + Tok := Get_Token; + if Tok /= Tok_Cparen then + loop + if Tok /= Tok_Identifier then + Error_Sdf ("instance identifier expected"); + return False; + end if; + for I in Ident_Start .. Ident_End loop + Buf (I) := To_Lower (Buf (I)); + end loop; + Vital_Annotate.Sdf_Instance + (Sdf_Context.all, Buf (Ident_Start .. Ident_End), Ok); + if not Ok then + Error_Sdf ("cannot find instance"); + return False; + end if; + Tok := Get_Token; + exit when Tok /= Tok_Dot; + Tok := Get_Token; + end loop; + end if; + if Tok /= Tok_Cparen + or else Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("instance or timing_spec expected"); + return False; + end if; + end loop; + Vital_Annotate.Sdf_Instance_End (Sdf_Context.all, Ok); + if not Ok then + Error_Sdf ("bad instance or celltype mistmatch"); + return False; + end if; + + -- Parse timing_spec+ + loop + if Is_Ident ("DELAY") then + -- Parse deltype+ + Tok := Get_Token; + loop + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("deltype expected"); + return False; + end if; + if Is_Ident ("PATHPULSE") + or else Is_Ident ("GLOBALPATHPULSE") + then + Error_Sdf ("PATHPULSE and GLOBALPATHPULSE not allowed"); + return False; + end if; + if Is_Ident ("ABSOLUTE") then + null; + elsif Is_Ident ("INCREMENT") then + null; + else + Error_Sdf ("ABSOLUTE or INCREMENT expected"); + return False; + end if; + -- Parse absvals+ or incvals+ + Tok := Get_Token; + loop + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("absvals or incvals expected"); + return False; + end if; + if Is_Ident ("IOPATH") then + Start_Generic_Name (Delay_Iopath); + if not Parse_Port_Spec + or else not Parse_Port_Path + or else not Parse_Rvalue + then + return False; + end if; + elsif Is_Ident ("PORT") then + Start_Generic_Name (Delay_Port); + if not Parse_Port_Path + or else not Parse_Rvalue + then + return False; + end if; + elsif Is_Ident ("COND") + or else Is_Ident ("INTERCONNECT") + or else Is_Ident ("DEVICE") + then + Error_Sdf + ("COND, INTERCONNECT, or DEVICE not handled"); + return False; + elsif Is_Ident ("NETDELAY") then + Error_Sdf ("NETDELAY not allowed in VITAL SDF"); + return False; + else + Error_Sdf ("absvals or incvals expected"); + return False; + end if; + + if not Handle_Generic then + return False; + end if; + + Tok := Get_Token; + exit when Tok = Tok_Cparen; + end loop; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + end loop; + elsif Is_Ident ("TIMINGCHECK") then + -- parse tc_def+ + Tok := Get_Token; + loop + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("tc_def expected"); + return False; + end if; + if Is_Ident ("SETUP") then + Start_Generic_Name (Timingcheck_Setup); + elsif Is_Ident ("HOLD") then + Start_Generic_Name (Timingcheck_Hold); + elsif Is_Ident ("SETUPHOLD") then + Start_Generic_Name (Timingcheck_Setuphold); + elsif Is_Ident ("RECOVERY") then + Start_Generic_Name (Timingcheck_Recovery); + elsif Is_Ident ("SKEW") then + Start_Generic_Name (Timingcheck_Skew); + elsif Is_Ident ("WIDTH") then + Start_Generic_Name (Timingcheck_Width); + elsif Is_Ident ("PERIOD") then + Start_Generic_Name (Timingcheck_Period); + elsif Is_Ident ("NOCHANGE") then + Start_Generic_Name (Timingcheck_Nochange); + elsif Is_Ident ("PATHCONSTRAINT") + or else Is_Ident ("SUM") + or else Is_Ident ("DIFF") + or else Is_Ident ("SKEWCONSTRAINT") + then + Error_Sdf ("non-VITAL tc_def"); + return False; + else + Error_Sdf ("bad tc_def"); + return False; + end if; + + case Sdf_Context.Kind is + when Timingcheck_Setup + | Timingcheck_Hold + | Timingcheck_Recovery + | Timingcheck_Skew + | Timingcheck_Setuphold + | Timingcheck_Nochange => + if not Parse_Port_Tchk + or else not Parse_Port_Tchk + or else not Parse_Simple_Tc_Rvalue + then + return False; + end if; + when Timingcheck_Width + | Timingcheck_Period => + if not Parse_Port_Tchk + or else not Parse_Simple_Tc_Rvalue + then + return False; + end if; + when others => + Internal_Error ("sdf_parse"); + end case; + + if not Handle_Generic then + return False; + end if; + + case Sdf_Context.Kind is + when Timingcheck_Setuphold + | Timingcheck_Nochange => + if not Parse_Simple_Tc_Rvalue then + return False; + end if; + Error_Sdf ("setuphold and nochange not yet handled"); + return False; + when others => + null; + end case; + + if Get_Token /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return False; + end if; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + end loop; + end if; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + if Tok /= Tok_Oparen then + Error_Sdf (Tok_Oparen); + return False; + end if; + if Get_Token /= Tok_Identifier then + Error_Sdf (Tok_Identifier); + return False; + end if; + end loop; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf (Tok_Identifier); + end if; + end loop; + if Get_Token /= Tok_Eof then + Error_Sdf ("EOF expected"); + return False; + end if; + return True; + end Parse_Sdf; + + function Parse_Sdf_File (Filename : String) return Boolean + is + Res : Boolean; + begin + if not Open_Sdf (Filename) then + return False; + end if; + Res := Parse_Sdf; + Close_Sdf; + return Res; + end Parse_Sdf_File; + +end Grt.Sdf; diff --git a/src/grt/grt-sdf.ads b/src/grt/grt-sdf.ads new file mode 100644 index 000000000..fd05b9e20 --- /dev/null +++ b/src/grt/grt-sdf.ads @@ -0,0 +1,131 @@ +-- GHDL Run Time (GRT) - SDF parser. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; + +package Grt.Sdf is + type Edge_Type is + ( + Edge_Error, + Edge_None, + Edge_Posedge, + Edge_Negedge, + Edge_01, + Edge_10, + Edge_0z, + Edge_Z1, + Edge_1z, + Edge_Z0 + ); + + type Timing_Generic_Kind is + ( + Delay_Port, + --Delay_Interconnect, + --Delay_Device, + + -- Simple condition + Delay_Iopath, + Timingcheck_Width, + Timingcheck_Period, + + -- Full condition + Timingcheck_Setup, + Timingcheck_Hold, + Timingcheck_Recovery, + Timingcheck_Skew, + Timingcheck_Nochange, + Timingcheck_Setuphold + ); + + subtype Timing_Generic_Simple_Condition is Timing_Generic_Kind + range Delay_Iopath .. Timingcheck_Period; + + subtype Timing_Generic_Full_Condition is Timing_Generic_Kind + range Timingcheck_Setup .. Timingcheck_Setuphold; + + type Sdf_Version_Type is + ( + Sdf_2_1, + Sdf_Version_Unknown, + Sdf_Version_Bad + ); + + Read_Size : constant Natural := 4096; + Buf_Size : constant Natural := Read_Size + 1024 + 1; + + Invalid_Dnumber : constant Ghdl_I32 := -1; + + type Port_Spec_Type is record + -- Port identifier. + Name : String (1 .. 128); + Name_Len : Natural; + + -- Left and Right range. + -- If L = R = Invalid_Dnumber, this is a simple scalar port. + -- If R = Invalid_Dnumber, this is a scalar port (from a vector) + -- Otherwise, this is a bus port. + L, R : Ghdl_I32; + + -- Cond : String (1 .. 1024); + -- Cond_Len : Natural; + + Edge : Edge_Type; + end record; + + type Port_Spec_Array_Type is array (Natural range <>) of Port_Spec_Type; + + type Ghdl_I64_Array is array (1 .. 12) of Ghdl_I64; + type Boolean_Array is array (1 .. 12) of Boolean; + + type Sdf_Context_Type is record + -- Version of the SDF file. + Version : Sdf_Version_Type; + + -- Timescale; 1 corresponds to 1 ps. + -- Default is 1000 (1 ns). + Timescale : Natural; + + Kind : Timing_Generic_Kind; + + -- Cell type. + Celltype : String (1 .. 128); + Celltype_Len : Natural; + + -- Current port. + Port_Num : Natural; + Ports : Port_Spec_Array_Type (1 .. 2); + + -- timing spec. + Timing : Ghdl_I64_Array; + Timing_Set : Boolean_Array; + Timing_Nbr : Natural; + end record; + + -- Which value is extracted. + type Mtm_Type is (Minimum, Typical, Maximum); + Sdf_Mtm : Mtm_Type := Typical; + + function Parse_Sdf_File (Filename : String) return Boolean; +end Grt.Sdf; diff --git a/src/grt/grt-shadow_ieee.adb b/src/grt/grt-shadow_ieee.adb new file mode 100644 index 000000000..32af4be5d --- /dev/null +++ b/src/grt/grt-shadow_ieee.adb @@ -0,0 +1,32 @@ +-- GHDL Run Time (GRT) - ghost declarations for ieee. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; + +package body Grt.Shadow_Ieee is + procedure Ieee_Std_Logic_1164_Resolved_RESOLV is + begin + Internal_Error ("resolved_RESOLV from shadow ieee called"); + end Ieee_Std_Logic_1164_Resolved_RESOLV; +end Grt.Shadow_Ieee; diff --git a/src/grt/grt-shadow_ieee.ads b/src/grt/grt-shadow_ieee.ads new file mode 100644 index 000000000..f12b4792f --- /dev/null +++ b/src/grt/grt-shadow_ieee.ads @@ -0,0 +1,41 @@ +-- GHDL Run Time (GRT) - ghost declarations for ieee. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +-- This packages provides dummy declaration for main IEEE.STD_LOGIC_1164 +-- type descriptors. +-- The package must not have elaboration code, since the actual type +-- descriptors are not writable (they are constant). Making it preelaborated +-- is not enough, the variables must be initialized. This current +-- implementation provides bad values; this is not a problem since they are +-- not read in grt. + +package Grt.Shadow_Ieee is + pragma Preelaborate (Grt.Shadow_Ieee); + + procedure Ieee_Std_Logic_1164_Resolved_RESOLV; +private + pragma Export (C, Ieee_Std_Logic_1164_Resolved_RESOLV, + "ieee__std_logic_1164__resolved_RESOLV"); +end Grt.Shadow_Ieee; diff --git a/src/grt/grt-signals.adb b/src/grt/grt-signals.adb new file mode 100644 index 000000000..9698d8178 --- /dev/null +++ b/src/grt/grt-signals.adb @@ -0,0 +1,3400 @@ +-- GHDL Run Time (GRT) - signals management. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Ada.Unchecked_Deallocation; +with Grt.Errors; use Grt.Errors; +with Grt.Processes; use Grt.Processes; +with Grt.Options; use Grt.Options; +with Grt.Rtis_Types; use Grt.Rtis_Types; +with Grt.Disp_Signals; +with Grt.Astdio; +with Grt.Stdio; +with Grt.Threads; use Grt.Threads; + +package body Grt.Signals is + procedure Free is new Ada.Unchecked_Deallocation + (Object => Transaction, Name => Transaction_Acc); + + procedure Free_In (Trans : Transaction_Acc) + is + Ntrans : Transaction_Acc; + begin + Ntrans := Trans; + Free (Ntrans); + end Free_In; + pragma Inline (Free_In); + + -- RTI for the current signal. + Sig_Rti : Ghdl_Rtin_Object_Acc; + + -- Signal mode (and flags) for the current signal. + Sig_Mode : Mode_Signal_Type; + Sig_Has_Active : Boolean; + Sig_Kind : Kind_Signal_Type; + + -- Last created implicit signal. This is used to add dependencies on + -- the prefix. + Last_Implicit_Signal : Ghdl_Signal_Ptr; + + -- Current signal resolver. + Current_Resolv : Resolved_Signal_Acc := null; + + function Get_Current_Mode_Signal return Mode_Signal_Type is + begin + return Sig_Mode; + end Get_Current_Mode_Signal; + + procedure Ghdl_Signal_Name_Rti (Sig : Ghdl_Rti_Access; + Ctxt : Ghdl_Rti_Access; + Addr : Address) + is + pragma Unreferenced (Ctxt); + pragma Unreferenced (Addr); + begin + Sig_Rti := To_Ghdl_Rtin_Object_Acc (Sig); + Sig_Mode := Mode_Signal_Type'Val + (Sig.Mode and Ghdl_Rti_Signal_Mode_Mask); + Sig_Kind := Kind_Signal_Type'Val + ((Sig.Mode and Ghdl_Rti_Signal_Kind_Mask) + / Ghdl_Rti_Signal_Kind_Offset); + Sig_Has_Active := + (Sig_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0; + end Ghdl_Signal_Name_Rti; + + procedure Ghdl_Signal_Set_Mode (Mode : Mode_Signal_Type; + Kind : Kind_Signal_Type; + Has_Active : Boolean) is + begin + Sig_Rti := null; + Sig_Mode := Mode; + Sig_Kind := Kind; + Sig_Has_Active := Has_Active; + end Ghdl_Signal_Set_Mode; + + function Is_Signal_Guarded (Sig : Ghdl_Signal_Ptr) return Boolean is + begin + return Sig.Sig_Kind /= Kind_Signal_No; + end Is_Signal_Guarded; + + function To_Address is new Ada.Unchecked_Conversion + (Source => Ghdl_Signal_Ptr, Target => Address); + + function Create_Signal + (Mode : Mode_Type; + Init_Val : Value_Union; + Mode_Sig : Mode_Signal_Type; + Resolv_Proc : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; + Resolv : Resolved_Signal_Acc; + S : Ghdl_Signal_Data (Mode_Sig); + begin + Sig_Table.Increment_Last; + + if Current_Resolv = null then + if Resolv_Proc /= null then + Resolv := new Resolved_Signal_Type' + (Resolv_Proc => Resolv_Proc, + Resolv_Inst => Resolv_Inst, + Resolv_Ptr => Null_Address, + Sig_Range => (Sig_Table.Last, Sig_Table.Last), + Disconnect_Time => Bad_Time); + else + Resolv := null; + end if; + else + if Resolv_Proc /= null then + -- Only one resolution function is allowed! + Internal_Error ("create_signal"); + end if; + Resolv := Current_Resolv; + if Current_Resolv.Sig_Range.Last = Sig_Table.Last then + Current_Resolv := null; + end if; + end if; + + case Mode_Sig is + when Mode_Signal_User => + S.Nbr_Drivers := 0; + S.Drivers := null; + S.Effective := null; + S.Resolv := Resolv; + when Mode_Conv_In + | Mode_Conv_Out => + S.Conv := null; + when Mode_Stable + | Mode_Quiet + | Mode_Delayed => + S.Time := 0; + when Mode_Guard => + S.Guard_Func := null; + S.Guard_Instance := System.Null_Address; + when Mode_Transaction + | Mode_End => + null; + end case; + + Res := new Ghdl_Signal'(Value => Init_Val, + Driving_Value => Init_Val, + Last_Value => Init_Val, + -- Note: use -Std_Time'last instead of + -- Std_Time'First so that NOW - x'last_event + -- returns time'high at initialization! + Last_Event => -Std_Time'Last, + Last_Active => -Std_Time'Last, + Event => False, + Active => False, + Has_Active => False, + Sig_Kind => Sig_Kind, + + Is_Direct_Active => False, + Mode => Mode, + Flags => (Propag => Propag_None, + Is_Dumped => False, + Cyc_Event => False, + Seen => False), + + Net => No_Signal_Net, + Link => null, + Alink => null, + Flink => null, + + Event_List => null, + Rti => Sig_Rti, + + Nbr_Ports => 0, + Ports => null, + + S => S); + + if Resolv /= null and then Resolv.Resolv_Ptr = System.Null_Address then + Resolv.Resolv_Ptr := To_Address (Res); + end if; + + case Flag_Activity is + when Activity_All => + Res.Has_Active := True; + when Activity_Minimal => + Res.Has_Active := Sig_Has_Active; + when Activity_None => + Res.Has_Active := False; + end case; + + -- Put the signal in the table. + Sig_Table.Table (Sig_Table.Last) := Res; + + return Res; + end Create_Signal; + + procedure Ghdl_Signal_Init (Sig : Ghdl_Signal_Ptr; Val : Value_Union) is + begin + Sig.Value := Val; + Sig.Driving_Value := Val; + Sig.Last_Value := Val; + end Ghdl_Signal_Init; + + procedure Ghdl_Signal_Merge_Rti (Sig : Ghdl_Signal_Ptr; + Rti : Ghdl_Rti_Access) + is + S_Rti : Ghdl_Rtin_Object_Acc; + begin + S_Rti := To_Ghdl_Rtin_Object_Acc (Rti); + if Flag_Activity = Activity_Minimal then + if (S_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0 then + Sig.Has_Active := True; + end if; + end if; + end Ghdl_Signal_Merge_Rti; + + procedure Ghdl_Signal_Create_Resolution (Proc : Resolver_Acc; + Instance : System.Address; + Sig : System.Address; + Nbr_Sig : Ghdl_Index_Type) + is + begin + if Current_Resolv /= null then + Internal_Error ("Ghdl_Signal_Create_Resolution"); + end if; + Current_Resolv := new Resolved_Signal_Type' + (Resolv_Proc => Proc, + Resolv_Inst => Instance, + Resolv_Ptr => Sig, + Sig_Range => (First => Sig_Table.Last + 1, + Last => Sig_Table.Last + Sig_Table_Index (Nbr_Sig)), + Disconnect_Time => Bad_Time); + end Ghdl_Signal_Create_Resolution; + + procedure Check_New_Source (Sig : Ghdl_Signal_Ptr) + is + use Grt.Stdio; + use Grt.Astdio; + begin + if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 0 then + if Sig.S.Resolv = null then + -- LRM 4.3.1.2 Signal Declaration + -- It is an error if, after the elaboration of a description, a + -- signal has multiple sources and it is not a resolved signal. + if Sig.Rti /= null then + Put ("for signal: "); + Disp_Signals.Put_Signal_Name (stderr, Sig); + New_Line (stderr); + end if; + Error ("several sources for unresolved signal"); + elsif Sig.S.Mode_Sig = Mode_Buffer and False then + -- LRM 1.1.1.2 Ports + -- A BUFFER port may have at most one source. + + -- FIXME: this is not true with VHDL-02. + -- With VHDL-87/93, should also check that: any actual associated + -- with a formal buffer port may have at most one source. + Error ("buffer port which more than one source"); + end if; + end if; + end Check_New_Source; + + -- Return TRUE if already present. + function Ghdl_Signal_Add_Driver (Sign : Ghdl_Signal_Ptr; + Trans : Transaction_Acc) + return Boolean + is + type Size_T is mod 2**Standard'Address_Size; + + function Malloc (Size : Size_T) return Driver_Arr_Ptr; + pragma Import (C, Malloc); + + function Realloc (Ptr : Driver_Arr_Ptr; Size : Size_T) + return Driver_Arr_Ptr; + pragma Import (C, Realloc); + + function Size (N : Ghdl_Index_Type) return Size_T is + begin + return Size_T (N * Driver_Fat_Array'Component_Size + / System.Storage_Unit); + end Size; + + Proc : Process_Acc; + begin + Proc := Get_Current_Process; + if Sign.S.Nbr_Drivers = 0 then + Check_New_Source (Sign); + Sign.S.Drivers := Malloc (Size (1)); + Sign.S.Nbr_Drivers := 1; + else + -- Do not create a driver twice. + for I in 0 .. Sign.S.Nbr_Drivers - 1 loop + if Sign.S.Drivers (I).Proc = Proc then + return True; + end if; + end loop; + Check_New_Source (Sign); + Sign.S.Nbr_Drivers := Sign.S.Nbr_Drivers + 1; + Sign.S.Drivers := Realloc (Sign.S.Drivers, Size (Sign.S.Nbr_Drivers)); + end if; + Sign.S.Drivers (Sign.S.Nbr_Drivers - 1) := + (First_Trans => Trans, + Last_Trans => Trans, + Proc => Proc); + return False; + end Ghdl_Signal_Add_Driver; + + procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Sign.Value); + if Ghdl_Signal_Add_Driver (Sign, Trans) then + Free (Trans); + end if; + end Ghdl_Process_Add_Driver; + + procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr; + Drv : Ghdl_Value_Ptr) + is + Trans : Transaction_Acc; + Trans1 : Transaction_Acc; + begin + -- Create transaction for current driving value. + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Sign.Value); + if Ghdl_Signal_Add_Driver (Sign, Trans) then + Free (Trans); + return; + end if; + -- Create transaction for the next driving value. + Trans1 := new Transaction'(Kind => Trans_Direct, + Line => 0, + Time => 0, + Next => null, + Val_Ptr => Drv); + Sign.S.Drivers (Sign.S.Nbr_Drivers - 1).Last_Trans := Trans1; + Trans.Next := Trans1; + end Ghdl_Signal_Add_Direct_Driver; + + procedure Append_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr) + is + type Size_T is new Integer; + + function Malloc (Size : Size_T) return Signal_Arr_Ptr; + pragma Import (C, Malloc); + + function Realloc (Ptr : Signal_Arr_Ptr; Size : Size_T) + return Signal_Arr_Ptr; + pragma Import (C, Realloc); + + function Size (N : Ghdl_Index_Type) return Size_T is + begin + return Size_T (N * Ghdl_Signal_Ptr'Size / System.Storage_Unit); + end Size; + begin + if Targ.Nbr_Ports = 0 then + Targ.Ports := Malloc (Size (1)); + Targ.Nbr_Ports := 1; + else + Targ.Nbr_Ports := Targ.Nbr_Ports + 1; + Targ.Ports := Realloc (Targ.Ports, Size (Targ.Nbr_Ports)); + end if; + Targ.Ports (Targ.Nbr_Ports - 1) := Src; + end Append_Port; + + -- Add SRC to port list of TARG, but only if not already in this list. + procedure Add_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr) + is + begin + for I in 1 .. Targ.Nbr_Ports loop + if Targ.Ports (I - 1) = Src then + return; + end if; + end loop; + Append_Port (Targ, Src); + end Add_Port; + + procedure Ghdl_Signal_Add_Source (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr) + is + begin + Check_New_Source (Targ); + Append_Port (Targ, Src); + end Ghdl_Signal_Add_Source; + + procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr; + Time : Std_Time) is + begin + if Sign.S.Resolv = null then + Internal_Error ("ghdl_signal_set_disconnect: not resolved"); + end if; + if Sign.S.Resolv.Disconnect_Time /= Bad_Time then + Error ("disconnection already specified for signal"); + end if; + if Time < 0 then + Error ("disconnection time is negative"); + end if; + Sign.S.Resolv.Disconnect_Time := Time; + end Ghdl_Signal_Set_Disconnect; + + procedure Direct_Assign + (Targ : out Value_Union; Val : Ghdl_Value_Ptr; Mode : Mode_Type) + is + begin + case Mode is + when Mode_B1 => + Targ.B1 := Val.B1; + when Mode_E8 => + Targ.E8 := Val.E8; + when Mode_E32 => + Targ.E32 := Val.E32; + when Mode_I32 => + Targ.I32 := Val.I32; + when Mode_I64 => + Targ.I64 := Val.I64; + when Mode_F64 => + Targ.F64 := Val.F64; + end case; + end Direct_Assign; + + function Value_Equal (Left, Right : Value_Union; Mode : Mode_Type) + return Boolean + is + begin + case Mode is + when Mode_B1 => + return Left.B1 = Right.B1; + when Mode_E8 => + return Left.E8 = Right.E8; + when Mode_E32 => + return Left.E32 = Right.E32; + when Mode_I32 => + return Left.I32 = Right.I32; + when Mode_I64 => + return Left.I64 = Right.I64; + when Mode_F64 => + return Left.F64 = Right.F64; + end case; + end Value_Equal; + + procedure Error_Trans_Error (Trans : Transaction_Acc) is + begin + Error_C ("range check error on signal at "); + Error_C (Trans.File); + Error_C (":"); + Error_C (Natural (Trans.Line)); + Error_E (""); + end Error_Trans_Error; + pragma No_Return (Error_Trans_Error); + + function Find_Driver (Sig : Ghdl_Signal_Ptr) return Ghdl_Index_Type + is + Proc : Process_Acc; + begin + if Sig.S.Drivers = null then + Error ("assignment to a signal without any driver"); + end if; + Proc := Get_Current_Process; + for I in 0 .. Sig.S.Nbr_Drivers - 1 loop + if Sig.S.Drivers (I).Proc = Proc then + return I; + end if; + end loop; + Error ("assignment to a signal without a driver for the process"); + end Find_Driver; + + function Get_Driver (Sig : Ghdl_Signal_Ptr) return Driver_Acc + is + Proc : Process_Acc; + begin + if Sig.S.Drivers = null then + return null; + end if; + Proc := Get_Current_Process; + for I in 0 .. Sig.S.Nbr_Drivers - 1 loop + if Sig.S.Drivers (I).Proc = Proc then + return Sig.S.Drivers (I)'Access; + end if; + end loop; + return null; + end Get_Driver; + + -- Return TRUE iff SIG has a future transaction for the current time, + -- ie iff SIG will be active in the next delta cycle. This is used to + -- recompute wether SIG must be in the active chain. SIG must be a user + -- signal. + function Has_Transaction_In_Next_Delta (Sig : Ghdl_Signal_Ptr) + return Boolean is + begin + if Sig.Is_Direct_Active then + return True; + end if; + + for I in 1 .. Sig.S.Nbr_Drivers loop + declare + Trans : constant Transaction_Acc := + Sig.S.Drivers (I - 1).First_Trans.Next; + begin + if Trans.Kind /= Trans_Direct + and then Trans.Time = Current_Time + then + return True; + end if; + end; + end loop; + return False; + end Has_Transaction_In_Next_Delta; + + -- Unused but well-known signal which always terminate + -- ghdl_signal_active_chain. + -- As a consequence, every element of the chain has a link field set to + -- a non-null value (this is of course not true for SIGNAL_END). This may + -- be used to quickly check if a signal is in the list. + -- This signal is not in the signal table. + Signal_End : Ghdl_Signal_Ptr; + + -- List of signals which have projected waveforms in the future (beyond + -- the next delta cycle). + Future_List : aliased Ghdl_Signal_Ptr; + + procedure Ghdl_Signal_Start_Assign (Sign : Ghdl_Signal_Ptr; + Reject : Std_Time; + Trans : Transaction_Acc; + After : Std_Time) + is + Assign_Time : Std_Time; + Drv : constant Ghdl_Index_Type := Find_Driver (Sign); + Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers; + Driver : Driver_Type renames Drv_Ptr (Drv); + begin + -- LRM93 8.4.1 + -- It is an error if the time expression in a waveform element + -- evaluates to a negative value. + if After < 0 then + Error ("negative time expression in signal assignment"); + end if; + + if After = 0 then + -- Put SIGN on the active list if the transaction is scheduled + -- for the next delta cycle. + if Sign.Link = null then + Sign.Link := Grt.Threads.Atomic_Insert + (Ghdl_Signal_Active_Chain'access, Sign); + end if; + else + -- AFTER > 0. + -- Put SIGN on the future list. + if Sign.Flink = null then + Sign.Flink := Grt.Threads.Atomic_Insert (Future_List'access, Sign); + end if; + end if; + + Assign_Time := Current_Time + After; + if Assign_Time < 0 then + -- Beyond the future + Free_In (Trans); + return; + end if; + + -- Handle sign as direct driver. + if Driver.Last_Trans.Kind = Trans_Direct then + if After /= 0 then + Internal_Error ("direct assign with non-0 after"); + end if; + -- FIXME: can be a bound-error too! + if Trans.Kind = Trans_Value then + case Sign.Mode is + when Mode_B1 => + Driver.Last_Trans.Val_Ptr.B1 := Trans.Val.B1; + when Mode_E8 => + Driver.Last_Trans.Val_Ptr.E8 := Trans.Val.E8; + when Mode_E32 => + Driver.Last_Trans.Val_Ptr.E32 := Trans.Val.E32; + when Mode_I32 => + Driver.Last_Trans.Val_Ptr.I32 := Trans.Val.I32; + when Mode_I64 => + Driver.Last_Trans.Val_Ptr.I64 := Trans.Val.I64; + when Mode_F64 => + Driver.Last_Trans.Val_Ptr.F64 := Trans.Val.F64; + end case; + Free_In (Trans); + elsif Trans.Kind = Trans_Error then + Error_Trans_Error (Trans); + else + Internal_Error ("direct assign with non-value"); + end if; + return; + end if; + + -- LRM93 8.4.1 + -- 1. All old transactions that are projected to occur at or after the + -- time at which the earliest new transaction is projected to occur + -- are deleted from the projected output waveform. + if Driver.Last_Trans.Time >= Assign_Time then + declare + -- LAST is the last transaction to keep. + Last : Transaction_Acc; + Next : Transaction_Acc; + begin + Last := Driver.First_Trans; + -- Find the first transaction to be deleted. + Next := Last.Next; + while Next /= null and then Next.Time < Assign_Time loop + Last := Next; + Next := Next.Next; + end loop; + -- Delete old transactions. + if Next /= null then + -- Set the last transaction of the driver. + Driver.Last_Trans := Last; + -- Cut the chain. This is not strickly necessary, since + -- it will be overriden below, by appending TRANS to the + -- driver. + Last.Next := null; + -- Free removed transactions. + loop + Last := Next.Next; + Free (Next); + exit when Last = null; + Next := Last; + end loop; + end if; + end; + end if; + + -- 2. The new transaction are then appended to the projected output + -- waveform in the order of their projected occurence. + Trans.Time := Assign_Time; + Driver.Last_Trans.Next := Trans; + Driver.Last_Trans := Trans; + + -- If the initial delay is inertial delay according to the definitions + -- of section 8.4, the projected output waveform is further modified + -- as follows: + -- 1. All of the new transactions are marked. + -- 2. An old transaction is marked if the time at which it is projected + -- to occur is less than the time at which the first new transaction + -- is projected to occur minus the pulse rejection limit. + -- 3. For each remaining unmarked, old transaction, the old transaction + -- is marked if it immediatly precedes a marked transaction and its + -- value component is the same as that of the marked transaction; + -- 4. The transaction that determines the current value of the driver + -- is marked. + -- 5. All unmarked transactions (all of which are old transactions) are + -- deleted from the projected output waveform. + -- + -- GHDL: only transactions that are projected to occur at [T-R, T[ + -- can be deleted (R is the reject time, T is now + after time). + if Reject > 0 then + -- LRM93 8.4 + -- It is an error if the pulse rejection limit for any inertially + -- delayed signal assignment statement is [...] or greater than the + -- time expression associated with the first waveform element. + if Reject > After then + Error ("pulse rejection greater than first waveform delay"); + end if; + + declare + Prev : Transaction_Acc; + Next : Transaction_Acc; + begin + -- Find the first transaction after the project time less the + -- rejection time. + -- PREV will be the last old transaction which is projected to + -- occur before T - R. + Prev := Driver.First_Trans; + loop + Next := Prev.Next; + exit when Next.Time >= Assign_Time - Reject; + Prev := Next; + end loop; + + -- Scan every transaction until TRANS. If a transaction value is + -- different from the TRANS value, then delete all previous + -- transactions (from T - R to the currently scanned transaction), + -- since they are not marked. + while Next /= Trans loop + if Next.Kind /= Trans.Kind + or else + (Trans.Kind = Trans_Value + and then not Value_Equal (Next.Val, Trans.Val, Sign.Mode)) + then + -- NEXT is different from TRANS. + -- Delete ]PREV;NEXT]. + declare + D, N : Transaction_Acc; + begin + D := Prev.Next; + Next := Next.Next; + Prev.Next := Next; + loop + N := D.Next; + Free (D); + exit when N = Next; + D := N; + end loop; + end; + else + Next := Next.Next; + end if; + end loop; + + -- A previous assignment (with a 0 after time) may have put this + -- signal on the active chain. But maybe this previous + -- transaction has been removed (due to rejection) and therefore + -- this signal won't be active at the next delta. So remove it + -- from the active chain. This is a little bit costly (because + -- the chain is simply linked), but that issue doesn't appear + -- frequently. + if Sign.Link /= null + and then not Has_Transaction_In_Next_Delta (Sign) + then + if Ghdl_Signal_Active_Chain = Sign then + -- At the head of the chain. + -- FIXME: this is not atomic. + Ghdl_Signal_Active_Chain := Sign.Link; + else + -- In the middle of the chain. + declare + Prev : Ghdl_Signal_Ptr := Ghdl_Signal_Active_Chain; + begin + while Prev.Link /= Sign loop + Prev := Prev.Link; + end loop; + Prev.Link := Sign.Link; + end; + end if; + Sign.Link := null; + end if; + end; + elsif Reject /= 0 then + -- LRM93 8.4 + -- It is an error if the pulse rejection limit for any inertially + -- delayed signal assignment statement is either negative or [...]. + Error ("pulse rejection is negative"); + end if; + + -- Do some checks. + if Driver.Last_Trans.Next /= null then + Error ("ghdl_signal_start_assign internal_error"); + end if; + end Ghdl_Signal_Start_Assign; + + procedure Ghdl_Signal_Next_Assign (Sign : Ghdl_Signal_Ptr; + Val : Value_Union; + After : Std_Time) + is + Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers; + Driver : Driver_Type renames Drv_Ptr (Find_Driver (Sign)); + + Trans : Transaction_Acc; + begin + if After > 0 and then Sign.Flink = null then + -- Put SIGN on the future list. + Sign.Flink := Future_List; + Future_List := Sign; + end if; + + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => Current_Time + After, + Next => null, + Val => Val); + if Trans.Time <= Driver.Last_Trans.Time then + Error ("transactions not in ascending order"); + end if; + Driver.Last_Trans.Next := Trans; + Driver.Last_Trans := Trans; + end Ghdl_Signal_Next_Assign; + + procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr) is + begin + if Sign.Link = null then + Sign.Link := Grt.Threads.Atomic_Insert + (Ghdl_Signal_Active_Chain'access, Sign); + end if; + + -- Must be always set (as Sign.Link may be set by a regular driver). + Sign.Is_Direct_Active := True; + end Ghdl_Signal_Direct_Assign; + + procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr; + File : Ghdl_C_String; + Line : Ghdl_I32) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction'(Kind => Trans_Error, + Line => Line, + Time => 0, + Next => null, + File => File); + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_Error; + + procedure Ghdl_Signal_Start_Assign_Error (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction'(Kind => Trans_Error, + Line => Line, + Time => 0, + Next => null, + File => File); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_Error; + + procedure Ghdl_Signal_Next_Assign_Error (Sign : Ghdl_Signal_Ptr; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32) + is + Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers; + Driver : Driver_Type renames Drv_Ptr (Find_Driver (Sign)); + + Trans : Transaction_Acc; + begin + if After > 0 and then Sign.Flink = null then + -- Put SIGN on the future list. + Sign.Flink := Future_List; + Future_List := Sign; + end if; + + Trans := new Transaction'(Kind => Trans_Error, + Line => Line, + Time => Current_Time + After, + Next => null, + File => File); + if Trans.Time <= Driver.Last_Trans.Time then + Error ("transactions not in ascending order"); + end if; + Driver.Last_Trans.Next := Trans; + Driver.Last_Trans := Trans; + end Ghdl_Signal_Next_Assign_Error; + + procedure Ghdl_Signal_Start_Assign_Null (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + if not Is_Signal_Guarded (Sign) then + Error ("null transaction for a non-guarded target"); + end if; + Trans := new Transaction'(Kind => Trans_Null, + Line => 0, + Time => 0, + Next => null); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_Null; + + procedure Ghdl_Signal_Disconnect (Sign : Ghdl_Signal_Ptr) + is + Trans : Transaction_Acc; + Time : Std_Time; + begin + if not Is_Signal_Guarded (Sign) then + Error ("null transaction for a non-guarded target"); + end if; + Trans := new Transaction'(Kind => Trans_Null, + Line => 0, + Time => 0, + Next => null); + Time := Sign.S.Resolv.Disconnect_Time; + Ghdl_Signal_Start_Assign (Sign, Time, Trans, Time); + end Ghdl_Signal_Disconnect; + + procedure Ghdl_Signal_Associate (Sig : Ghdl_Signal_Ptr; Val : Value_Union) + is + begin + Sig.Value := Val; + Sig.Driving_Value := Val; + end Ghdl_Signal_Associate; + + function Ghdl_Create_Signal_B1 + (Init_Val : Ghdl_B1; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_B1; + + procedure Ghdl_Signal_Init_B1 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_B1) is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_B1, B1 => Init_Val)); + end Ghdl_Signal_Init_B1; + + procedure Ghdl_Signal_Associate_B1 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_B1) is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_B1, B1 => Val)); + end Ghdl_Signal_Associate_B1; + + procedure Ghdl_Signal_Simple_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.B1 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_B1, B1 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_B1; + + procedure Ghdl_Signal_Start_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_B1; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_B1, B1 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_B1; + + procedure Ghdl_Signal_Next_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_B1, B1 => Val), After); + end Ghdl_Signal_Next_Assign_B1; + + function Ghdl_Create_Signal_E8 + (Init_Val : Ghdl_E8; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_E8, Value_Union'(Mode => Mode_E8, E8 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_E8; + + procedure Ghdl_Signal_Init_E8 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E8) is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_E8, E8 => Init_Val)); + end Ghdl_Signal_Init_E8; + + procedure Ghdl_Signal_Associate_E8 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E8) is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_E8, E8 => Val)); + end Ghdl_Signal_Associate_E8; + + procedure Ghdl_Signal_Simple_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.E8 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E8, E8 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_E8; + + procedure Ghdl_Signal_Start_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E8; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E8, E8 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_E8; + + procedure Ghdl_Signal_Next_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_E8, E8 => Val), After); + end Ghdl_Signal_Next_Assign_E8; + + function Ghdl_Create_Signal_E32 + (Init_Val : Ghdl_E32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_E32, Value_Union'(Mode => Mode_E32, E32 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_E32; + + procedure Ghdl_Signal_Init_E32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E32) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_E32, E32 => Init_Val)); + end Ghdl_Signal_Init_E32; + + procedure Ghdl_Signal_Associate_E32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E32) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_E32, E32 => Val)); + end Ghdl_Signal_Associate_E32; + + procedure Ghdl_Signal_Simple_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.E32 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E32, E32 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_E32; + + procedure Ghdl_Signal_Start_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E32; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E32, E32 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_E32; + + procedure Ghdl_Signal_Next_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_E32, E32 => Val), After); + end Ghdl_Signal_Next_Assign_E32; + + function Ghdl_Create_Signal_I32 + (Init_Val : Ghdl_I32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_I32, Value_Union'(Mode => Mode_I32, I32 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_I32; + + procedure Ghdl_Signal_Init_I32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I32) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_I32, I32 => Init_Val)); + end Ghdl_Signal_Init_I32; + + procedure Ghdl_Signal_Associate_I32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I32) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_I32, I32 => Val)); + end Ghdl_Signal_Associate_I32; + + procedure Ghdl_Signal_Simple_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.I32 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I32, I32 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_I32; + + procedure Ghdl_Signal_Start_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I32; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I32, I32 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_I32; + + procedure Ghdl_Signal_Next_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_I32, I32 => Val), After); + end Ghdl_Signal_Next_Assign_I32; + + function Ghdl_Create_Signal_I64 + (Init_Val : Ghdl_I64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_I64, Value_Union'(Mode => Mode_I64, I64 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_I64; + + procedure Ghdl_Signal_Init_I64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I64) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_I64, I64 => Init_Val)); + end Ghdl_Signal_Init_I64; + + procedure Ghdl_Signal_Associate_I64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I64) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_I64, I64 => Val)); + end Ghdl_Signal_Associate_I64; + + procedure Ghdl_Signal_Simple_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.I64 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I64, I64 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_I64; + + procedure Ghdl_Signal_Start_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I64; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I64, I64 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_I64; + + procedure Ghdl_Signal_Next_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_I64, I64 => Val), After); + end Ghdl_Signal_Next_Assign_I64; + + function Ghdl_Create_Signal_F64 + (Init_Val : Ghdl_F64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_F64, Value_Union'(Mode => Mode_F64, F64 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_F64; + + procedure Ghdl_Signal_Init_F64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_F64) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_F64, F64 => Init_Val)); + end Ghdl_Signal_Init_F64; + + procedure Ghdl_Signal_Associate_F64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_F64) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_F64, F64 => Val)); + end Ghdl_Signal_Associate_F64; + + procedure Ghdl_Signal_Simple_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.F64 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_F64, F64 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_F64; + + procedure Ghdl_Signal_Start_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_F64; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_F64, F64 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_F64; + + procedure Ghdl_Signal_Next_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_F64, F64 => Val), After); + end Ghdl_Signal_Next_Assign_F64; + + procedure Ghdl_Signal_Internal_Checks + is + Sig : Ghdl_Signal_Ptr; + begin + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + + -- Check drivers. + case Sig.S.Mode_Sig is + when Mode_Signal_User => + for J in 1 .. Sig.S.Nbr_Drivers loop + declare + Trans : Transaction_Acc; + begin + Trans := Sig.S.Drivers (J - 1).First_Trans; + while Trans.Next /= null loop + if Trans.Next.Time < Trans.Time then + Internal_Error ("ghdl_signal_internal_checks: " + & "bad transaction order"); + end if; + Trans := Trans.Next; + end loop; + if Trans /= Sig.S.Drivers (J - 1).Last_Trans then + Internal_Error ("ghdl_signal_internal_checks: " + & "last transaction mismatch"); + end if; + end; + end loop; + when others => + null; + end case; + end loop; + end Ghdl_Signal_Internal_Checks; + + procedure Ghdl_Signal_Effective_Value (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr) + is + begin + if Targ.S.Effective /= null then + Error ("internal error: already effective value"); + end if; + Targ.S.Effective := Src; + end Ghdl_Signal_Effective_Value; + + Bit_Signal_Rti : aliased Ghdl_Rtin_Object := + (Common => (Kind => Ghdl_Rtik_Signal, + Depth => 0, + Mode => Ghdl_Rti_Signal_Mode_None, + Max_Depth => 0), + Name => null, + Loc => Null_Rti_Loc, + Obj_Type => null); + + Boolean_Signal_Rti : aliased Ghdl_Rtin_Object := + (Common => (Kind => Ghdl_Rtik_Signal, + Depth => 0, + Mode => Ghdl_Rti_Signal_Mode_None, + Max_Depth => 0), + Name => null, + Loc => Null_Rti_Loc, + Obj_Type => null); + + function Ghdl_Create_Signal_Attribute + (Mode : Mode_Signal_Type; Time : Std_Time) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; +-- Sig_Type : Ghdl_Desc_Ptr; + begin + case Mode is + when Mode_Transaction => + Sig_Rti := To_Ghdl_Rtin_Object_Acc + (To_Ghdl_Rti_Access (Bit_Signal_Rti'Address)); + when Mode_Quiet + | Mode_Stable => + Sig_Rti := To_Ghdl_Rtin_Object_Acc + (To_Ghdl_Rti_Access (Boolean_Signal_Rti'Address)); + when others => + Internal_Error ("ghdl_create_signal_attribute"); + end case; + -- Note: bit and boolean are both mode_b1. + Res := Create_Signal + (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => True), + Mode, null, Null_Address); + Sig_Rti := null; + Last_Implicit_Signal := Res; + + if Mode /= Mode_Transaction then + Res.S.Time := Time; + Res.S.Attr_Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Res.Value); + end if; + + if Time > 0 then + Res.Flink := Future_List; + Future_List := Res; + end if; + + return Res; + end Ghdl_Create_Signal_Attribute; + + function Ghdl_Create_Stable_Signal (Val : Std_Time) return Ghdl_Signal_Ptr + is + begin + return Ghdl_Create_Signal_Attribute (Mode_Stable, Val); + end Ghdl_Create_Stable_Signal; + + function Ghdl_Create_Quiet_Signal (Val : Std_Time) return Ghdl_Signal_Ptr + is + begin + return Ghdl_Create_Signal_Attribute (Mode_Quiet, Val); + end Ghdl_Create_Quiet_Signal; + + function Ghdl_Create_Transaction_Signal return Ghdl_Signal_Ptr + is + begin + return Ghdl_Create_Signal_Attribute (Mode_Transaction, 0); + end Ghdl_Create_Transaction_Signal; + + procedure Ghdl_Signal_Attribute_Register_Prefix (Sig : Ghdl_Signal_Ptr) + is + begin + Add_Port (Last_Implicit_Signal, Sig); + end Ghdl_Signal_Attribute_Register_Prefix; + + --Guard_String : constant String := "guard"; + --Guard_Name : constant Ghdl_Str_Len_Address_Type := + -- (Len => 5, Str => Guard_String'Address); + --function To_Ghdl_Str_Len_Ptr is new Ada.Unchecked_Conversion + -- (Source => System.Address, Target => Ghdl_Str_Len_Ptr); + + Guard_Rti : aliased constant Ghdl_Rtin_Object := + (Common => (Kind => Ghdl_Rtik_Signal, + Depth => 0, + Mode => Ghdl_Rti_Signal_Mode_None, + Max_Depth => 0), + Name => null, + Loc => Null_Rti_Loc, + Obj_Type => Std_Standard_Boolean_RTI_Ptr); + + function Ghdl_Signal_Create_Guard (This : System.Address; + Proc : Guard_Func_Acc) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; + begin + Sig_Rti := To_Ghdl_Rtin_Object_Acc + (To_Ghdl_Rti_Access (Guard_Rti'Address)); + Res := Create_Signal + (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => Proc.all (This)), + Mode_Guard, null, Null_Address); + Sig_Rti := null; + Res.S.Guard_Func := Proc; + Res.S.Guard_Instance := This; + Last_Implicit_Signal := Res; + return Res; + end Ghdl_Signal_Create_Guard; + + procedure Ghdl_Signal_Guard_Dependence (Sig : Ghdl_Signal_Ptr) + is + begin + Add_Port (Last_Implicit_Signal, Sig); + Sig.Has_Active := True; + end Ghdl_Signal_Guard_Dependence; + + function Ghdl_Create_Delayed_Signal (Sig : Ghdl_Signal_Ptr; Val : Std_Time) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; + begin + Res := Create_Signal (Sig.Mode, Sig.Value, + Mode_Delayed, null, Null_Address); + Res.S.Time := Val; + if Val > 0 then + Res.Flink := Future_List; + Future_List := Res; + end if; + Res.S.Attr_Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Res.Value); + Append_Port (Res, Sig); + return Res; + end Ghdl_Create_Delayed_Signal; + + function Signal_Ptr_To_Index (Ptr : Ghdl_Signal_Ptr) return Sig_Table_Index + is + begin + -- Note: we may start from ptr.instance_name.sig_index, but + -- instance_name is *not* set for conversion signals. + for I in reverse Sig_Table.First .. Sig_Table.Last loop + if Sig_Table.Table (I) = Ptr then + return I; + end if; + end loop; + return -1; + end Signal_Ptr_To_Index; + + function Ghdl_Signal_Get_Nbr_Ports (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type is + begin + return Sig.Nbr_Ports; + end Ghdl_Signal_Get_Nbr_Ports; + + function Ghdl_Signal_Get_Nbr_Drivers (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type is + begin + return Sig.S.Nbr_Drivers; + end Ghdl_Signal_Get_Nbr_Drivers; + + function Ghdl_Signal_Read_Port + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr + is + begin + if Index >= Sig.Nbr_Ports then + Internal_Error ("ghdl_signal_read_port: bad index"); + end if; + return To_Ghdl_Value_Ptr (Sig.Ports (Index).Driving_Value'Address); + end Ghdl_Signal_Read_Port; + + function Ghdl_Signal_Read_Driver + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr + is + Trans : Transaction_Acc; + begin + if Index >= Sig.S.Nbr_Drivers then + Internal_Error ("ghdl_signal_read_driver: bad index"); + end if; + Trans := Sig.S.Drivers (Index).First_Trans; + case Trans.Kind is + when Trans_Value => + return To_Ghdl_Value_Ptr (Trans.Val'Address); + when Trans_Direct => + Internal_Error ("ghdl_signal_read_driver: trans_direct"); + when Trans_Null => + return null; + when Trans_Error => + Error_Trans_Error (Trans); + end case; + end Ghdl_Signal_Read_Driver; + + procedure Ghdl_Signal_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type; + Mode : Mode_Signal_Type) + is + Data : Sig_Conversion_Acc; + Sig : Ghdl_Signal_Ptr; + begin + Data := new Sig_Conversion_Type'(Func => Func, + Instance => Instance, + Src => (-1, -1), + Dest => (-1, -1)); + Data.Src.First := Signal_Ptr_To_Index (Src); + Data.Src.Last := Data.Src.First + Sig_Table_Index (Src_Len) - 1; + + Data.Dest.First := Signal_Ptr_To_Index (Dst); + Data.Dest.Last := Data.Dest.First + Sig_Table_Index (Dst_Len) - 1; + + -- Convert DEST to new mode. + for I in Data.Dest.First .. Data.Dest.Last loop + Sig := Sig_Table.Table (I); + case Mode is + when Mode_Conv_In => + Sig.S := (Mode_Sig => Mode_Conv_In, + Conv => Data); + when Mode_Conv_Out => + Sig.S := (Mode_Sig => Mode_Conv_Out, + Conv => Data); + when others => + Internal_Error ("ghdl_signal_conversion"); + end case; + end loop; + end Ghdl_Signal_Conversion; + + procedure Ghdl_Signal_In_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type) + is + begin + Ghdl_Signal_Conversion + (Func, Instance, Src, Src_Len, Dst, Dst_Len, Mode_Conv_In); + end Ghdl_Signal_In_Conversion; + + procedure Ghdl_Signal_Out_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type) + is + begin + Ghdl_Signal_Conversion + (Func, Instance, Src, Src_Len, Dst, Dst_Len, Mode_Conv_Out); + end Ghdl_Signal_Out_Conversion; + + function Ghdl_Signal_Driving (Sig : Ghdl_Signal_Ptr) return Ghdl_B1 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null then + -- FIXME: disp signal and process. + Error ("'driving error: no driver in process for signal"); + end if; + if Drv.First_Trans.Kind /= Trans_Null then + return True; + else + return False; + end if; + end Ghdl_Signal_Driving; + + function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr) return Ghdl_B1 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.B1; + end if; + end Ghdl_Signal_Driving_Value_B1; + + function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E8 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.E8; + end if; + end Ghdl_Signal_Driving_Value_E8; + + function Ghdl_Signal_Driving_Value_E32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E32 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.E32; + end if; + end Ghdl_Signal_Driving_Value_E32; + + function Ghdl_Signal_Driving_Value_I32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I32 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.I32; + end if; + end Ghdl_Signal_Driving_Value_I32; + + function Ghdl_Signal_Driving_Value_I64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I64 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.I64; + end if; + end Ghdl_Signal_Driving_Value_I64; + + function Ghdl_Signal_Driving_Value_F64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_F64 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.F64; + end if; + end Ghdl_Signal_Driving_Value_F64; + + Ghdl_Implicit_Signal_Active_Chain : Ghdl_Signal_Ptr; + + procedure Flush_Active_List + is + Sig : Ghdl_Signal_Ptr; + Next_Sig : Ghdl_Signal_Ptr; + begin + -- Free active_chain. + Sig := Ghdl_Signal_Active_Chain; + loop + Next_Sig := Sig.Link; + exit when Next_Sig = null; + Sig.Link := null; + Sig := Next_Sig; + end loop; + Ghdl_Signal_Active_Chain := Sig; + end Flush_Active_List; + + function Find_Next_Time return Std_Time + is + Res : Std_Time; + Sig : Ghdl_Signal_Ptr; + + procedure Check_Transaction (Trans : Transaction_Acc) + is + begin + if Trans = null or else Trans.Kind = Trans_Direct then + -- Activity of direct drivers is done through link. + return; + end if; + + if Trans.Time = Res and Sig.Link = null then + Sig.Link := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Sig; + elsif Trans.Time < Res then + Flush_Active_List; + + -- Put sig on the list. + Sig.Link := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Sig; + + Res := Trans.Time; + end if; + if Res = Current_Time then + -- Must have been in the active list. + Internal_Error ("find_next_time(2)"); + end if; + end Check_Transaction; + begin + -- If there is signals in the active list, then next cycle is a delta + -- cycle, so next time is current_time. + if Ghdl_Signal_Active_Chain.Link /= null then + return Current_Time; + end if; + if Ghdl_Implicit_Signal_Active_Chain.Link /= null then + return Current_Time; + end if; + Res := Std_Time'Last; + + Sig := Future_List; + while Sig.Flink /= null loop + case Sig.S.Mode_Sig is + when Mode_Signal_User => + for J in 1 .. Sig.S.Nbr_Drivers loop + Check_Transaction (Sig.S.Drivers (J - 1).First_Trans.Next); + end loop; + when Mode_Delayed + | Mode_Stable + | Mode_Quiet => + Check_Transaction (Sig.S.Attr_Trans.Next); + when others => + Internal_Error ("find_next_time(3)"); + end case; + Sig := Sig.Flink; + end loop; + return Res; + end Find_Next_Time; + +-- function Get_Nbr_Non_Null_Source (Sig : Ghdl_Signal_Ptr) +-- return Natural +-- is +-- Length : Natural; +-- begin +-- Length := Sig.Nbr_Ports; +-- for I in 0 .. Sig.Nbr_Drivers - 1 loop +-- case Sig.Drivers (I).First_Trans.Kind is +-- when Trans_Value => +-- Length := Length + 1; +-- when Trans_Null => +-- null; +-- when Trans_Error => +-- Error ("range check error"); +-- end case; +-- end loop; +-- return Length; +-- end Get_Nbr_Non_Null_Source; + + function To_Resolver_Acc is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Resolver_Acc); + + procedure Compute_Resolved_Signal (Resolv : Resolved_Signal_Acc) + is + Sig : constant Ghdl_Signal_Ptr := + Sig_Table.Table (Resolv.Sig_Range.First); + Length : Ghdl_Index_Type; + type Bool_Array_Type is array (1 .. Sig.S.Nbr_Drivers) of Boolean; + Vec : Bool_Array_Type; + begin + -- Compute number of non-null drivers. + Length := 0; + for I in 1 .. Sig.S.Nbr_Drivers loop + case Sig.S.Drivers (I - 1).First_Trans.Kind is + when Trans_Value => + Length := Length + 1; + Vec (I) := True; + when Trans_Null => + Vec (I) := False; + when Trans_Error => + Error ("range check error"); + when Trans_Direct => + Internal_Error ("compute_resolved_signal: trans_direct"); + end case; + end loop; + + -- Check driving condition on all signals. + for J in Resolv.Sig_Range.First + 1.. Resolv.Sig_Range.Last loop + for I in 1 .. Sig.S.Nbr_Drivers loop + if (Sig_Table.Table (J).S.Drivers (I - 1).First_Trans.Kind + /= Trans_Null) + xor Vec (I) + then + Error ("null-transaction required"); + end if; + end loop; + end loop; + + -- if no driving sources and register, exit. + if Length = 0 + and then Sig.Nbr_Ports = 0 + and then Sig.Sig_Kind = Kind_Signal_Register + then + return; + end if; + + -- Call the procedure. + Resolv.Resolv_Proc.all (Resolv.Resolv_Inst, + Resolv.Resolv_Ptr, + Vec'Address, + Length, + Sig.S.Nbr_Drivers, + Sig.Nbr_Ports); + end Compute_Resolved_Signal; + + procedure Call_Conversion_Function (Conv : Sig_Conversion_Acc) + is + F : Conversion_Func_Acc; + begin + F := To_Conversion_Func_Acc (Conv.Func); + F.all (Conv.Instance); + end Call_Conversion_Function; + + procedure Resume_Process_If_Event + (Sig : Ghdl_Signal_Ptr; Proc : Process_Acc) + is + El : Action_List_Acc; + begin + El := new Action_List'(Dynamic => False, + Proc => Proc, + Next => Sig.Event_List); + Sig.Event_List := El; + end Resume_Process_If_Event; + + -- Order of signals: + -- To be computed: driving value or/and effective value + -- To be considered: ports, signals, implicit signals, resolution, + -- conversion + -- + + procedure Add_Propagation (P : Propagation_Type) is + begin + Propagation.Increment_Last; + Propagation.Table (Propagation.Last) := P; + end Add_Propagation; + + procedure Add_Forward_Propagation (Sig : Ghdl_Signal_Ptr) + is + begin + for I in 1 .. Sig.Nbr_Ports loop + Add_Propagation + ((Kind => Imp_Forward_Build, + Forward => new Forward_Build_Type'(Src => Sig.Ports (I - 1), + Targ => Sig))); + end loop; + end Add_Forward_Propagation; + + -- Put SIG in PROPAGATION table until ORDER level. + procedure Order_Signal (Sig : Ghdl_Signal_Ptr; Order : Propag_Order_Flag); + + -- Return TRUE is the effective value of SIG is the driving value of SIG. + function Is_Eff_Drv (Sig : Ghdl_Signal_Ptr) return Boolean + is + begin + case Sig.S.Mode_Sig is + when Mode_Signal + | Mode_Buffer => + return True; + when Mode_Linkage + | Mode_Out => + -- No effective value. + return False; + when Mode_Inout + | Mode_In => + if Sig.S.Effective = null then + if Sig.S.Nbr_Drivers > 0 or Sig.Nbr_Ports > 0 then + -- Only for inout. + return True; + else + return False; + end if; + else + return False; + end if; + when Mode_Conv_In + | Mode_Conv_Out => + return False; + when Mode_Stable + | Mode_Guard + | Mode_Quiet + | Mode_Transaction + | Mode_Delayed => + return True; + when Mode_End => + return False; + end case; + end Is_Eff_Drv; + + procedure Order_Signal_List (Sig : Ghdl_Signal_Ptr; + Order : Propag_Order_Flag) + is + begin + for I in 1 .. Sig.Nbr_Ports loop + Order_Signal (Sig.Ports (I - 1), Order); + end loop; + end Order_Signal_List; + + -- Put SIG in PROPAGATION table until ORDER level. + procedure Order_Signal (Sig : Ghdl_Signal_Ptr; Order : Propag_Order_Flag) + is + begin + if Sig = null then + return; + end if; + + -- Catch infinite loops, which must never happen. + -- Also exit if the signal is already fully ordered. + case Sig.Flags.Propag is + when Propag_None => + null; + when Propag_Being_Driving => + Internal_Error ("order_signal: being driving"); + when Propag_Being_Effective => + Internal_Error ("order_signal: being effective"); + when Propag_Driving => + null; + when Propag_Done => + -- If sig was already handled, nothing to do! + return; + end case; + + -- First, the driving value. + if Sig.Flags.Propag = Propag_None then + case Sig.S.Mode_Sig is + when Mode_Signal_User => + if Sig.S.Nbr_Drivers = 0 and Sig.Nbr_Ports = 0 then + -- No source. + Sig.Flags.Propag := Propag_Driving; + elsif Sig.S.Resolv = null then + -- Not resolved (so at most one source). + if Sig.S.Nbr_Drivers = 1 then + -- Not resolved, 1 source : a driver. + if Is_Eff_Drv (Sig) then + Add_Propagation ((Kind => Eff_One_Driver, Sig => Sig)); + Sig.Flags.Propag := Propag_Done; + else + Add_Propagation ((Kind => Drv_One_Driver, Sig => Sig)); + Sig.Flags.Propag := Propag_Driving; + end if; + else + Sig.Flags.Propag := Propag_Being_Driving; + -- not resolved, 1 source : Source is a port. + Order_Signal (Sig.Ports (0), Propag_Driving); + if Is_Eff_Drv (Sig) then + Add_Propagation ((Kind => Eff_One_Port, Sig => Sig)); + Sig.Flags.Propag := Propag_Done; + else + Add_Propagation ((Kind => Drv_One_Port, Sig => Sig)); + Sig.Flags.Propag := Propag_Driving; + end if; + end if; + else + -- Resolved signal. + declare + Resolv : Resolved_Signal_Acc; + S : Ghdl_Signal_Ptr; + begin + -- Compute driving value of brothers. + Resolv := Sig.S.Resolv; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + S := Sig_Table.Table (I); + if S.Flags.Propag /= Propag_None then + Internal_Error ("order_signal(1)"); + end if; + S.Flags.Propag := Propag_Being_Driving; + end loop; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + S := Sig_Table.Table (I); + -- Compute driving value of the sources. + for J in 1 .. S.Nbr_Ports loop + Order_Signal (S.Ports (J - 1), Propag_Driving); + end loop; + end loop; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + S := Sig_Table.Table (I); + S.Flags.Propag := Propag_Driving; + end loop; + + if Is_Eff_Drv (Sig) then + if Resolv.Sig_Range.First = Resolv.Sig_Range.Last then + Add_Propagation ((Kind => Eff_One_Resolved, + Sig => Sig)); + else + Add_Propagation ((Kind => Eff_Multiple, + Resolv => Resolv)); + end if; + else + if Resolv.Sig_Range.First = Resolv.Sig_Range.Last then + Add_Propagation ((Kind => Drv_One_Resolved, + Sig => Sig)); + else + Add_Propagation ((Kind => Drv_Multiple, + Resolv => Resolv)); + end if; + end if; + end; + end if; + when Mode_Signal_Implicit => + Sig.Flags.Propag := Propag_Being_Driving; + Order_Signal_List (Sig, Propag_Done); + Sig.Flags.Propag := Propag_Done; + if Sig.S.Mode_Sig in Mode_Signal_Forward then + Add_Forward_Propagation (Sig); + end if; + case Mode_Signal_Implicit (Sig.S.Mode_Sig) is + when Mode_Guard => + Add_Propagation ((Kind => Imp_Guard, Sig => Sig)); + when Mode_Stable => + Add_Propagation ((Kind => Imp_Stable, Sig => Sig)); + when Mode_Quiet => + Add_Propagation ((Kind => Imp_Quiet, Sig => Sig)); + when Mode_Transaction => + Add_Propagation ((Kind => Imp_Transaction, Sig => Sig)); + when Mode_Delayed => + Add_Propagation ((Kind => Imp_Delayed, Sig => Sig)); + end case; + return; + when Mode_Conv_In => + -- In conversion signals have no driving value + null; + when Mode_Conv_Out => + declare + Conv : Sig_Conversion_Acc; + begin + Conv := Sig.S.Conv; + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Being_Driving; + end loop; + for I in Conv.Src.First .. Conv.Src.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Driving); + end loop; + Add_Propagation ((Kind => Out_Conversion, Conv => Conv)); + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Done; + end loop; + end; + when Mode_End => + Internal_Error ("order_signal: mode_end"); + end case; + end if; + + -- Effective value. + if Order = Propag_Driving then + -- Will be done later. + return; + end if; + + case Sig.S.Mode_Sig is + when Mode_Signal + | Mode_Buffer => + -- Effective value is driving value. + Sig.Flags.Propag := Propag_Done; + when Mode_Linkage + | Mode_Out => + -- No effective value. + Sig.Flags.Propag := Propag_Done; + when Mode_Inout + | Mode_In => + if Sig.S.Effective = null then + -- Effective value is driving value or initial value. + null; + else + Sig.Flags.Propag := Propag_Being_Effective; + Order_Signal (Sig.S.Effective, Propag_Done); + Add_Propagation ((Kind => Eff_Actual, Sig => Sig)); + Sig.Flags.Propag := Propag_Done; + end if; + when Mode_Stable + | Mode_Guard + | Mode_Quiet + | Mode_Transaction + | Mode_Delayed => + -- Sig.Propag is already set to PROPAG_DONE. + null; + when Mode_Conv_In => + declare + Conv : Sig_Conversion_Acc; + begin + Conv := Sig.S.Conv; + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Being_Effective; + end loop; + for I in Conv.Src.First .. Conv.Src.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Done); + end loop; + Add_Propagation ((Kind => In_Conversion, Conv => Conv)); + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Done; + end loop; + end; + when Mode_Conv_Out => + -- No effective value. + null; + when Mode_End => + Internal_Error ("order_signal: mode_end"); + end case; + end Order_Signal; + + procedure Set_Net (Sig : Ghdl_Signal_Ptr; + Net : Signal_Net_Type; + Link : Ghdl_Signal_Ptr) + is + use Astdio; + use Stdio; + begin + if Sig = null then + return; + end if; + + if Boolean'(False) then + Put ("set_net "); + Put_I32 (stdout, Ghdl_I32 (Net)); + Put (" on "); + Put (stdout, Sig.all'Address); + Put (" "); + Disp_Signals.Disp_Mode_Signal (Sig.S.Mode_Sig); + New_Line; + end if; + + if Sig.Net /= No_Signal_Net then + if Sig.Net /= Net then + -- Renumber. + if Boolean'(False) then + Put ("set_net renumber "); + Put_I32 (stdout, Ghdl_I32 (Net)); + Put (" on "); + Put (stdout, Sig.all'Address); + New_Line; + end if; + + declare + S : Ghdl_Signal_Ptr; + Old : constant Signal_Net_Type := Sig.Net; + begin + -- Merge the old net into NET. + S := Sig; + loop + S.Net := Net; + S := S.Link; + exit when S = Sig; + end loop; + + -- Add to the ring. + S := Sig.Link; + Sig.Link := Link.Link; + Link.Link := S; + + -- Check. + for I in Sig_Table.First .. Sig_Table.Last loop + if Sig_Table.Table (I).Net = Old then +-- Disp_Signals.Disp_Signals_Table; +-- Disp_Signals.Disp_Signals_Map; + + Internal_Error ("set_net: link corrupted"); + end if; + end loop; + end; + end if; + return; + end if; + + Sig.Net := Net; + + -- Add SIG in the LINK ring. + -- Note: this works even if LINK is not a ring (ie, LINK.link = null). + if Link.Link = null and then Sig /= Link then + Internal_Error ("set_net: bad link"); + end if; + Sig.Link := Link.Link; + Link.Link := Sig; + + -- Dependences. + case Sig.S.Mode_Sig is + when Mode_Signal_User => + for I in 1 .. Sig.Nbr_Ports loop + Set_Net (Sig.Ports (I - 1), Net, Link); + end loop; + Set_Net (Sig.S.Effective, Net, Link); + if Sig.S.Resolv /= null then + for I in Sig.S.Resolv.Sig_Range.First + .. Sig.S.Resolv.Sig_Range.Last + loop + Set_Net (Sig_Table.Table (I), Net, Link); + end loop; + end if; + when Mode_Signal_Forward => + null; + when Mode_Transaction + | Mode_Guard => + for I in 1 .. Sig.Nbr_Ports loop + Set_Net (Sig.Ports (I - 1), Net, Link); + end loop; + when Mode_Conv_In + | Mode_Conv_Out => + declare + S : Ghdl_Signal_Ptr; + Conv : Sig_Conversion_Acc; + begin + Conv := Sig.S.Conv; + S := Sig_Table.Table (Conv.Src.First); + if Sig = S or else S.Net /= Net then + for J in Conv.Src.First .. Conv.Src.Last loop + Set_Net (Sig_Table.Table (J), Net, Link); + end loop; + for J in Conv.Dest.First .. Conv.Dest.Last loop + Set_Net (Sig_Table.Table (J), Net, Link); + end loop; + end if; + end; + when Mode_End => + Internal_Error ("set_net"); + end case; + end Set_Net; + + function Get_Propagation_Net (P : Signal_Net_Type) return Signal_Net_Type + is + begin + case Propagation.Table (P).Kind is + when Drv_Multiple + | Eff_Multiple => + return Sig_Table.Table + (Propagation.Table (P).Resolv.Sig_Range.First).Net; + when In_Conversion + | Out_Conversion => + return Sig_Table.Table + (Propagation.Table (P).Conv.Src.First).Net; + when Imp_Forward_Build => + return Propagation.Table (P).Forward.Src.Net; + when others => + return Propagation.Table (P).Sig.Net; + end case; + end Get_Propagation_Net; + + Last_Signal_Net : Signal_Net_Type; + + -- Create a net for SIG, or if one of its dependences has already a net, + -- merge SIG in this net. + procedure Merge_Net (Sig : Ghdl_Signal_Ptr) + is + begin + if Sig.S.Mode_Sig in Mode_Signal_User then + if Sig.S.Resolv = null + and then Sig.Nbr_Ports = 0 + and then Sig.S.Effective = null + then + Internal_Error ("merge_net(1)"); + end if; + + if Sig.S.Effective /= null + and then Sig.S.Effective.Net /= No_Signal_Net + then + -- Avoid to create a net, just merge. + Set_Net (Sig, Sig.S.Effective.Net, Sig.S.Effective); + return; + end if; + end if; + + if Sig.Nbr_Ports >= 1 + and then Sig.Ports (0).Net /= No_Signal_Net + then + -- Avoid to create a net, just merge. + Set_Net (Sig, Sig.Ports (0).Net, Sig.Ports (0)); + else + Last_Signal_Net := Last_Signal_Net + 1; + Set_Net (Sig, Last_Signal_Net, Sig); + end if; + end Merge_Net; + + -- Create nets. + -- For all signals, set the net field. + procedure Create_Nets + is + Sig : Ghdl_Signal_Ptr; + begin + Last_Signal_Net := No_Signal_Net; + + for I in reverse Propagation.First .. Propagation.Last loop + case Propagation.Table (I).Kind is + when Drv_Error + | Prop_End => + null; + when Drv_One_Driver + | Eff_One_Driver => + null; + when Eff_One_Resolved => + Sig := Propagation.Table (I).Sig; + -- Do not create a net if the signal has no dependences. + if Sig.Net = No_Signal_Net + and then (Sig.S.Effective /= null or Sig.Nbr_Ports /= 0) + then + Merge_Net (Sig); + end if; + when Drv_One_Port + | Eff_One_Port + | Imp_Guard + | Imp_Transaction + | Eff_Actual + | Drv_One_Resolved => + Sig := Propagation.Table (I).Sig; + if Sig.Net = No_Signal_Net then + Merge_Net (Sig); + end if; + when Imp_Forward => + -- Should not yet appear. + Internal_Error ("create_nets - forward"); + when Imp_Forward_Build => + Sig := Propagation.Table (I).Forward.Src; + if Sig.Net = No_Signal_Net then + -- Create a new net with only sig. + Last_Signal_Net := Last_Signal_Net + 1; + Set_Net (Sig, Last_Signal_Net, Sig); + end if; + when Imp_Quiet + | Imp_Stable + | Imp_Delayed => + Sig := Propagation.Table (I).Sig; + if Sig.Net = No_Signal_Net then + -- Create a new net with only sig. + Last_Signal_Net := Last_Signal_Net + 1; + Sig.Net := Last_Signal_Net; + Sig.Link := Sig; + end if; + when Drv_Multiple + | Eff_Multiple => + declare + Resolv : Resolved_Signal_Acc; + Link : Ghdl_Signal_Ptr; + begin + Last_Signal_Net := Last_Signal_Net + 1; + Resolv := Propagation.Table (I).Resolv; + Link := Sig_Table.Table (Resolv.Sig_Range.First); + for J in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop + Set_Net (Sig_Table.Table (J), Last_Signal_Net, Link); + end loop; + end; + when In_Conversion + | Out_Conversion => + declare + Conv : Sig_Conversion_Acc; + Link : Ghdl_Signal_Ptr; + begin + Conv := Propagation.Table (I).Conv; + Link := Sig_Table.Table (Conv.Src.First); + if Link.Net = No_Signal_Net then + Last_Signal_Net := Last_Signal_Net + 1; + Set_Net (Link, Last_Signal_Net, Link); + end if; + end; + end case; + end loop; + + -- Reorder propagation table. + declare + type Off_Array is array (Signal_Net_Type range <>) of Signal_Net_Type; + Offs : Off_Array (0 .. Last_Signal_Net) := (others => 0); + + Last_Off : Signal_Net_Type; + Num : Signal_Net_Type; + +-- procedure Disp_Offs +-- is +-- use Grt.Astdio; +-- use Grt.Stdio; +-- begin +-- for I in Offs'Range loop +-- if Offs (I) /= 0 then +-- Put_I32 (stdout, Ghdl_I32 (I)); +-- Put (": "); +-- Put_I32 (stdout, Ghdl_I32 (Offs (I))); +-- New_Line; +-- end if; +-- end loop; +-- end Disp_Offs; + + type Propag_Array is array (Signal_Net_Type range <>) + of Propagation_Type; + + procedure Deallocate is new Ada.Unchecked_Deallocation + (Object => Forward_Build_Type, Name => Forward_Build_Acc); + + Net : Signal_Net_Type; + begin + -- 1) Count number of propagation cell per net. + for I in Propagation.First .. Propagation.Last loop + Net := Get_Propagation_Net (I); + Offs (Net) := Offs (Net) + 1; + end loop; + + -- 2) Convert numbers to offsets. + Last_Off := 1; + for I in 1 .. Last_Signal_Net loop + Num := Offs (I); + if Num /= 0 then + -- Reserve one slot for a prepended 'prop_end'. + Offs (I) := Last_Off + 1; + Last_Off := Last_Off + 1 + Num; + end if; + end loop; + Offs (0) := Last_Off + 1; + + declare + Propag : Propag_Array (1 .. Last_Off); -- := (others => 0); + begin + for I in Propagation.First .. Propagation.Last loop + Net := Get_Propagation_Net (I); + if Net /= No_Signal_Net then + Propag (Offs (Net)) := Propagation.Table (I); + Offs (Net) := Offs (Net) + 1; + end if; + end loop; + Propagation.Set_Last (Last_Off); + Propagation.Release; + for I in Propagation.First .. Propagation.Last loop + if Propag (I).Kind = Imp_Forward_Build then + Propagation.Table (I) := (Kind => Imp_Forward, + Sig => Propag (I).Forward.Targ); + Deallocate (Propag (I).Forward); + else + Propagation.Table (I) := Propag (I); + end if; + end loop; + end; + for I in 1 .. Last_Signal_Net loop + -- Ignore holes. + if Offs (I) /= 0 then + Propagation.Table (Offs (I)) := + (Kind => Prop_End, Updated => True); + end if; + end loop; + Propagation.Table (1) := (Kind => Prop_End, Updated => True); + + -- 4) Convert back from offset to start position (on the prop_end + -- cell). + Offs (0) := 1; + Last_Off := 1; + for I in 1 .. Last_Signal_Net loop + if Offs (I) /= 0 then + Num := Offs (I); + Offs (I) := Last_Off; + Last_Off := Num; + end if; + end loop; + + -- 5) Re-map the nets to cell indexes. + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + if Sig.Net = No_Signal_Net then + if Sig.S.Resolv /= null then + Sig.Net := Net_One_Resolved; + elsif Sig.S.Nbr_Drivers = 1 then + if Sig.S.Drivers (0).Last_Trans.Kind = Trans_Direct then + Sig.Net := Net_One_Direct; + else + Sig.Net := Net_One_Driver; + end if; + end if; + else + Sig.Net := Offs (Sig.Net); + end if; + Sig.Link := null; + end loop; + end; + end Create_Nets; + + function Get_Nbr_Future return Ghdl_I32 + is + Res : Ghdl_I32; + Sig : Ghdl_Signal_Ptr; + begin + Res := 0; + Sig := Future_List; + while Sig.Flink /= null loop + Res := Res + 1; + Sig := Sig.Flink; + end loop; + return Res; + end Get_Nbr_Future; + + -- Check every scalar subelement of a resolved signal has a driver + -- in the same process. + procedure Check_Resolved_Driver (Resolv : Resolved_Signal_Acc) + is + First_Sig : Ghdl_Signal_Ptr; + Nbr : Ghdl_Index_Type; + begin + First_Sig := Sig_Table.Table (Resolv.Sig_Range.First); + Nbr := First_Sig.S.Nbr_Drivers; + for I in Resolv.Sig_Range.First + 1 .. Resolv.Sig_Range.Last loop + if Sig_Table.Table (I).S.Nbr_Drivers /= Nbr then + -- FIXME: provide more information (signal name, process name). + Error ("missing drivers for subelement of a resolved signal"); + end if; + end loop; + end Check_Resolved_Driver; + + Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address; + pragma Import (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr, + "ieee__std_logic_1164__resolved_RESOLV_ptr"); + + procedure Free is new Ada.Unchecked_Deallocation + (Name => Resolved_Signal_Acc, Object => Resolved_Signal_Type); + + procedure Order_All_Signals + is + Sig : Ghdl_Signal_Ptr; + Resolv : Resolved_Signal_Acc; + begin + -- Do checks and optimization. + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + + -- LRM 5.3 + -- If, by the above rules, no disconnection specification applies to + -- the drivers of a guarded, scalar signal S whose type mark is T + -- (including a scalar subelement of a composite signal), then the + -- following default disconnection specification is implicitly + -- assumed: + -- disconnect S : T after 0 ns; + if Sig.S.Mode_Sig in Mode_Signal_User then + Resolv := Sig.S.Resolv; + if Resolv /= null and then Resolv.Disconnect_Time = Bad_Time then + Resolv.Disconnect_Time := 0; + end if; + + if Resolv /= null + and then Resolv.Sig_Range.First = I + and then Resolv.Sig_Range.Last > I + then + -- Check every scalar subelement of a resolved signal + -- has a driver in the same process. + Check_Resolved_Driver (Resolv); + end if; + + if Resolv /= null + and then Resolv.Sig_Range.First = I + and then Resolv.Sig_Range.Last = I + and then + (Resolv.Resolv_Proc + = To_Resolver_Acc (Ieee_Std_Logic_1164_Resolved_Resolv_Ptr)) + and then Sig.S.Nbr_Drivers + Sig.Nbr_Ports <= 1 + then + -- Optimization: remove resolver if there is at most one + -- source. + Free (Sig.S.Resolv); + end if; + end if; + end loop; + + -- Really order them. + for I in Sig_Table.First .. Sig_Table.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Driving); + end loop; + for I in Sig_Table.First .. Sig_Table.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Done); + end loop; + + Create_Nets; + end Order_All_Signals; + + -- Add SIG in active_chain. + procedure Add_Active_Chain (Sig : Ghdl_Signal_Ptr); + pragma Inline (Add_Active_Chain); + + procedure Add_Active_Chain (Sig : Ghdl_Signal_Ptr) + is + begin + if Sig.Link = null then + Sig.Link := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Sig; + end if; + end Add_Active_Chain; + + Clear_List : Ghdl_Signal_Ptr := null; + + -- Mark SIG as active and put it on Clear_List (if not already). + procedure Mark_Active (Sig : Ghdl_Signal_Ptr); + pragma Inline (Mark_Active); + + procedure Mark_Active (Sig : Ghdl_Signal_Ptr) + is + begin + if not Sig.Active then + Sig.Active := True; + Sig.Last_Active := Current_Time; + Sig.Alink := Clear_List; + Clear_List := Sig; + end if; + end Mark_Active; + + procedure Set_Guard_Activity (Sig : Ghdl_Signal_Ptr) is + begin + for I in 1 .. Sig.Nbr_Ports loop + if Sig.Ports (I - 1).Active then + Mark_Active (Sig); + return; + end if; + end loop; + end Set_Guard_Activity; + + procedure Set_Stable_Quiet_Activity + (Mode : Propagation_Kind_Type; Sig : Ghdl_Signal_Ptr) is + begin + case Mode is + when Imp_Stable => + for I in 0 .. Sig.Nbr_Ports - 1 loop + if Sig.Ports (I).Event then + Mark_Active (Sig); + return; + end if; + end loop; + when Imp_Quiet + | Imp_Transaction => + for I in 0 .. Sig.Nbr_Ports - 1 loop + if Sig.Ports (I).Active then + Mark_Active (Sig); + return; + end if; + end loop; + when others => + Internal_Error ("set_stable_quiet_activity"); + end case; + end Set_Stable_Quiet_Activity; + + function Get_Resolved_Activity (Sig : Ghdl_Signal_Ptr) return Boolean + is + Trans : Transaction_Acc; + Res : Boolean := False; + begin + for J in 1 .. Sig.S.Nbr_Drivers loop + Trans := Sig.S.Drivers (J - 1).First_Trans.Next; + if Trans /= null then + if Trans.Kind = Trans_Direct then + Direct_Assign (Sig.S.Drivers (J - 1).First_Trans.Val, + Trans.Val_Ptr, Sig.Mode); + -- In fact we knew the signal was active! + Res := True; + elsif Trans.Time = Current_Time then + Free (Sig.S.Drivers (J - 1).First_Trans); + Sig.S.Drivers (J - 1).First_Trans := Trans; + Res := True; + end if; + end if; + end loop; + if Res then + return True; + end if; + for J in 1 .. Sig.Nbr_Ports loop + if Sig.Ports (J - 1).Active then + return True; + end if; + end loop; + return False; + end Get_Resolved_Activity; + + procedure Set_Conversion_Activity (Conv : Sig_Conversion_Acc) + is + Active : Boolean := False; + begin + for I in Conv.Src.First .. Conv.Src.Last loop + Active := Active or Sig_Table.Table (I).Active; + end loop; + if Active then + Call_Conversion_Function (Conv); + end if; + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Active := Active; + end loop; + end Set_Conversion_Activity; + + procedure Delayed_Implicit_Process (Sig : Ghdl_Signal_Ptr) + is + Pfx : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + Last : Transaction_Acc; + Prev : Transaction_Acc; + begin + Pfx := Sig.Ports (0); + if Pfx.Event then + -- LRM 14.1 + -- P: process (S) + -- begin + -- R <= transport S after T; + -- end process; + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => Current_Time + Sig.S.Time, + Next => null, + Val => Pfx.Value); + -- Find the last transaction. + Last := Sig.S.Attr_Trans; + Prev := Last; + while Last.Next /= null loop + Prev := Last; + Last := Last.Next; + end loop; + -- Maybe, remove it. + if Last.Time > Trans.Time then + Internal_Error ("delayed time"); + elsif Last.Time = Trans.Time then + if Prev /= Last then + Free (Last); + else + -- No transaction. + if Last.Time /= 0 then + -- This can happen only at time = 0. + Internal_Error ("delayed"); + end if; + end if; + else + Prev := Last; + end if; + -- Append the transaction. + Prev.Next := Trans; + if Sig.S.Time = 0 then + Add_Active_Chain (Sig); + end if; + end if; + end Delayed_Implicit_Process; + + -- Set the effective value of signal SIG to VAL. + -- If the value is different from the previous one, resume processes. + procedure Set_Effective_Value (Sig : Ghdl_Signal_Ptr; Val : Value_Union) + is + El : Action_List_Acc; + begin + if not Value_Equal (Sig.Value, Val, Sig.Mode) then + Sig.Last_Value := Sig.Value; + Sig.Value := Val; + Sig.Event := True; + Sig.Last_Event := Current_Time; + Sig.Flags.Cyc_Event := True; + + El := Sig.Event_List; + while El /= null loop + Resume_Process (El.Proc); + El := El.Next; + end loop; + end if; + end Set_Effective_Value; + + procedure Run_Propagation (Start : Signal_Net_Type) + is + I : Signal_Net_Type; + Sig : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + First_Trans : Transaction_Acc; + begin + I := Start; + loop + -- First: the driving value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Eff_One_Driver => + Sig := Propagation.Table (I).Sig; + First_Trans := Sig.S.Drivers (0).First_Trans; + Trans := First_Trans.Next; + if Trans /= null then + if Trans.Kind = Trans_Direct then + -- Note: already or will be marked as active in + -- update_signals. + Mark_Active (Sig); + Direct_Assign (First_Trans.Val, + Trans.Val_Ptr, Sig.Mode); + Sig.Driving_Value := First_Trans.Val; + elsif Trans.Time = Current_Time then + Mark_Active (Sig); + Free (First_Trans); + Sig.S.Drivers (0).First_Trans := Trans; + case Trans.Kind is + when Trans_Value => + Sig.Driving_Value := Trans.Val; + when Trans_Direct => + Internal_Error ("run_propagation: trans_direct"); + when Trans_Null => + Error ("null transaction"); + when Trans_Error => + Error_Trans_Error (Trans); + end case; + end if; + end if; + when Drv_One_Resolved + | Eff_One_Resolved => + Sig := Propagation.Table (I).Sig; + if Get_Resolved_Activity (Sig) then + Mark_Active (Sig); + Compute_Resolved_Signal (Propagation.Table (I).Sig.S.Resolv); + end if; + when Drv_One_Port + | Eff_One_Port => + Sig := Propagation.Table (I).Sig; + if Sig.Ports (0).Active then + Mark_Active (Sig); + Sig.Driving_Value := Sig.Ports (0).Driving_Value; + end if; + when Eff_Actual => + Sig := Propagation.Table (I).Sig; + -- Note: the signal may have drivers (inout ports). + if Sig.S.Effective.Active and not Sig.Active then + Mark_Active (Sig); + end if; + when Drv_Multiple + | Eff_Multiple => + declare + Active : Boolean := False; + Resolv : Resolved_Signal_Acc; + begin + Resolv := Propagation.Table (I).Resolv; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop + Sig := Sig_Table.Table (I); + Active := Active or Get_Resolved_Activity (Sig); + end loop; + if Active then + -- Mark the first signal as active (since only this one + -- will be checked to set effective value). + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + Mark_Active (Sig_Table.Table (I)); + end loop; + Compute_Resolved_Signal (Resolv); + end if; + end; + when Imp_Guard + | Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Forward_Build => + null; + when Imp_Forward => + Sig := Propagation.Table (I).Sig; + if Sig.Link = null then + Sig.Link := Ghdl_Implicit_Signal_Active_Chain; + Ghdl_Implicit_Signal_Active_Chain := Sig; + end if; + when Imp_Delayed => + Sig := Propagation.Table (I).Sig; + Trans := Sig.S.Attr_Trans.Next; + if Trans /= null and then Trans.Time = Current_Time then + Mark_Active (Sig); + Free (Sig.S.Attr_Trans); + Sig.S.Attr_Trans := Trans; + Sig.Driving_Value := Trans.Val; + end if; + when In_Conversion => + null; + when Out_Conversion => + Set_Conversion_Activity (Propagation.Table (I).Conv); + when Prop_End => + return; + when Drv_Error => + Internal_Error ("update signals"); + end case; + + -- Second: the effective value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Drv_One_Port + | Drv_One_Resolved + | Drv_Multiple => + null; + when Eff_One_Driver + | Eff_One_Port + | Eff_One_Resolved => + Sig := Propagation.Table (I).Sig; + if Sig.Active then + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + when Eff_Multiple => + declare + Resolv : Resolved_Signal_Acc; + begin + Resolv := Propagation.Table (I).Resolv; + if Sig_Table.Table (Resolv.Sig_Range.First).Active then + -- If one signal is active, all are active. + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + Sig := Sig_Table.Table (I); + Set_Effective_Value (Sig, Sig.Driving_Value); + end loop; + end if; + end; + when Eff_Actual => + Sig := Propagation.Table (I).Sig; + if Sig.Active then + Set_Effective_Value (Sig, Sig.S.Effective.Value); + end if; + when Imp_Forward + | Imp_Forward_Build => + null; + when Imp_Guard => + -- Guard signal is active iff one of its dependence is active. + Sig := Propagation.Table (I).Sig; + Set_Guard_Activity (Sig); + if Sig.Active then + Sig.Driving_Value.B1 := + Sig.S.Guard_Func.all (Sig.S.Guard_Instance); + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + when Imp_Stable + | Imp_Quiet => + Sig := Propagation.Table (I).Sig; + Set_Stable_Quiet_Activity (Propagation.Table (I).Kind, Sig); + if Sig.Active then + Sig.Driving_Value := + Value_Union'(Mode => Mode_B1, B1 => False); + -- Set driver. + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => Current_Time + Sig.S.Time, + Next => null, + Val => Value_Union'(Mode => Mode_B1, B1 => True)); + if Sig.S.Attr_Trans.Next /= null then + Free (Sig.S.Attr_Trans.Next); + end if; + Sig.S.Attr_Trans.Next := Trans; + Set_Effective_Value (Sig, Sig.Driving_Value); + if Sig.S.Time = 0 then + Add_Active_Chain (Sig); + end if; + else + Trans := Sig.S.Attr_Trans.Next; + if Trans /= null and then Trans.Time = Current_Time then + Mark_Active (Sig); + Free (Sig.S.Attr_Trans); + Sig.S.Attr_Trans := Trans; + Sig.Driving_Value := Trans.Val; + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + end if; + when Imp_Transaction => + -- LRM 12.6.3 Updating Implicit Signals + -- Finally, for any implicit signal S'Transaction, the current + -- value of the signal is modified if and only if S is active. + -- If signal S is active, then S'Transaction is updated by + -- assigning the value of the expression (not S'Transaction) + -- to the variable representing the current value of + -- S'Transaction. + Sig := Propagation.Table (I).Sig; + for I in 0 .. Sig.Nbr_Ports - 1 loop + if Sig.Ports (I).Active then + Mark_Active (Sig); + Set_Effective_Value + (Sig, Value_Union'(Mode => Mode_B1, + B1 => not Sig.Value.B1)); + exit; + end if; + end loop; + when Imp_Delayed => + Sig := Propagation.Table (I).Sig; + if Sig.Active then + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + Delayed_Implicit_Process (Sig); + when In_Conversion => + Set_Conversion_Activity (Propagation.Table (I).Conv); + when Out_Conversion => + null; + when Prop_End => + null; + when Drv_Error => + Internal_Error ("run_propagation(2)"); + end case; + I := I + 1; + end loop; + end Run_Propagation; + + procedure Reset_Active_Flag + is + Sig : Ghdl_Signal_Ptr; + begin + -- 1) Reset active flag. + Sig := Clear_List; + Clear_List := null; + while Sig /= null loop + if Options.Flag_Stats then + if Sig.Active then + Nbr_Active := Nbr_Active + 1; + end if; + if Sig.Event then + Nbr_Events := Nbr_Events + 1; + end if; + end if; + Sig.Active := False; + Sig.Event := False; + + Sig := Sig.Alink; + end loop; + +-- for I in Sig_Table.First .. Sig_Table.Last loop +-- Sig := Sig_Table.Table (I); +-- if Sig.Active or Sig.Event then +-- Internal_Error ("reset_active_flag"); +-- end if; +-- end loop; + end Reset_Active_Flag; + + procedure Update_Signals + is + Sig : Ghdl_Signal_Ptr; + Next_Sig : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + begin + -- LRM93 12.6.2 + -- 1) Reset active flag. + Reset_Active_Flag; + + -- For each active signals + Sig := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Signal_End; + while Sig.S.Mode_Sig /= Mode_End loop + Next_Sig := Sig.Link; + Sig.Link := null; + + case Sig.Net is + when Net_One_Driver => + -- This signal is active. + Mark_Active (Sig); + + Trans := Sig.S.Drivers (0).First_Trans.Next; + Free (Sig.S.Drivers (0).First_Trans); + Sig.S.Drivers (0).First_Trans := Trans; + case Trans.Kind is + when Trans_Value => + Sig.Driving_Value := Trans.Val; + when Trans_Direct => + Internal_Error ("update_signals: trans_direct"); + when Trans_Null => + Error ("null transaction"); + when Trans_Error => + Error_Trans_Error (Trans); + end case; + Set_Effective_Value (Sig, Sig.Driving_Value); + + when Net_One_Direct => + Mark_Active (Sig); + Sig.Is_Direct_Active := False; + + Trans := Sig.S.Drivers (0).Last_Trans; + Direct_Assign (Sig.Driving_Value, Trans.Val_Ptr, Sig.Mode); + Sig.S.Drivers (0).First_Trans.Val := Sig.Driving_Value; + Set_Effective_Value (Sig, Sig.Driving_Value); + + when Net_One_Resolved => + -- This signal is active. + Mark_Active (Sig); + Sig.Is_Direct_Active := False; + + for J in 1 .. Sig.S.Nbr_Drivers loop + Trans := Sig.S.Drivers (J - 1).First_Trans.Next; + if Trans /= null then + if Trans.Kind = Trans_Direct then + Direct_Assign (Sig.S.Drivers (J - 1).First_Trans.Val, + Trans.Val_Ptr, Sig.Mode); + elsif Trans.Time = Current_Time then + Free (Sig.S.Drivers (J - 1).First_Trans); + Sig.S.Drivers (J - 1).First_Trans := Trans; + end if; + end if; + end loop; + Compute_Resolved_Signal (Sig.S.Resolv); + Set_Effective_Value (Sig, Sig.Driving_Value); + + when No_Signal_Net => + Internal_Error ("update_signals: no_signal_net"); + + when others => + Sig.Is_Direct_Active := False; + if not Propagation.Table (Sig.Net).Updated then + Propagation.Table (Sig.Net).Updated := True; + Run_Propagation (Sig.Net + 1); + + -- Put it on the list, so that updated flag will be cleared. + Add_Active_Chain (Sig); + end if; + end case; + + Sig := Next_Sig; + end loop; + + -- Implicit signals (forwarded). + loop + Sig := Ghdl_Implicit_Signal_Active_Chain; + exit when Sig.Link = null; + Ghdl_Implicit_Signal_Active_Chain := Sig.Link; + Sig.Link := null; + + if not Propagation.Table (Sig.Net).Updated then + Propagation.Table (Sig.Net).Updated := True; + Run_Propagation (Sig.Net + 1); + + -- Put it on the list, so that updated flag will be cleared. + Add_Active_Chain (Sig); + end if; + end loop; + + -- Un-mark updated. + Sig := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Signal_End; + while Sig.Link /= null loop + Propagation.Table (Sig.Net).Updated := False; + Next_Sig := Sig.Link; + Sig.Link := null; + + -- Maybe put SIG in the active list, if it will be active during + -- the next cycle. + -- This can happen only for 'quiet, 'stable or 'delayed. + case Sig.S.Mode_Sig is + when Mode_Stable + | Mode_Quiet + | Mode_Delayed => + declare + Trans : Transaction_Acc; + begin + Trans := Sig.S.Attr_Trans.Next; + if Trans /= null and then Trans.Time = Current_Time then + Sig.Link := Ghdl_Implicit_Signal_Active_Chain; + Ghdl_Implicit_Signal_Active_Chain := Sig; + end if; + end; + when others => + null; + end case; + + Sig := Next_Sig; + end loop; + end Update_Signals; + + procedure Run_Propagation_Init (Start : Signal_Net_Type) + is + I : Signal_Net_Type; + Sig : Ghdl_Signal_Ptr; + begin + I := Start; + loop + -- First: the driving value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Eff_One_Driver => + -- Nothing to do: drivers were already created. + null; + when Drv_One_Resolved + | Eff_One_Resolved => + -- Execute the resolution function. + Sig := Propagation.Table (I).Sig; + if Sig.Nbr_Ports > 0 then + Compute_Resolved_Signal (Sig.S.Resolv); + end if; + when Drv_One_Port + | Eff_One_Port => + -- Copy value. + Sig := Propagation.Table (I).Sig; + Sig.Driving_Value := Sig.Ports (0).Driving_Value; + when Eff_Actual => + null; + when Drv_Multiple + | Eff_Multiple => + Compute_Resolved_Signal (Propagation.Table (I).Resolv); + when Imp_Guard + | Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Forward + | Imp_Forward_Build => + null; + when Imp_Delayed => + -- LRM 14.1 + -- Assuming that the initial value of R is the same as the + -- initial value of S, [...] + Sig := Propagation.Table (I).Sig; + Sig.Driving_Value := Sig.Ports (0).Driving_Value; + when In_Conversion => + null; + when Out_Conversion => + Call_Conversion_Function (Propagation.Table (I).Conv); + when Prop_End => + return; + when Drv_Error => + Internal_Error ("init_signals"); + end case; + + -- Second: the effective value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Drv_One_Port + | Drv_One_Resolved + | Drv_Multiple => + null; + when Eff_One_Driver + | Eff_One_Port + | Eff_One_Resolved + | Imp_Delayed => + Sig := Propagation.Table (I).Sig; + Sig.Value := Sig.Driving_Value; + when Eff_Multiple => + declare + Resolv : Resolved_Signal_Acc; + begin + Resolv := Propagation.Table (I).Resolv; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop + Sig := Sig_Table.Table (I); + Sig.Value := Sig.Driving_Value; + end loop; + end; + when Eff_Actual => + Sig := Propagation.Table (I).Sig; + Sig.Value := Sig.S.Effective.Value; + when Imp_Guard => + -- Guard signal is active iff one of its dependence is active. + Sig := Propagation.Table (I).Sig; + Sig.Driving_Value.B1 := + Sig.S.Guard_Func.all (Sig.S.Guard_Instance); + Sig.Value := Sig.Driving_Value; + when Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Forward + | Imp_Forward_Build => + -- Already initialized during creation. + null; + when In_Conversion => + Call_Conversion_Function (Propagation.Table (I).Conv); + when Out_Conversion => + null; + when Prop_End => + null; + when Drv_Error => + Internal_Error ("init_signals(2)"); + end case; + + I := I + 1; + end loop; + end Run_Propagation_Init; + + procedure Init_Signals + is + Sig : Ghdl_Signal_Ptr; + begin + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + + case Sig.Net is + when Net_One_Driver + | Net_One_Direct => + -- Nothing to do: drivers were already created. + null; + + when Net_One_Resolved => + Sig.Has_Active := True; + if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 0 then + Compute_Resolved_Signal (Sig.S.Resolv); + Sig.Value := Sig.Driving_Value; + end if; + + when No_Signal_Net => + null; + + when others => + if Propagation.Table (Sig.Net).Updated then + Propagation.Table (Sig.Net).Updated := False; + Run_Propagation_Init (Sig.Net + 1); + end if; + end case; + end loop; + + end Init_Signals; + + procedure Init is + begin + Signal_End := new Ghdl_Signal'(Value => (Mode => Mode_B1, + B1 => False), + Driving_Value => (Mode => Mode_B1, + B1 => False), + Last_Value => (Mode => Mode_B1, + B1 => False), + Last_Event => 0, + Last_Active => 0, + Event => False, + Active => False, + Has_Active => False, + Is_Direct_Active => False, + Sig_Kind => Kind_Signal_No, + Mode => Mode_B1, + + Flags => (Propag => Propag_None, + Is_Dumped => False, + Cyc_Event => False, + Seen => False), + + Net => No_Signal_Net, + Link => null, + Alink => null, + Flink => null, + + Event_List => null, + Rti => null, + + Nbr_Ports => 0, + Ports => null, + + S => (Mode_Sig => Mode_End)); + + Ghdl_Signal_Active_Chain := Signal_End; + Ghdl_Implicit_Signal_Active_Chain := Signal_End; + Future_List := Signal_End; + + Boolean_Signal_Rti.Obj_Type := Std_Standard_Boolean_RTI_Ptr; + Bit_Signal_Rti.Obj_Type := Std_Standard_Bit_RTI_Ptr; + end Init; + +end Grt.Signals; diff --git a/src/grt/grt-signals.ads b/src/grt/grt-signals.ads new file mode 100644 index 000000000..d792f1634 --- /dev/null +++ b/src/grt/grt-signals.ads @@ -0,0 +1,919 @@ +-- GHDL Run Time (GRT) - signals management. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; +with Ada.Unchecked_Conversion; +with Grt.Table; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; +limited with Grt.Processes; +pragma Elaborate_All (Grt.Table); + +package Grt.Signals is + pragma Suppress (All_Checks); + + -- Kind of transaction. + type Transaction_Kind is + ( + -- Normal transaction, with a value. + Trans_Value, + -- Normal transaction, with a pointer to a value (direct assignment). + Trans_Direct, + -- Null transaction. + Trans_Null, + -- Like a normal transaction, but without a value due to check error. + Trans_Error + ); + + type Transaction; + type Transaction_Acc is access Transaction; + type Transaction (Kind : Transaction_Kind) is record + -- Line for error. Put here to compact the record. + Line : Ghdl_I32; + + Next : Transaction_Acc; + Time : Std_Time; + case Kind is + when Trans_Value => + Val : Value_Union; + when Trans_Direct => + Val_Ptr : Ghdl_Value_Ptr; + when Trans_Null => + null; + when Trans_Error => + -- Filename for error. + File : Ghdl_C_String; + end case; + end record; + + type Process_Acc is access Grt.Processes.Process_Type; + + -- A driver is bound to a process (PROC) and contains a list of + -- transactions. + type Driver_Type is record + First_Trans : Transaction_Acc; + Last_Trans : Transaction_Acc; + Proc : Process_Acc; + end record; + + type Driver_Acc is access all Driver_Type; + type Driver_Fat_Array is array (Ghdl_Index_Type) of aliased Driver_Type; + type Driver_Arr_Ptr is access Driver_Fat_Array; + + -- Function access type used to evaluate the guard expression. + type Guard_Func_Acc is access function (This : System.Address) + return Ghdl_B1; + pragma Convention (C, Guard_Func_Acc); + + -- Simply linked list of processes to be resumed in case of events. + + type Ghdl_Signal; + type Ghdl_Signal_Ptr is access Ghdl_Signal; + + function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Ghdl_Signal_Ptr); + + type Signal_Fat_Array is array (Ghdl_Index_Type) of Ghdl_Signal_Ptr; + type Signal_Arr_Ptr is access Signal_Fat_Array; + + function To_Signal_Arr_Ptr is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Signal_Arr_Ptr); + + -- List of processes to wake-up in case of event on the signal. + type Action_List; + type Action_List_Acc is access Action_List; + + type Action_List (Dynamic : Boolean) is record + -- Next action for the current signal. + Next : Action_List_Acc; + + -- Process to wake-up. + Proc : Process_Acc; + + case Dynamic is + when True => + -- For a non-sensitized process. + -- Previous action (to speed-up remove from the chain). + Prev : Action_List_Acc; + + Sig : Ghdl_Signal_Ptr; + + -- Chain of signals for the process. + Chain : Action_List_Acc; + when False => + null; + end case; + end record; + + -- Resolution function. + -- There is a wrapper around resolution functions to simplify the call + -- from GRT. + -- INSTANCE is the opaque parameter given when the resolver is + -- registers (RESOLV_INST). + -- VAL is the signal (which may be composite). + -- BOOL_VEC is an array of NBR_DRV booleans (bytes) and indicates + -- non-null drivers. There are VEC_LEN non-null drivers. So the number + -- of values is VEC_LEN + NBR_PORTS. This number of values is the length + -- of the array for the resolution function. + type Resolver_Acc is access procedure + (Instance : System.Address; + Val : System.Address; + Bool_Vec : System.Address; + Vec_Len : Ghdl_Index_Type; + Nbr_Drv : Ghdl_Index_Type; + Nbr_Ports : Ghdl_Index_Type); + + -- On some platforms, GNAT use a descriptor (instead of a trampoline) for + -- nested subprograms. This descriptor contains the address of the + -- subprogram and the address of the chain. An unaligned pointer to this + -- descriptor (address + 1) is then used for 'Access, and every indirect + -- call check for unaligned address. + -- + -- Disable this feature (as a resolver is never a nested subprogram), so + -- code generated by ghdl is compatible with ghdl runtimes built with + -- gnat. + pragma Convention (C, Resolver_Acc); + + -- How to compute resolved signal. + type Resolved_Signal_Type is record + Resolv_Proc : Resolver_Acc; + Resolv_Inst : System.Address; + Resolv_Ptr : System.Address; + Sig_Range : Sig_Table_Range; + Disconnect_Time : Std_Time; + end record; + + type Resolved_Signal_Acc is access Resolved_Signal_Type; + + type Conversion_Func_Acc is access procedure (Instance : System.Address); + pragma Convention (C, Conversion_Func_Acc); + + function To_Conversion_Func_Acc is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Conversion_Func_Acc); + + -- Signal conversion data. + type Sig_Conversion_Type is record + -- Function which performs the conversion. + Func : System.Address; + Instance : System.Address; + + Src : Sig_Table_Range; + Dest : Sig_Table_Range; + end record; + type Sig_Conversion_Acc is access Sig_Conversion_Type; + + type Forward_Build_Type is record + Src : Ghdl_Signal_Ptr; + Targ : Ghdl_Signal_Ptr; + end record; + type Forward_Build_Acc is access Forward_Build_Type; + + -- Used to order the signals for the propagation of signals values. + type Propag_Order_Flag is + ( + -- The signal was not yet ordered. + Propag_None, + -- The signal is being ordered for driving value. + -- This stage is used to catch loop (which can not occur). + Propag_Being_Driving, + -- The signal has been ordered for driving value. + Propag_Driving, + -- The signal is being ordered for effective value. + Propag_Being_Effective, + -- The signal has completly been ordered. + Propag_Done); + + -- Each signal belongs to a signal_net. + -- Signals on the same net must be updated in order. + -- Signals on different nets have no direct relation-ship, and thus may + -- be updated without order. + -- Net NO_SIGNAL_NET is special: it groups all lonely signals. + type Signal_Net_Type is new Integer; + No_Signal_Net : constant Signal_Net_Type := 0; + Net_One_Driver : constant Signal_Net_Type := -1; + Net_One_Direct : constant Signal_Net_Type := -2; + Net_One_Resolved : constant Signal_Net_Type := -3; + + -- Flush the list of active signals. + procedure Flush_Active_List; + + type Ghdl_Signal_Data (Mode_Sig : Mode_Signal_Type := Mode_Signal) + is record + case Mode_Sig is + when Mode_Signal_User => + Nbr_Drivers : Ghdl_Index_Type; + Drivers : Driver_Arr_Ptr; + + -- Signal which defines the effective value of this signal, + -- if any. + Effective : Ghdl_Signal_Ptr; + + -- Null if not resolved. + Resolv : Resolved_Signal_Acc; + + when Mode_Conv_In + | Mode_Conv_Out => + -- Conversion paramaters for conv_in, conv_out. + Conv : Sig_Conversion_Acc; + + when Mode_Stable + | Mode_Quiet + | Mode_Delayed => + -- Time parameter for 'stable, 'quiet or 'delayed + Time : Std_Time; + Attr_Trans : Transaction_Acc; + + when Mode_Guard => + -- Guard function and instance used to compute the + -- guard expression. + Guard_Func : Guard_Func_Acc; + Guard_Instance : System.Address; + + when Mode_Transaction + | Mode_End => + null; + end case; + end record; + pragma Suppress (Discriminant_Check, On => Ghdl_Signal_Data); + + type Ghdl_Signal_Flags is record + -- Status of the ordering. + Propag : Propag_Order_Flag; + + -- If set, the signal is dumped in a GHW file. + Is_Dumped : Boolean; + + -- Set when an event occured. + -- Only reset by GHW file dumper. + Cyc_Event : Boolean; + + -- Set if the signal has already been visited. When outside of the + -- algorithm that use it, it must be cleared. + Seen : Boolean; + end record; + pragma Pack (Ghdl_Signal_Flags); + + type Ghdl_Signal is record + -- Fields known by the compilers. + Value : Value_Union; + Driving_Value : Value_Union; + Last_Value : Value_Union; + Last_Event : Std_Time; + Last_Active : Std_Time; + + Event : Boolean; + Active : Boolean; + -- If set, the activity of the signal is required by the user. + Has_Active : Boolean; + + -- Internal fields. + -- NOTE: keep above fields (components) in sync with translation. + + -- If set, the signal has an active direct driver. + Is_Direct_Active : Boolean; + + -- Kind of the signal (none, bus or register). + Sig_Kind : Kind_Signal_Type; + + -- Values mode of this signal. + Mode : Mode_Type; + + -- Misc flags. + Flags : Ghdl_Signal_Flags; + + -- Net of the signal. + Net : Signal_Net_Type; + + -- Chain of signals that will be active in the next delta-cycle. + -- (Also used to build nets). + Link : Ghdl_Signal_Ptr; + + -- Chain of signals whose active flag was set. Used to clear the active + -- flag at the end of the delta cycle. + Alink : Ghdl_Signal_Ptr; + + -- Chain of signals that have a projected waveform in the real future. + Flink : Ghdl_Signal_Ptr; + + -- List of processes to resume when there is an event on + -- this signal. + Event_List : Action_List_Acc; + + -- Path of the signal (with its name) in the design hierarchy. + -- Used to get the type of the signal. + Rti : Ghdl_Rtin_Object_Acc; + + -- For user signals: the sources of a signals are drivers + -- and connected ports. + -- For implicit signals: PORTS is used as dependence list. + Nbr_Ports : Ghdl_Index_Type; + Ports : Signal_Arr_Ptr; + + -- Mode of the signal (in, out ...) + --Mode_Signal : Mode_Signal_Type; + S : Ghdl_Signal_Data; + end record; + + -- Each simple signal declared can be accessed by SIG_TABLE. + package Sig_Table is new Grt.Table + (Table_Component_Type => Ghdl_Signal_Ptr, + Table_Index_Type => Sig_Table_Index, + Table_Low_Bound => 0, + Table_Initial => 128); + + -- Return the next time at which a driver becomes active. + function Find_Next_Time return Std_Time; + + -- Elementary propagation computation. + -- See LRM 12.6.2 and 12.6.3 + type Propagation_Kind_Type is + ( + -- How to compute driving value: + -- Default value. + Drv_Error, + + -- One source, a driver and not resolved: + -- the driving value is the driver. + Drv_One_Driver, + + -- Same as previous, and the effective value is the driving value. + Eff_One_Driver, + + -- One source, a port and not resolved: + -- the driving value is the driving value of the port. + -- Dependence. + Drv_One_Port, + + -- Same as previous, and the effective value is the driving value. + Eff_One_Port, + + -- Several sources or resolved: + -- signal is not composite. + Drv_One_Resolved, + Eff_One_Resolved, + + -- Use the resolution function, signal is composite. + Drv_Multiple, + + -- Same as previous, but the effective value is the previous value. + Eff_Multiple, + + -- The effective value is the actual associated. + Eff_Actual, + + -- Sig must be updated but does not belong to the same net. + Imp_Forward, + Imp_Forward_Build, + + -- Implicit guard signal. + -- Its value must be evaluated after the effective value of its + -- dependences. + Imp_Guard, + + -- Implicit stable. + -- Its value must be evaluated after the effective value of its + -- dependences. + Imp_Stable, + + -- Implicit quiet. + -- Its value must be evaluated after the driving value of its + -- dependences. + Imp_Quiet, + + -- Implicit transaction. + -- Its value must be evaluated after the driving value of its + -- dependences. + Imp_Transaction, + + -- Implicit delayed + -- Its value must be evaluated after the driving value of its + -- dependences. + Imp_Delayed, + + -- in_conversion. + -- Pseudo-signal which is set by conversion function. + In_Conversion, + Out_Conversion, + + -- End of propagation. + Prop_End + ); + + type Propagation_Type (Kind : Propagation_Kind_Type := Drv_Error) is record + case Kind is + when Drv_Error => + null; + when Drv_One_Driver + | Eff_One_Driver + | Drv_One_Port + | Eff_One_Port + | Imp_Forward + | Imp_Guard + | Imp_Quiet + | Imp_Transaction + | Imp_Stable + | Imp_Delayed + | Eff_Actual + | Eff_One_Resolved + | Drv_One_Resolved => + Sig : Ghdl_Signal_Ptr; + when Drv_Multiple + | Eff_Multiple => + Resolv : Resolved_Signal_Acc; + when In_Conversion + | Out_Conversion => + Conv : Sig_Conversion_Acc; + when Imp_Forward_Build => + Forward : Forward_Build_Acc; + when Prop_End => + Updated : Boolean; + end case; + end record; + + package Propagation is new Grt.Table + (Table_Component_Type => Propagation_Type, + Table_Index_Type => Signal_Net_Type, + Table_Low_Bound => 1, + Table_Initial => 128); + + -- Get the signal index of PTR. + function Signal_Ptr_To_Index (Ptr : Ghdl_Signal_Ptr) return Sig_Table_Index; + + -- Compute propagation order of signals. + procedure Order_All_Signals; + + -- Initialize the package (mainly the lists). + procedure Init; + + -- Initialize all signals. + procedure Init_Signals; + + -- Update signals. + procedure Update_Signals; + + -- Set the effective value of signal SIG to VAL. + -- If the value is different from the previous one, resume processes. + procedure Set_Effective_Value (Sig : Ghdl_Signal_Ptr; Val : Value_Union); + + -- Add PROC in the list of processes to be resumed in case of event on + -- SIG. + procedure Resume_Process_If_Event + (Sig : Ghdl_Signal_Ptr; Proc : Process_Acc); + + -- Creating a signal: + -- 1a) call Ghdl_Signal_Name_Rti (CTXT and ADDR are unused) to register + -- the RTI for the whole signal (in particular the mode and the + -- has_active flag) + -- or + -- 1b) call Ghdl_Signal_Set_Mode to register the mode and the has_active + -- flag. In that case, the signal has no name. + -- + -- 2) call Ghdl_Create_Signal_XXX for each non-composite element + + procedure Ghdl_Signal_Name_Rti (Sig : Ghdl_Rti_Access; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + + procedure Ghdl_Signal_Set_Mode (Mode : Mode_Signal_Type; + Kind : Kind_Signal_Type; + Has_Active : Boolean); + + -- FIXME: document. + -- Merge RTI with SIG: adjust the has_active flag of SIG according to RTI. + procedure Ghdl_Signal_Merge_Rti (Sig : Ghdl_Signal_Ptr; + Rti : Ghdl_Rti_Access); + + -- Assigning a waveform to a signal: + -- + -- For simple waveform (sig <= val), the short form can be used: + -- Ghdl_Signal_Simple_Assign_XX (Sig, Val); + -- For all other forms + -- SIG <= reject R inertial V1 after T1, V2 after T2, ...: + -- Ghdl_Signal_Start_Assign_XX (SIG, R, V1, T1); + -- Ghdl_Signal_Next_Assign_XX (SIG, V2, T2); + -- ... + -- If the delay mechanism is transport, they R = 0, + -- if there is no rejection time, the mechanism is internal and R = T1. + + -- Performs some internal checks on signals (transaction order). + -- Internal_error is called in case of error. + procedure Ghdl_Signal_Internal_Checks; + + procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr; + File : Ghdl_C_String; + Line : Ghdl_I32); + procedure Ghdl_Signal_Start_Assign_Error (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32); + procedure Ghdl_Signal_Next_Assign_Error (Sign : Ghdl_Signal_Ptr; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32); + + procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr); + + procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr; + Time : Std_Time); + + procedure Ghdl_Signal_Disconnect (Sign : Ghdl_Signal_Ptr); + + procedure Ghdl_Signal_Start_Assign_Null (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time); + + function Ghdl_Signal_Driving (Sig : Ghdl_Signal_Ptr) return Ghdl_B1; + + function Ghdl_Create_Signal_B1 (Init_Val : Ghdl_B1; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_B1 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_B1); + procedure Ghdl_Signal_Associate_B1 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_B1); + procedure Ghdl_Signal_Simple_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1); + procedure Ghdl_Signal_Start_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_B1; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1; + After : Std_Time); + function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr) + return Ghdl_B1; + + function Ghdl_Create_Signal_E8 (Init_Val : Ghdl_E8; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_E8 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E8); + procedure Ghdl_Signal_Associate_E8 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E8); + procedure Ghdl_Signal_Simple_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8); + procedure Ghdl_Signal_Start_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E8; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8; + After : Std_Time); + function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E8; + + function Ghdl_Create_Signal_E32 (Init_Val : Ghdl_E32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_E32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E32); + procedure Ghdl_Signal_Associate_E32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E32); + procedure Ghdl_Signal_Simple_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32); + procedure Ghdl_Signal_Start_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E32; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32; + After : Std_Time); + function Ghdl_Signal_Driving_Value_E32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E32; + + function Ghdl_Create_Signal_I32 (Init_Val : Ghdl_I32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_I32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I32); + procedure Ghdl_Signal_Associate_I32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I32); + procedure Ghdl_Signal_Simple_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32); + procedure Ghdl_Signal_Start_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I32; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32; + After : Std_Time); + function Ghdl_Signal_Driving_Value_I32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I32; + + function Ghdl_Create_Signal_I64 (Init_Val : Ghdl_I64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_I64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I64); + procedure Ghdl_Signal_Associate_I64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I64); + procedure Ghdl_Signal_Simple_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64); + procedure Ghdl_Signal_Start_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I64; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64; + After : Std_Time); + function Ghdl_Signal_Driving_Value_I64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I64; + + function Ghdl_Create_Signal_F64 (Init_Val : Ghdl_F64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_F64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_F64); + procedure Ghdl_Signal_Associate_F64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_F64); + procedure Ghdl_Signal_Simple_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64); + procedure Ghdl_Signal_Start_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_F64; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64; + After : Std_Time); + function Ghdl_Signal_Driving_Value_F64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_F64; + + -- Add a driver to SIGN for the current process. + procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr); + + -- Add a direct driver for the current process. This is an optimization + -- that could be used when a driver has no projected waveforms. + -- + -- Assignment using direct driver: + -- * the driver value is set + -- * put the signal on the ghdl_signal_active_chain, if the signal will + -- be active and if not already on the chain. + procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr; + Drv : Ghdl_Value_Ptr); + + -- Used for connexions: + -- SRC is a source for TARG. + procedure Ghdl_Signal_Add_Source (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr); + + -- The effective value of TARG is the effective value of SRC. + procedure Ghdl_Signal_Effective_Value (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr); + + -- Conversions. In order to do conversion from A to B, an intermediate + -- signal T must be created. The flow is A -> T -> B. + -- The link from A -> T is a conversion, added by one of the two + -- following procedures. The type of A and T is different. + -- The link from T -> B is a normal connection: either an effective + -- one (for in conversion) or a source (for out conversion). + + -- Add an in conversion (from SRC to DEST using function FUNC). + -- The effective value can be read and writen directly. + procedure Ghdl_Signal_In_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type); + + -- Add an out conversion. + -- The driving value can be read and writen directly. + procedure Ghdl_Signal_Out_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type); + + -- Mark the next (and not yet created) NBR_SIG signals as resolved. + procedure Ghdl_Signal_Create_Resolution (Proc : Resolver_Acc; + Instance : System.Address; + Sig : System.Address; + Nbr_Sig : Ghdl_Index_Type); + + -- Create a new 'stable (VAL) signal. The prefixes are set by + -- ghdl_signal_attribute_register_prefix. + function Ghdl_Create_Stable_Signal (Val : Std_Time) return Ghdl_Signal_Ptr; + -- Create a new 'quiet (VAL) signal. The prefixes are set by + -- ghdl_signal_attribute_register_prefix. + function Ghdl_Create_Quiet_Signal (Val : Std_Time) return Ghdl_Signal_Ptr; + -- Create a new 'transaction signal. The prefixes are set by + -- ghdl_signal_attribute_register_prefix. + function Ghdl_Create_Transaction_Signal return Ghdl_Signal_Ptr; + + -- Create a new SIG'delayed (VAL) signal. + function Ghdl_Create_Delayed_Signal (Sig : Ghdl_Signal_Ptr; Val : Std_Time) + return Ghdl_Signal_Ptr; + + -- Add SIG in the set of prefix for the last created signal. + procedure Ghdl_Signal_Attribute_Register_Prefix (Sig : Ghdl_Signal_Ptr); + + -- Create a new implicitly defined GUARD signal. + function Ghdl_Signal_Create_Guard (This : System.Address; + Proc : Guard_Func_Acc) + return Ghdl_Signal_Ptr; + + -- Add SIG to the list of referenced signals that appear in the guard + -- expression. + procedure Ghdl_Signal_Guard_Dependence (Sig : Ghdl_Signal_Ptr); + + -- Return number of ports/drivers. + function Ghdl_Signal_Get_Nbr_Ports (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type; + function Ghdl_Signal_Get_Nbr_Drivers (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type; + + -- Read a source (port or driver) from a signal. This is used by + -- resolution functions. + function Ghdl_Signal_Read_Port + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr; + function Ghdl_Signal_Read_Driver + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr; + + Ghdl_Signal_Active_Chain : aliased Ghdl_Signal_Ptr; + + -- Statistics. + Nbr_Active : Ghdl_I32; + Nbr_Events: Ghdl_I32; + function Get_Nbr_Future return Ghdl_I32; +private + pragma Export (C, Ghdl_Signal_Name_Rti, + "__ghdl_signal_name_rti"); + pragma Export (C, Ghdl_Signal_Merge_Rti, + "__ghdl_signal_merge_rti"); + + pragma Export (C, Ghdl_Signal_Simple_Assign_Error, + "__ghdl_signal_simple_assign_error"); + pragma Export (C, Ghdl_Signal_Start_Assign_Error, + "__ghdl_signal_start_assign_error"); + pragma Export (C, Ghdl_Signal_Next_Assign_Error, + "__ghdl_signal_next_assign_error"); + + pragma Export (C, Ghdl_Signal_Start_Assign_Null, + "__ghdl_signal_start_assign_null"); + + pragma Export (C, Ghdl_Signal_Direct_Assign, + "__ghdl_signal_direct_assign"); + + pragma Export (C, Ghdl_Signal_Set_Disconnect, + "__ghdl_signal_set_disconnect"); + pragma Export (C, Ghdl_Signal_Disconnect, + "__ghdl_signal_disconnect"); + + pragma Export (Ada, Ghdl_Signal_Driving, + "__ghdl_signal_driving"); + + pragma Export (Ada, Ghdl_Create_Signal_B1, + "__ghdl_create_signal_b1"); + pragma Export (Ada, Ghdl_Signal_Init_B1, + "__ghdl_signal_init_b1"); + pragma Export (Ada, Ghdl_Signal_Associate_B1, + "__ghdl_signal_associate_b1"); + pragma Export (Ada, Ghdl_Signal_Simple_Assign_B1, + "__ghdl_signal_simple_assign_b1"); + pragma Export (Ada, Ghdl_Signal_Start_Assign_B1, + "__ghdl_signal_start_assign_b1"); + pragma Export (Ada, Ghdl_Signal_Next_Assign_B1, + "__ghdl_signal_next_assign_b1"); + pragma Export (Ada, Ghdl_Signal_Driving_Value_B1, + "__ghdl_signal_driving_value_b1"); + + pragma Export (C, Ghdl_Create_Signal_E8, + "__ghdl_create_signal_e8"); + pragma Export (C, Ghdl_Signal_Init_E8, + "__ghdl_signal_init_e8"); + pragma Export (C, Ghdl_Signal_Associate_E8, + "__ghdl_signal_associate_e8"); + pragma Export (C, Ghdl_Signal_Simple_Assign_E8, + "__ghdl_signal_simple_assign_e8"); + pragma Export (C, Ghdl_Signal_Start_Assign_E8, + "__ghdl_signal_start_assign_e8"); + pragma Export (C, Ghdl_Signal_Next_Assign_E8, + "__ghdl_signal_next_assign_e8"); + pragma Export (C, Ghdl_Signal_Driving_Value_E8, + "__ghdl_signal_driving_value_e8"); + + pragma Export (C, Ghdl_Create_Signal_E32, + "__ghdl_create_signal_e32"); + pragma Export (C, Ghdl_Signal_Init_E32, + "__ghdl_signal_init_e32"); + pragma Export (C, Ghdl_Signal_Associate_E32, + "__ghdl_signal_associate_e32"); + pragma Export (C, Ghdl_Signal_Simple_Assign_E32, + "__ghdl_signal_simple_assign_e32"); + pragma Export (C, Ghdl_Signal_Start_Assign_E32, + "__ghdl_signal_start_assign_e32"); + pragma Export (C, Ghdl_Signal_Next_Assign_E32, + "__ghdl_signal_next_assign_e32"); + pragma Export (C, Ghdl_Signal_Driving_Value_E32, + "__ghdl_signal_driving_value_e32"); + + pragma Export (C, Ghdl_Create_Signal_I32, + "__ghdl_create_signal_i32"); + pragma Export (C, Ghdl_Signal_Init_I32, + "__ghdl_signal_init_i32"); + pragma Export (C, Ghdl_Signal_Associate_I32, + "__ghdl_signal_associate_i32"); + pragma Export (C, Ghdl_Signal_Simple_Assign_I32, + "__ghdl_signal_simple_assign_i32"); + pragma Export (C, Ghdl_Signal_Start_Assign_I32, + "__ghdl_signal_start_assign_i32"); + pragma Export (C, Ghdl_Signal_Next_Assign_I32, + "__ghdl_signal_next_assign_i32"); + pragma Export (C, Ghdl_Signal_Driving_Value_I32, + "__ghdl_signal_driving_value_i32"); + + pragma Export (C, Ghdl_Create_Signal_I64, + "__ghdl_create_signal_i64"); + pragma Export (C, Ghdl_Signal_Init_I64, + "__ghdl_signal_init_i64"); + pragma Export (C, Ghdl_Signal_Associate_I64, + "__ghdl_signal_associate_i64"); + pragma Export (C, Ghdl_Signal_Simple_Assign_I64, + "__ghdl_signal_simple_assign_i64"); + pragma Export (C, Ghdl_Signal_Start_Assign_I64, + "__ghdl_signal_start_assign_i64"); + pragma Export (C, Ghdl_Signal_Next_Assign_I64, + "__ghdl_signal_next_assign_i64"); + pragma Export (C, Ghdl_Signal_Driving_Value_I64, + "__ghdl_signal_driving_value_i64"); + + pragma Export (C, Ghdl_Create_Signal_F64, + "__ghdl_create_signal_f64"); + pragma Export (C, Ghdl_Signal_Init_F64, + "__ghdl_signal_init_f64"); + pragma Export (C, Ghdl_Signal_Associate_F64, + "__ghdl_signal_associate_f64"); + pragma Export (C, Ghdl_Signal_Simple_Assign_F64, + "__ghdl_signal_simple_assign_f64"); + pragma Export (C, Ghdl_Signal_Start_Assign_F64, + "__ghdl_signal_start_assign_f64"); + pragma Export (C, Ghdl_Signal_Next_Assign_F64, + "__ghdl_signal_next_assign_f64"); + pragma Export (C, Ghdl_Signal_Driving_Value_F64, + "__ghdl_signal_driving_value_f64"); + + pragma Export (C, Ghdl_Process_Add_Driver, + "__ghdl_process_add_driver"); + pragma Export (C, Ghdl_Signal_Add_Direct_Driver, + "__ghdl_signal_add_direct_driver"); + + pragma Export (C, Ghdl_Signal_Add_Source, + "__ghdl_signal_add_source"); + pragma Export (C, Ghdl_Signal_Effective_Value, + "__ghdl_signal_effective_value"); + pragma Export (C, Ghdl_Signal_In_Conversion, + "__ghdl_signal_in_conversion"); + pragma Export (C, Ghdl_Signal_Out_Conversion, + "__ghdl_signal_out_conversion"); + + pragma Export (C, Ghdl_Signal_Create_Resolution, + "__ghdl_signal_create_resolution"); + + pragma Export (C, Ghdl_Create_Stable_Signal, + "__ghdl_create_stable_signal"); + pragma Export (C, Ghdl_Create_Quiet_Signal, + "__ghdl_create_quiet_signal"); + pragma Export (C, Ghdl_Create_Transaction_Signal, + "__ghdl_create_transaction_signal"); + pragma Export (C, Ghdl_Signal_Attribute_Register_Prefix, + "__ghdl_signal_attribute_register_prefix"); + pragma Export (C, Ghdl_Create_Delayed_Signal, + "__ghdl_create_delayed_signal"); + + pragma Export (Ada, Ghdl_Signal_Create_Guard, + "__ghdl_signal_create_guard"); + pragma Export (C, Ghdl_Signal_Guard_Dependence, + "__ghdl_signal_guard_dependence"); + + pragma Export (C, Ghdl_Signal_Get_Nbr_Ports, + "__ghdl_signal_get_nbr_ports"); + pragma Export (C, Ghdl_Signal_Get_Nbr_Drivers, + "__ghdl_signal_get_nbr_drivers"); + pragma Export (C, Ghdl_Signal_Read_Port, + "__ghdl_signal_read_port"); + pragma Export (C, Ghdl_Signal_Read_Driver, + "__ghdl_signal_read_driver"); + + pragma Export (C, Ghdl_Signal_Active_Chain, + "__ghdl_signal_active_chain"); + +end Grt.Signals; diff --git a/src/grt/grt-stack2.adb b/src/grt/grt-stack2.adb new file mode 100644 index 000000000..82341d072 --- /dev/null +++ b/src/grt/grt-stack2.adb @@ -0,0 +1,205 @@ +-- GHDL Run Time (GRT) - secondary stack. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Grt.Errors; use Grt.Errors; +with Grt.Stdio; +with Grt.Astdio; + +package body Grt.Stack2 is + -- This should be storage_elements.storage_element, but I don't want to + -- use system.storage_elements package (not pure). Unfortunatly, this is + -- currently a failure (storage_elements is automagically used). + type Memory is array (Mark_Id range <>) of Character; + + type Chunk_Type (First, Last : Mark_Id); + type Chunk_Acc is access all Chunk_Type; + type Chunk_Type (First, Last : Mark_Id) is record + Next : Chunk_Acc; + Mem : Memory (First .. Last); + end record; + + type Stack2_Type is record + First_Chunk : Chunk_Acc; + Last_Chunk : Chunk_Acc; + Top : Mark_Id; + end record; + type Stack2_Acc is access all Stack2_Type; + + function To_Acc is new Ada.Unchecked_Conversion + (Source => Stack2_Ptr, Target => Stack2_Acc); + function To_Addr is new Ada.Unchecked_Conversion + (Source => Stack2_Acc, Target => Stack2_Ptr); + + procedure Free is new Ada.Unchecked_Deallocation + (Object => Chunk_Type, Name => Chunk_Acc); + + function Mark (S : Stack2_Ptr) return Mark_Id + is + S2 : Stack2_Acc; + begin + S2 := To_Acc (S); + return S2.Top; + end Mark; + + procedure Release (S : Stack2_Ptr; Mark : Mark_Id) + is + S2 : Stack2_Acc; + begin + S2 := To_Acc (S); + S2.Top := Mark; + end Release; + + function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type) + return System.Address + is + pragma Suppress (All_Checks); + + S2 : Stack2_Acc; + Chunk : Chunk_Acc; + N_Chunk : Chunk_Acc; + + Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment); + Max_Size : constant Mark_Id := + ((Mark_Id (Size) + Max_Align - 1) / Max_Align) * Max_Align; + + Res : System.Address; + begin + S2 := To_Acc (S); + + -- Find the chunk to which S2.TOP belong. + Chunk := S2.First_Chunk; + loop + exit when S2.Top >= Chunk.First and S2.Top <= Chunk.Last; + Chunk := Chunk.Next; + exit when Chunk = null; + end loop; + + if Chunk /= null then + -- If there is enough place in it, allocate from the chunk. + if S2.Top + Max_Size <= Chunk.Last then + Res := Chunk.Mem (S2.Top)'Address; + S2.Top := S2.Top + Max_Size; + return Res; + end if; + + -- If there is not enough place in it: + -- find a chunk which has enough room, deallocate skipped chunk. + loop + N_Chunk := Chunk.Next; + exit when N_Chunk = null; + if N_Chunk.Last - N_Chunk.First + 1 < Max_Size then + -- Not enough place in this chunk. + Chunk.Next := N_Chunk.Next; + Free (N_Chunk); + if Chunk.Next = null then + S2.Last_Chunk := Chunk; + exit; + end if; + else + Res := N_Chunk.Mem (N_Chunk.First)'Address; + S2.Top := N_Chunk.First + Max_Size; + return Res; + end if; + end loop; + end if; + + -- If not such chunk, allocate a chunk + S2.Top := S2.Last_Chunk.Last + 1; + Chunk := new Chunk_Type (First => S2.Top, + Last => S2.Top + Max_Size - 1); + Chunk.Next := null; + S2.Last_Chunk.Next := Chunk; + S2.Last_Chunk := Chunk; + S2.Top := Chunk.Last + 1; + return Chunk.Mem (Chunk.First)'Address; + end Allocate; + + function Create return Stack2_Ptr is + Res : Stack2_Acc; + Chunk : Chunk_Acc; + begin + Chunk := new Chunk_Type (First => 1, Last => 8 * 1024); + Chunk.Next := null; + Res := new Stack2_Type'(First_Chunk => Chunk, + Last_Chunk => Chunk, + Top => 1); + return To_Addr (Res); + end Create; + + procedure Check_Empty (S : Stack2_Ptr) + is + S2 : Stack2_Acc; + begin + S2 := To_Acc (S); + if S2 /= null and then S2.Top /= S2.First_Chunk.First then + Internal_Error ("stack2.check_empty: stack is not empty"); + end if; + end Check_Empty; + + -- May be used to debug. + procedure Dump_Stack2 (S : Stack2_Ptr); + pragma Unreferenced (Dump_Stack2); + + procedure Dump_Stack2 (S : Stack2_Ptr) + is + use Grt.Astdio; + use Grt.Stdio; + use System; + function To_Address is new Ada.Unchecked_Conversion + (Source => Chunk_Acc, Target => Address); + function To_Address is new Ada.Unchecked_Conversion + (Source => Mark_Id, Target => Address); + S2 : Stack2_Acc; + Chunk : Chunk_Acc; + begin + S2 := To_Acc (S); + Put ("Stack 2 at "); + Put (stdout, Address (S)); + New_Line; + Put ("First Chunk at "); + Put (stdout, To_Address (S2.First_Chunk)); + Put (", last chunk at "); + Put (stdout, To_Address (S2.Last_Chunk)); + Put (", top at "); + Put (stdout, To_Address (S2.Top)); + New_Line; + Chunk := S2.First_Chunk; + while Chunk /= null loop + Put ("Chunk "); + Put (stdout, To_Address (Chunk)); + Put (": first: "); + Put (stdout, To_Address (Chunk.First)); + Put (", last: "); + Put (stdout, To_Address (Chunk.Last)); + Put (", len: "); + Put (stdout, To_Address (Chunk.Last - Chunk.First + 1)); + Put (", next = "); + Put (stdout, To_Address (Chunk.Next)); + New_Line; + Chunk := Chunk.Next; + end loop; + end Dump_Stack2; +end Grt.Stack2; diff --git a/src/grt/grt-stack2.ads b/src/grt/grt-stack2.ads new file mode 100644 index 000000000..b3de6b76d --- /dev/null +++ b/src/grt/grt-stack2.ads @@ -0,0 +1,43 @@ +-- GHDL Run Time (GRT) - secondary stack. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; +with Grt.Types; use Grt.Types; + +-- Secondary stack management. +package Grt.Stack2 is + type Stack2_Ptr is new System.Address; + Null_Stack2_Ptr : constant Stack2_Ptr := Stack2_Ptr (System.Null_Address); + + type Mark_Id is new Integer_Address; + + function Mark (S : Stack2_Ptr) return Mark_Id; + procedure Release (S : Stack2_Ptr; Mark : Mark_Id); + function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type) + return System.Address; + function Create return Stack2_Ptr; + + -- Check S is empty. + procedure Check_Empty (S : Stack2_Ptr); +end Grt.Stack2; diff --git a/src/grt/grt-stacks.adb b/src/grt/grt-stacks.adb new file mode 100644 index 000000000..adb008d02 --- /dev/null +++ b/src/grt/grt-stacks.adb @@ -0,0 +1,43 @@ +-- GHDL Run Time (GRT) - process stacks. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; + +package body Grt.Stacks is + procedure Error_Grow_Failed is + begin + Error ("cannot grow the stack"); + end Error_Grow_Failed; + + procedure Error_Memory_Access is + begin + Error + ("invalid memory access (dangling accesses or stack size too small)"); + end Error_Memory_Access; + + procedure Error_Null_Access is + begin + Error ("NULL access dereferenced"); + end Error_Null_Access; +end Grt.Stacks; diff --git a/src/grt/grt-stacks.ads b/src/grt/grt-stacks.ads new file mode 100644 index 000000000..dd9434080 --- /dev/null +++ b/src/grt/grt-stacks.ads @@ -0,0 +1,87 @@ +-- GHDL Run Time (GRT) - process stacks. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Ada.Unchecked_Conversion; + +package Grt.Stacks is + -- Instance is the parameter of the process procedure. + -- This is in fact a fully opaque type whose content is private to the + -- process. + type Instance is limited private; + type Instance_Acc is access all Instance; + pragma Convention (C, Instance_Acc); + + -- A process is identified by a procedure having a single private + -- parameter (its instance). + type Proc_Acc is access procedure (Self : Instance_Acc); + pragma Convention (C, Proc_Acc); + + function To_Address is new Ada.Unchecked_Conversion + (Instance_Acc, System.Address); + + type Stack_Type is new Address; + Null_Stack : constant Stack_Type := Stack_Type (Null_Address); + + -- Initialize the stacks package. + -- This may adjust stack sizes. + -- Must be called after grt.options.decode. + procedure Stack_Init; + + -- Create a new stack, which on first execution will call FUNC with + -- an argument ARG. + function Stack_Create (Func : Proc_Acc; Arg : Instance_Acc) + return Stack_Type; + + -- Resume stack TO and save the current context to the stack pointed by + -- CUR. + procedure Stack_Switch (To : Stack_Type; From : Stack_Type); + + -- Delete stack STACK, which must not be currently executed. + procedure Stack_Delete (Stack : Stack_Type); + + -- Error during stack handling: + -- Cannot grow the stack. + procedure Error_Grow_Failed; + pragma No_Return (Error_Grow_Failed); + + -- Invalid memory access detected (other than dereferencing a NULL access). + procedure Error_Memory_Access; + pragma No_Return (Error_Memory_Access); + + -- A NULL access is dereferenced. + procedure Error_Null_Access; + pragma No_Return (Error_Null_Access); +private + type Instance is null record; + + pragma Import (C, Stack_Init, "grt_stack_init"); + pragma Import (C, Stack_Create, "grt_stack_create"); + pragma Import (C, Stack_Switch, "grt_stack_switch"); + pragma Import (C, Stack_Delete, "grt_stack_delete"); + + pragma Export (C, Error_Grow_Failed, "grt_stack_error_grow_failed"); + pragma Export (C, Error_Memory_Access, "grt_stack_error_memory_access"); + pragma Export (C, Error_Null_Access, "grt_stack_error_null_access"); +end Grt.Stacks; diff --git a/src/grt/grt-stats.adb b/src/grt/grt-stats.adb new file mode 100644 index 000000000..5bc046d00 --- /dev/null +++ b/src/grt/grt-stats.adb @@ -0,0 +1,370 @@ +-- GHDL Run Time (GRT) - statistics. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Stdio; use Grt.Stdio; +with Grt.Astdio; use Grt.Astdio; +with Grt.Signals; +with Grt.Processes; +with Grt.Types; use Grt.Types; +with Grt.Disp; + +package body Grt.Stats is + type Clock_T is new Integer; + + type Time_Stats is record + Wall : Clock_T; + User : Clock_T; + Sys : Clock_T; + end record; + + -- Number of CLOCK_T per second. + One_Second : Clock_T; + + + -- Get number of seconds per CLOCK_T. + function Get_Clk_Tck return Clock_T; + pragma Import (C, Get_Clk_Tck, "grt_get_clk_tck"); + + -- Get wall, user and system times. + -- This is a binding to times(2). + procedure Get_Times (Wall : Address; User : Address; Sys : Address); + pragma Import (C, Get_Times, "grt_get_times"); + + procedure Get_Stats (Stats : out Time_Stats) + is + begin + Get_Times (Stats.Wall'Address, Stats.User'Address, Stats.Sys'Address); + end Get_Stats; + + function "-" (L : Time_Stats; R : Time_Stats) return Time_Stats + is + begin + return Time_Stats'(Wall => L.Wall - R.Wall, + User => L.User - R.User, + Sys => L.Sys - R.Sys); + end "-"; + + function "+" (L : Time_Stats; R : Time_Stats) return Time_Stats + is + begin + return Time_Stats'(Wall => L.Wall + R.Wall, + User => L.User + R.User, + Sys => L.Sys + R.Sys); + end "+"; + + procedure Put (Stream : FILEs; Val : Clock_T) + is + procedure Fprintf_Clock (Stream : FILEs; A, B : Clock_T); + pragma Import (C, Fprintf_Clock, "__ghdl_fprintf_clock"); + + Sec : Clock_T; + Ms : Clock_T; + begin + Sec := Val / One_Second; + + -- Avoid overflow. + Ms := ((Val mod One_Second) * 1000) / One_Second; + + Fprintf_Clock (Stream, Sec, Ms); + end Put; + + procedure Put (Stream : FILEs; T : Time_Stats) is + begin + Put (Stream, "wall: "); + Put (Stream, T.Wall); + Put (Stream, " user: "); + Put (Stream, T.User); + Put (Stream, " sys: "); + Put (Stream, T.Sys); + end Put; + + type Counter_Kind is (Counter_Elab, Counter_Order, + Counter_Process, Counter_Update, + Counter_Next, Counter_Resume); + + type Counter_Array is array (Counter_Kind) of Time_Stats; + Counters : Counter_Array := (others => (0, 0, 0)); + + Init_Time : Time_Stats; + Last_Counter : Counter_Kind; + Last_Time : Time_Stats; + +-- -- Stats at origin. +-- Start_Time : Time_Stats; +-- End_Elab_Time : Time_Stats; +-- End_Order_Time : Time_Stats; + +-- Start_Proc_Time : Time_Stats; +-- Proc_Times : Time_Stats; + +-- Start_Update_Time : Time_Stats; +-- Update_Times : Time_Stats; + +-- Start_Next_Time_Time : Time_Stats; +-- Next_Time_Times : Time_Stats; + +-- Start_Resume_Time : Time_Stats; +-- Resume_Times : Time_Stats; + +-- Running_Time : Time_Stats; +-- Simu_Time : Time_Stats; + + procedure Start_Elaboration is + begin + One_Second := Get_Clk_Tck; + + Get_Stats (Init_Time); + Last_Time := Init_Time; + Last_Counter := Counter_Elab; + end Start_Elaboration; + + procedure Change_Counter (Cnt : Counter_Kind) + is + New_Time : Time_Stats; + begin + Get_Stats (New_Time); + Counters (Last_Counter) := Counters (Last_Counter) + + (New_Time - Last_Time); + Last_Time := New_Time; + Last_Counter := Cnt; + end Change_Counter; + + procedure Start_Order is + begin + Change_Counter (Counter_Order); + end Start_Order; + + procedure Start_Processes is + begin + Change_Counter (Counter_Process); + end Start_Processes; + + procedure Start_Update is + begin + Change_Counter (Counter_Update); + end Start_Update; + + procedure Start_Next_Time is + begin + Change_Counter (Counter_Next); + end Start_Next_Time; + + procedure Start_Resume is + begin + Change_Counter (Counter_Resume); + end Start_Resume; + + procedure End_Simulation is + begin + Change_Counter (Last_Counter); + end End_Simulation; + + procedure Disp_Signals_Stats + is + use Grt.Signals; + Nbr_No_Drivers : Ghdl_I32; + Nbr_Resolv : Ghdl_I32; + Nbr_Multi_Src : Ghdl_I32; + Nbr_Active : Ghdl_I32; + Nbr_Drivers : Ghdl_I32; + Nbr_Direct_Drivers : Ghdl_I32; + + type Propagation_Kind_Array is array (Propagation_Kind_Type) of Ghdl_I32; + Propag_Count : Propagation_Kind_Array; + + type Mode_Array is array (Mode_Type) of Ghdl_I32; + Mode_Counts : Mode_Array; + + type Mode_Name_Type is array (Mode_Type) of String (1 .. 4); + Mode_Names : constant Mode_Name_Type := (Mode_B1 => "B1: ", + Mode_E8 => "E8: ", + Mode_E32 => "E32:", + Mode_I32 => "I32:", + Mode_I64 => "I64:", + Mode_F64 => "F64:"); + begin + Put (stdout, "Number of simple signals: "); + Put_I32 (stdout, Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1)); + New_Line; + Put (stdout, "Number of signals with projected wave: "); + Put_I32 (stdout, Get_Nbr_Future); + New_Line; + + Nbr_No_Drivers := 0; + Nbr_Resolv := 0; + Nbr_Multi_Src := 0; + Nbr_Active := 0; + Nbr_Drivers := 0; + Nbr_Direct_Drivers := 0; + Mode_Counts := (others => 0); + for I in Sig_Table.First .. Sig_Table.Last loop + declare + Sig : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + begin + Sig := Sig_Table.Table (I); + if Sig.S.Mode_Sig in Mode_Signal_User then + if Sig.S.Nbr_Drivers = 0 then + Nbr_No_Drivers := Nbr_No_Drivers + 1; + end if; + if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 1 then + Nbr_Multi_Src := Nbr_Multi_Src + 1; + end if; + if Sig.S.Resolv /= null then + Nbr_Resolv := Nbr_Resolv + 1; + end if; + Nbr_Drivers := Nbr_Drivers + Ghdl_I32 (Sig.S.Nbr_Drivers); + for J in 1 .. Sig.S.Nbr_Drivers loop + Trans := Sig.S.Drivers (J - 1).Last_Trans; + if Trans /= null and then Trans.Kind = Trans_Direct then + Nbr_Direct_Drivers := Nbr_Direct_Drivers + 1; + end if; + end loop; + end if; + Mode_Counts (Sig.Mode) := Mode_Counts (Sig.Mode) + 1; + if Sig.Has_Active then + Nbr_Active := Nbr_Active + 1; + end if; + end; + end loop; + Put (stdout, "Number of non-driven simple signals: "); + Put_I32 (stdout, Nbr_No_Drivers); + New_Line; + Put (stdout, "Number of resolved simple signals: "); + Put_I32 (stdout, Nbr_Resolv); + New_Line; + Put (stdout, "Number of multi-sourced signals: "); + Put_I32 (stdout, Nbr_Multi_Src); + New_Line; + Put (stdout, "Number of signals whose activity is managed: "); + Put_I32 (stdout, Nbr_Active); + New_Line; + Put (stdout, "Number of drivers: "); + Put_I32 (stdout, Nbr_Drivers); + New_Line; + Put (stdout, "Number of direct drivers: "); + Put_I32 (stdout, Nbr_Direct_Drivers); + New_Line; + Put (stdout, "Number of signals per mode:"); + New_Line; + for I in Mode_Type loop + Put (stdout, " "); + Put (stdout, Mode_Names (I)); + Put (stdout, " "); + Put_I32 (stdout, Mode_Counts (I)); + New_Line; + end loop; + New_Line; + + Propag_Count := (others => 0); + for I in Propagation.First .. Propagation.Last loop + Propag_Count (Propagation.Table (I).Kind) := + Propag_Count (Propagation.Table (I).Kind) + 1; + end loop; + + Put (stdout, "Propagation table length: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Signals.Propagation.Last)); + New_Line; + Put (stdout, "Propagation table count:"); + New_Line; + for I in Propagation_Kind_Type loop + if Propag_Count (I) /= 0 then + Put (stdout, " "); + Grt.Disp.Disp_Propagation_Kind (I); + Put (stdout, ": "); + Put_I32 (stdout, Propag_Count (I)); + New_Line; + end if; + end loop; + end Disp_Signals_Stats; + + -- Disp all statistics. + procedure Disp_Stats + is + N : Natural; + begin + Put (stdout, "total: "); + Put (stdout, Last_Time - Init_Time); + New_Line (stdout); + Put (stdout, " elab: "); + Put (stdout, Counters (Counter_Elab)); + New_Line (stdout); + Put (stdout, " internal elab: "); + Put (stdout, Counters (Counter_Order)); + New_Line (stdout); + Put (stdout, " cycle (sum): "); + Put (stdout, Counters (Counter_Process) + Counters (Counter_Resume) + + Counters (Counter_Update) + Counters (Counter_Next)); + New_Line (stdout); + Put (stdout, " processes: "); + Put (stdout, Counters (Counter_Process)); + New_Line (stdout); + Put (stdout, " resume: "); + Put (stdout, Counters (Counter_Resume)); + New_Line (stdout); + Put (stdout, " update: "); + Put (stdout, Counters (Counter_Update)); + New_Line (stdout); + Put (stdout, " next compute: "); + Put (stdout, Counters (Counter_Next)); + New_Line (stdout); + + Disp_Signals_Stats; + + Put (stdout, "Number of delta cycles: "); + Put_I32 (stdout, Ghdl_I32 (Processes.Nbr_Delta_Cycles)); + New_Line; + Put (stdout, "Number of non-delta cycles: "); + Put_I32 (stdout, Ghdl_I32 (Processes.Nbr_Cycles)); + New_Line; + + Put (stdout, "Nbr of events: "); + Put_I32 (stdout, Signals.Nbr_Events); + New_Line; + Put (stdout, "Nbr of active: "); + Put_I32 (stdout, Signals.Nbr_Active); + New_Line; + + Put (stdout, "Number of processes: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Processes)); + New_Line; + Put (stdout, "Number of sensitized processes: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Sensitized_Processes)); + New_Line; + Put (stdout, "Number of resumed processes: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Resumed_Processes)); + New_Line; + Put (stdout, "Average number of resumed processes per cycle: "); + N := Processes.Nbr_Delta_Cycles + Processes.Nbr_Cycles; + if N = 0 then + Put (stdout, "-"); + else + Put_I32 (stdout, Ghdl_I32 (Processes.Get_Nbr_Resumed_Processes / N)); + end if; + New_Line; + end Disp_Stats; +end Grt.Stats; diff --git a/src/grt/grt-stats.ads b/src/grt/grt-stats.ads new file mode 100644 index 000000000..6f60261af --- /dev/null +++ b/src/grt/grt-stats.ads @@ -0,0 +1,54 @@ +-- GHDL Run Time (GRT) - statistics. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package Grt.Stats is + -- Entry points to gather statistics. + procedure Start_Elaboration; + procedure Start_Order; + + -- Time in user processes. + procedure Start_Processes; + + + -- Time in next time computation. + procedure Start_Next_Time; + + + -- Time in signals update. + procedure Start_Update; + + + -- Time in process resume + procedure Start_Resume; + + + procedure End_Simulation; + + -- Disp all statistics. + procedure Disp_Stats; +end Grt.Stats; + + + diff --git a/src/grt/grt-std_logic_1164.adb b/src/grt/grt-std_logic_1164.adb new file mode 100644 index 000000000..5be308bd6 --- /dev/null +++ b/src/grt/grt-std_logic_1164.adb @@ -0,0 +1,146 @@ +-- GHDL Run Time (GRT) std_logic_1664 subprograms. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with Grt.Lib; + +package body Grt.Std_Logic_1164 is + Assert_DC_Msg : constant String := + "STD_LOGIC_1164: '-' operand for matching ordering operator"; + + Assert_DC_Msg_Bound : constant Std_String_Bound := + (Dim_1 => (Left => 1, Right => Assert_DC_Msg'Length, Dir => Dir_To, + Length => Assert_DC_Msg'Length)); + + Assert_DC_Msg_Str : aliased constant Std_String := + (Base => To_Std_String_Basep (Assert_DC_Msg'Address), + Bounds => To_Std_String_Boundp (Assert_DC_Msg_Bound'Address)); + + Filename : constant String := "std_logic_1164.vhdl" & NUL; + Loc : aliased constant Ghdl_Location := + (Filename => To_Ghdl_C_String (Filename'Address), + Line => 58, + Col => 3); + + procedure Assert_Not_Match (V : Std_Ulogic) + is + use Grt.Lib; + begin + if V = '-' then + Ghdl_Ieee_Assert_Failed + (To_Std_String_Ptr (Assert_DC_Msg_Str'Address), Error_Severity, + To_Ghdl_Location_Ptr (Loc'Address)); + end if; + end Assert_Not_Match; + + function Ghdl_Std_Ulogic_Match_Eq (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Match_Eq_Table (Left, Right)); + end Ghdl_Std_Ulogic_Match_Eq; + + function Ghdl_Std_Ulogic_Match_Ne (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Not_Table (Match_Eq_Table (Left, Right))); + end Ghdl_Std_Ulogic_Match_Ne; + + function Ghdl_Std_Ulogic_Match_Lt (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Match_Lt_Table (Left, Right)); + end Ghdl_Std_Ulogic_Match_Lt; + + function Ghdl_Std_Ulogic_Match_Le (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Or_Table (Match_Lt_Table (Left, Right), + Match_Eq_Table (Left, Right))); + end Ghdl_Std_Ulogic_Match_Le; + + Assert_Arr_Msg : constant String := + "parameters of '?=' array operator are not of the same length"; + + Assert_Arr_Msg_Bound : constant Std_String_Bound := + (Dim_1 => (Left => 1, Right => Assert_Arr_Msg'Length, Dir => Dir_To, + Length => Assert_Arr_Msg'Length)); + + Assert_Arr_Msg_Str : aliased constant Std_String := + (Base => To_Std_String_Basep (Assert_Arr_Msg'Address), + Bounds => To_Std_String_Boundp (Assert_Arr_Msg_Bound'Address)); + + + function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32 + is + use Grt.Lib; + L_Arr : constant Ghdl_E8_Array_Base_Ptr := + To_Ghdl_E8_Array_Base_Ptr (L); + R_Arr : constant Ghdl_E8_Array_Base_Ptr := + To_Ghdl_E8_Array_Base_Ptr (R); + Res : Std_Ulogic := '1'; + begin + if L_Len /= R_Len then + Ghdl_Ieee_Assert_Failed + (To_Std_String_Ptr (Assert_Arr_Msg_Str'Address), Error_Severity, + To_Ghdl_Location_Ptr (Loc'Address)); + end if; + for I in 1 .. L_Len loop + Res := And_Table + (Res, Std_Ulogic'Val (Ghdl_Std_Ulogic_Match_Eq (L_Arr (I - 1), + R_Arr (I - 1)))); + end loop; + return Std_Ulogic'Pos (Res); + end Ghdl_Std_Ulogic_Array_Match_Eq; + + function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32 is + begin + return Std_Ulogic'Pos + (Not_Table (Std_Ulogic'Val + (Ghdl_Std_Ulogic_Array_Match_Eq (L, L_Len, R, R_Len)))); + end Ghdl_Std_Ulogic_Array_Match_Ne; +end Grt.Std_Logic_1164; diff --git a/src/grt/grt-std_logic_1164.ads b/src/grt/grt-std_logic_1164.ads new file mode 100644 index 000000000..4d1569553 --- /dev/null +++ b/src/grt/grt-std_logic_1164.ads @@ -0,0 +1,124 @@ +-- GHDL Run Time (GRT) std_logic_1664 subprograms. +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with Grt.Types; use Grt.Types; + +package Grt.Std_Logic_1164 is + type Std_Ulogic is ('U', 'X', '0', '1', 'Z', 'W','L', 'H', '-'); + + type Stdlogic_Table_2d is array (Std_Ulogic, Std_Ulogic) of Std_Ulogic; + type Stdlogic_Table_1d is array (Std_Ulogic) of Std_Ulogic; + + -- LRM08 9.2.3 Relational operators + Match_Eq_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUUUUUUU1", + "UXXXXXXX1", + "UX10XX101", + "UX01XX011", + "UXXXXXXX1", + "UXXXXXXX1", + "UX10XX101", + "UX01XX011", + "111111111"); + + Match_Lt_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUUUUUUUX", + "UXXXXXXXX", + "UX01XX01X", + "UX00XX00X", + "UXXXXXXXX", + "UXXXXXXXX", + "UX01XX01X", + "UX00XX00X", + "XXXXXXXXX"); + + And_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UU0UUU0UX", -- U + "UX0XXX0XX", -- X + "000000000", -- 0 + "UX01XX01X", -- 1 + "UX0XXX0XX", -- Z + "UX0XXX0XX", -- W + "000000000", -- L + "UX01XX01X", -- H + "UX0XXX0XX"); -- - + + Or_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUU1UUU1U", -- U + "UXX1XXX1X", -- X + "UX01XX01X", -- 0 + "111111111", -- 1 + "UXX1XXX1X", -- Z + "UXX1XXX1X", -- W + "UX01XX01X", -- L + "111111111", -- H + "UXX1XXX1X"); -- - + + Xor_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUUUUUUUU", -- U + "UXXXXXXXX", -- X + "UX01XX01X", -- 0 + "UX10XX10X", -- 1 + "UXXXXXXXX", -- Z + "UXXXXXXXX", -- W + "UX01XX01X", -- L + "UX10XX10X", -- H + "UXXXXXXXX"); -- - + + Not_Table : constant Stdlogic_Table_1d := "UX10XX10X"; + + function Ghdl_Std_Ulogic_Match_Eq (L, R : Ghdl_E8) return Ghdl_E8; + function Ghdl_Std_Ulogic_Match_Ne (L, R : Ghdl_E8) return Ghdl_E8; + function Ghdl_Std_Ulogic_Match_Lt (L, R : Ghdl_E8) return Ghdl_E8; + function Ghdl_Std_Ulogic_Match_Le (L, R : Ghdl_E8) return Ghdl_E8; + -- For Gt and Ge, use Lt and Le with swapped parameters. + + function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32; + function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32; + +private + pragma Export (C, Ghdl_Std_Ulogic_Match_Eq, "__ghdl_std_ulogic_match_eq"); + pragma Export (C, Ghdl_Std_Ulogic_Match_Ne, "__ghdl_std_ulogic_match_ne"); + pragma Export (C, Ghdl_Std_Ulogic_Match_Lt, "__ghdl_std_ulogic_match_lt"); + pragma Export (C, Ghdl_Std_Ulogic_Match_Le, "__ghdl_std_ulogic_match_le"); + + pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Eq, + "__ghdl_std_ulogic_array_match_eq"); + pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Ne, + "__ghdl_std_ulogic_array_match_ne"); +end Grt.Std_Logic_1164; diff --git a/src/grt/grt-stdio.ads b/src/grt/grt-stdio.ads new file mode 100644 index 000000000..229249ac9 --- /dev/null +++ b/src/grt/grt-stdio.ads @@ -0,0 +1,107 @@ +-- GHDL Run Time (GRT) - stdio binding. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; +with Grt.C; use Grt.C; + +-- This package provides a thin binding to the stdio.h of the C library. +-- It mimics GNAT package Interfaces.C_Streams. +-- The purpose of this package is to remove dependencies on the GNAT run time. + +package Grt.Stdio is + pragma Preelaborate (Grt.Stdio); + + -- Type FILE *. + type FILEs is new System.Address; + + -- NULL for a stream. + NULL_Stream : constant FILEs; + + -- Predefined streams. + function stdout return FILEs; + function stderr return FILEs; + function stdin return FILEs; + + -- The following subprograms are translation of the C prototypes. + + function fopen (path: chars; mode : chars) return FILEs; + + function fwrite (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + + function fread (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + + function fputc (c : int; stream : FILEs) return int; + procedure fputc (c : int; stream : FILEs); + + function fputs (s : chars; stream : FILEs) return int; + + function fgetc (stream : FILEs) return int; + function fgets (s : chars; size : int; stream : FILEs) return chars; + function ungetc (c : int; stream : FILEs) return int; + + function fflush (stream : FILEs) return int; + procedure fflush (stream : FILEs); + + function feof (stream : FILEs) return int; + + function ftell (stream : FILEs) return long; + + function fclose (stream : FILEs) return int; + procedure fclose (Stream : FILEs); +private + -- This is a little bit dubious, but this package should be preelaborated, + -- and Null_Address is not static (since defined in the private part + -- of System). + -- I am pretty sure the C definition of NULL is 0. + NULL_Stream : constant FILEs := FILEs (System'To_Address (0)); + + pragma Import (C, fopen); + + pragma Import (C, fwrite); + pragma Import (C, fread); + + pragma Import (C, fputs); + pragma Import (C, fputc); + + pragma Import (C, fgetc); + pragma Import (C, fgets); + pragma Import (C, ungetc); + + pragma Import (C, fflush); + pragma Import (C, feof); + pragma Import (C, ftell); + pragma Import (C, fclose); + + pragma Import (C, stdout, "__ghdl_get_stdout"); + pragma Import (C, stderr, "__ghdl_get_stderr"); + pragma Import (C, stdin, "__ghdl_get_stdin"); +end Grt.Stdio; diff --git a/src/grt/grt-table.adb b/src/grt/grt-table.adb new file mode 100644 index 000000000..36aa99982 --- /dev/null +++ b/src/grt/grt-table.adb @@ -0,0 +1,120 @@ +-- GHDL Run Time (GRT) - Resizable array +-- Copyright (C) 2008 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with System; use System; +with Grt.C; use Grt.C; + +package body Grt.Table is + + -- Maximum index of table before resizing. + Max : Table_Index_Type := Table_Index_Type'Pred (Table_Low_Bound); + + -- Current value of Last + Last_Val : Table_Index_Type; + + function Malloc (Size : size_t) return Table_Ptr; + pragma Import (C, Malloc); + + procedure Free (T : Table_Ptr); + pragma Import (C, Free); + + -- Resize and reallocate the table according to LAST_VAL. + procedure Resize is + function Realloc (T : Table_Ptr; Size : size_t) return Table_Ptr; + pragma Import (C, Realloc); + + New_Size : size_t; + begin + while Max < Last_Val loop + Max := Max + (Max - Table_Low_Bound + 1); + end loop; + + New_Size := size_t ((Max - Table_Low_Bound + 1) * + (Table_Type'Component_Size / Storage_Unit)); + + Table := Realloc (Table, New_Size); + + if Table = null then + raise Storage_Error; + end if; + end Resize; + + procedure Append (New_Val : Table_Component_Type) is + begin + Increment_Last; + Table (Last_Val) := New_Val; + end Append; + + procedure Decrement_Last is + begin + Last_Val := Table_Index_Type'Pred (Last_Val); + end Decrement_Last; + + procedure Free is + begin + Free (Table); + Table := null; + end Free; + + procedure Increment_Last is + begin + Last_Val := Table_Index_Type'Succ (Last_Val); + + if Last_Val > Max then + Resize; + end if; + end Increment_Last; + + function Last return Table_Index_Type is + begin + return Last_Val; + end Last; + + procedure Release is + begin + Max := Last_Val; + Resize; + end Release; + + procedure Set_Last (New_Val : Table_Index_Type) is + begin + if New_Val < Last_Val then + Last_Val := New_Val; + else + Last_Val := New_Val; + + if Last_Val > Max then + Resize; + end if; + end if; + end Set_Last; + +begin + Last_Val := Table_Index_Type'Pred (Table_Low_Bound); + Max := Table_Low_Bound + Table_Index_Type (Table_Initial) - 1; + + Table := Malloc (size_t (Table_Initial * + (Table_Type'Component_Size / Storage_Unit))); +end Grt.Table; diff --git a/src/grt/grt-table.ads b/src/grt/grt-table.ads new file mode 100644 index 000000000..f814eff5c --- /dev/null +++ b/src/grt/grt-table.ads @@ -0,0 +1,75 @@ +-- GHDL Run Time (GRT) - Resizable array +-- Copyright (C) 2008 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type; + Table_Initial : Positive; + +package Grt.Table is + pragma Elaborate_Body; + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + subtype Fat_Table_Type is + Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + + -- Thin pointer. + type Table_Ptr is access all Fat_Table_Type; + + -- The table itself. + Table : aliased Table_Ptr := null; + + -- Get the high bound. + function Last return Table_Index_Type; + pragma Inline (Last); + + -- Get the low bound. + First : constant Table_Index_Type := Table_Low_Bound; + + -- Increase the length by 1. + procedure Increment_Last; + pragma Inline (Increment_Last); + + -- Decrease the length by 1. + procedure Decrement_Last; + pragma Inline (Decrement_Last); + + -- Set the last bound. + procedure Set_Last (New_Val : Table_Index_Type); + + -- Release extra memory. + procedure Release; + + -- Free all the memory used by the table. + -- The table won't be useable anymore. + procedure Free; + + -- Append a new element. + procedure Append (New_Val : Table_Component_Type); + pragma Inline (Append); +end Grt.Table; diff --git a/src/grt/grt-threads.ads b/src/grt/grt-threads.ads new file mode 100644 index 000000000..248f2c41b --- /dev/null +++ b/src/grt/grt-threads.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - threading. +-- Copyright (C) 2005 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Unithread; + +package Grt.Threads renames Grt.Unithread; diff --git a/src/grt/grt-types.ads b/src/grt/grt-types.ads new file mode 100644 index 000000000..fed822554 --- /dev/null +++ b/src/grt/grt-types.ads @@ -0,0 +1,327 @@ +-- GHDL Run Time (GRT) - common types. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Interfaces; use Interfaces; + +package Grt.Types is + pragma Preelaborate (Grt.Types); + + type Ghdl_B1 is new Boolean; + type Ghdl_E8 is new Unsigned_8; + type Ghdl_U32 is new Unsigned_32; + subtype Ghdl_E32 is Ghdl_U32; + type Ghdl_I32 is new Integer_32; + type Ghdl_I64 is new Integer_64; + type Ghdl_U64 is new Unsigned_64; + type Ghdl_F64 is new IEEE_Float_64; + + type Ghdl_Ptr is new Address; + type Ghdl_Index_Type is mod 2 ** 32; + subtype Ghdl_Real is Ghdl_F64; + + type Ghdl_Dir_Type is (Dir_To, Dir_Downto); + for Ghdl_Dir_Type use (Dir_To => 0, Dir_Downto => 1); + for Ghdl_Dir_Type'Size use 8; + + -- Access to an unconstrained string. + type String_Access is access String; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => String_Access, Object => String); + + subtype Std_Integer is Ghdl_I32; + + type Std_Time is new Ghdl_I64; + Bad_Time : constant Std_Time := Std_Time'First; + + type Std_Integer_Trt is record + Left : Std_Integer; + Right : Std_Integer; + Dir : Ghdl_Dir_Type; + Length : Ghdl_Index_Type; + end record; + + subtype Std_Character is Character; + type Std_String_Uncons is array (Ghdl_Index_Type range <>) of Std_Character; + subtype Std_String_Base is Std_String_Uncons (Ghdl_Index_Type); + type Std_String_Basep is access all Std_String_Base; + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => Address, Target => Std_String_Basep); + + type Std_String_Bound is record + Dim_1 : Std_Integer_Trt; + end record; + type Std_String_Boundp is access all Std_String_Bound; + function To_Std_String_Boundp is new Ada.Unchecked_Conversion + (Source => Address, Target => Std_String_Boundp); + + type Std_String is record + Base : Std_String_Basep; + Bounds : Std_String_Boundp; + end record; + type Std_String_Ptr is access all Std_String; + function To_Std_String_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Std_String_Ptr); + + type Std_Bit is ('0', '1'); + type Std_Bit_Vector_Uncons is array (Ghdl_Index_Type range <>) of Std_Bit; + subtype Std_Bit_Vector_Base is Std_Bit_Vector_Uncons (Ghdl_Index_Type); + type Std_Bit_Vector_Basep is access all Std_Bit_Vector_Base; + + -- An unconstrained array. + -- It is in fact a fat pointer to the base and the bounds. + type Ghdl_Uc_Array is record + Base : Address; + Bounds : Address; + end record; + type Ghdl_Uc_Array_Acc is access Ghdl_Uc_Array; + function To_Ghdl_Uc_Array_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Uc_Array_Acc); + + -- Verilog types. + + type Ghdl_Logic32 is record + Val : Ghdl_U32; + Xz : Ghdl_U32; + end record; + type Ghdl_Logic32_Ptr is access Ghdl_Logic32; + type Ghdl_Logic32_Vec is array (Ghdl_U32) of Ghdl_Logic32; + type Ghdl_Logic32_Vptr is access Ghdl_Logic32_Vec; + + function To_Ghdl_Logic32_Vptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Logic32_Vptr); + + function To_Ghdl_Logic32_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Logic32_Ptr); + + -- Mimics C strings (NUL ended). + -- Note: this is 1 based. + type Ghdl_C_String is access String (Positive); + NUL : constant Character := Character'Val (0); + + Nl : constant Character := Character'Val (10); -- LF, nl or '\n'. + + function strlen (Str : Ghdl_C_String) return Natural; + pragma Import (C, strlen); + + function Strcmp (L , R : Ghdl_C_String) return Integer; + pragma Import (C, Strcmp); + + function To_Ghdl_C_String is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_C_String); + + -- Str_len. + type String_Ptr is access String (1 .. Natural'Last); + type Ghdl_Str_Len_Type is record + Len : Natural; + Str : String_Ptr; + end record; + -- Same as previous one, but using 'address. + type Ghdl_Str_Len_Address_Type is record + Len : Natural; + Str : Address; + end record; + type Ghdl_Str_Len_Ptr is access constant Ghdl_Str_Len_Type; + type Ghdl_Str_Len_Array is array (Natural) of Ghdl_Str_Len_Type; + type Ghdl_Str_Len_Array_Ptr is access all Ghdl_Str_Len_Array; + + -- Location is used for errors/messages. + type Ghdl_Location is record + Filename : Ghdl_C_String; + Line : Integer; + Col : Integer; + end record; + type Ghdl_Location_Ptr is access Ghdl_Location; + function To_Ghdl_Location_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Location_Ptr); + + -- Signal index. + type Sig_Table_Index is new Integer; + + -- A range of signals. + type Sig_Table_Range is record + First, Last : Sig_Table_Index; + end record; + + -- Simple values, used for signals. + type Mode_Type is + (Mode_B1, Mode_E8, Mode_E32, Mode_I32, Mode_I64, Mode_F64); + + type Ghdl_B1_Array is array (Ghdl_Index_Type range <>) of Ghdl_B1; + subtype Ghdl_B1_Array_Base is Ghdl_B1_Array (Ghdl_Index_Type); + type Ghdl_B1_Array_Base_Ptr is access Ghdl_B1_Array_Base; + function To_Ghdl_B1_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_B1_Array_Base_Ptr); + + type Ghdl_E8_Array is array (Ghdl_Index_Type range <>) of Ghdl_E8; + subtype Ghdl_E8_Array_Base is Ghdl_E8_Array (Ghdl_Index_Type); + type Ghdl_E8_Array_Base_Ptr is access Ghdl_E8_Array_Base; + function To_Ghdl_E8_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_E8_Array_Base_Ptr); + + type Ghdl_E32_Array is array (Ghdl_Index_Type range <>) of Ghdl_E32; + subtype Ghdl_E32_Array_Base is Ghdl_E32_Array (Ghdl_Index_Type); + type Ghdl_E32_Array_Base_Ptr is access Ghdl_E32_Array_Base; + function To_Ghdl_E32_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_E32_Array_Base_Ptr); + + type Ghdl_I32_Array is array (Ghdl_Index_Type range <>) of Ghdl_I32; + + type Value_Union (Mode : Mode_Type := Mode_B1) is record + case Mode is + when Mode_B1 => + B1 : Ghdl_B1; + when Mode_E8 => + E8 : Ghdl_E8; + when Mode_E32 => + E32 : Ghdl_E32; + when Mode_I32 => + I32 : Ghdl_I32; + when Mode_I64 => + I64 : Ghdl_I64; + when Mode_F64 => + F64 : Ghdl_F64; + end case; + end record; + pragma Unchecked_Union (Value_Union); + + type Ghdl_Value_Ptr is access Value_Union; + function To_Ghdl_Value_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Value_Ptr); + + -- Ranges. + type Ghdl_Range_B1 is record + Left : Ghdl_B1; + Right : Ghdl_B1; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_E8 is record + Left : Ghdl_E8; + Right : Ghdl_E8; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_E32 is record + Left : Ghdl_E32; + Right : Ghdl_E32; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_I32 is record + Left : Ghdl_I32; + Right : Ghdl_I32; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_I64 is record + Left : Ghdl_I64; + Right : Ghdl_I64; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_F64 is record + Left : Ghdl_F64; + Right : Ghdl_F64; + Dir : Ghdl_Dir_Type; + end record; + + type Ghdl_Range_Type (K : Mode_Type := Mode_B1) is record + case K is + when Mode_B1 => + B1 : Ghdl_Range_B1; + when Mode_E8 => + E8 : Ghdl_Range_E8; + when Mode_E32 => + E32 : Ghdl_Range_E32; + when Mode_I32 => + I32 : Ghdl_Range_I32; + when Mode_I64 => + P64 : Ghdl_Range_I64; + when Mode_F64 => + F64 : Ghdl_Range_F64; + end case; + end record; + pragma Unchecked_Union (Ghdl_Range_Type); + + type Ghdl_Range_Ptr is access all Ghdl_Range_Type; + + function To_Ghdl_Range_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Range_Ptr); + + type Ghdl_Range_Array is array (Ghdl_Index_Type range <>) of Ghdl_Range_Ptr; + + -- Mode of a signal. + type Mode_Signal_Type is + (Mode_Signal, + Mode_Linkage, Mode_Buffer, Mode_Out, Mode_Inout, Mode_In, + Mode_Stable, Mode_Quiet, Mode_Delayed, Mode_Transaction, Mode_Guard, + Mode_Conv_In, Mode_Conv_Out, + Mode_End); + + subtype Mode_Signal_Port is + Mode_Signal_Type range Mode_Linkage .. Mode_In; + + -- Not implicit signals. + subtype Mode_Signal_User is + Mode_Signal_Type range Mode_Signal .. Mode_In; + + -- Implicit signals. + subtype Mode_Signal_Implicit is + Mode_Signal_Type range Mode_Stable .. Mode_Guard; + + subtype Mode_Signal_Forward is + Mode_Signal_Type range Mode_Stable .. Mode_Delayed; + + -- Kind of a signal. + type Kind_Signal_Type is + (Kind_Signal_No, Kind_Signal_Register, Kind_Signal_Bus); + + -- Note: we could use system.storage_elements, but unfortunatly, + -- this doesn't work with pragma no_run_time (gnat 3.15p). + type Integer_Address is mod Memory_Size; + + function To_Address is new Ada.Unchecked_Conversion + (Source => Integer_Address, Target => Address); + + function To_Integer is new Ada.Unchecked_Conversion + (Source => Address, Target => Integer_Address); + + -- The NOW value. + Current_Time : Std_Time; + -- Copy of Current_Time before updating it. + -- To be used by hooks. + Cycle_Time : Std_Time; + -- The current delta cycle number. + Current_Delta : Integer; +private + pragma Export (C, Current_Time, "__ghdl_now"); +end Grt.Types; diff --git a/src/grt/grt-unithread.adb b/src/grt/grt-unithread.adb new file mode 100644 index 000000000..6acb52169 --- /dev/null +++ b/src/grt/grt-unithread.adb @@ -0,0 +1,106 @@ +-- GHDL Run Time (GRT) - mono-thread version. +-- Copyright (C) 2005 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package body Grt.Unithread is + procedure Init is + begin + null; + end Init; + + procedure Finish is + begin + null; + end Finish; + + procedure Run_Parallel (Subprg : Parallel_Subprg_Acc) is + begin + Subprg.all; + end Run_Parallel; + + function Atomic_Insert (List : access Ghdl_Signal_Ptr; El : Ghdl_Signal_Ptr) + return Ghdl_Signal_Ptr + is + Prev : Ghdl_Signal_Ptr; + begin + Prev := List.all; + List.all := El; + return Prev; + end Atomic_Insert; + + function Atomic_Inc (Val : access Natural) return Natural + is + Res : Natural; + begin + Res := Val.all; + Val.all := Val.all + 1; + return Res; + end Atomic_Inc; + + Current_Process : Process_Acc; + + -- Called by linux.c + function Grt_Get_Current_Process return Process_Acc; + pragma Export (C, Grt_Get_Current_Process); + + function Grt_Get_Current_Process return Process_Acc is + begin + return Current_Process; + end Grt_Get_Current_Process; + + + procedure Set_Current_Process (Proc : Process_Acc) is + begin + Current_Process := Proc; + end Set_Current_Process; + + function Get_Current_Process return Process_Acc is + begin + return Current_Process; + end Get_Current_Process; + + Stack2 : Stack2_Ptr; + + function Get_Stack2 return Stack2_Ptr is + begin + return Stack2; + end Get_Stack2; + + procedure Set_Stack2 (St : Stack2_Ptr) is + begin + Stack2 := St; + end Set_Stack2; + + Main_Stack : Stack_Type; + + function Get_Main_Stack return Stack_Type is + begin + return Main_Stack; + end Get_Main_Stack; + + procedure Set_Main_Stack (St : Stack_Type) is + begin + Main_Stack := St; + end Set_Main_Stack; +end Grt.Unithread; diff --git a/src/grt/grt-unithread.ads b/src/grt/grt-unithread.ads new file mode 100644 index 000000000..b35b7be33 --- /dev/null +++ b/src/grt/grt-unithread.ads @@ -0,0 +1,73 @@ +-- GHDL Run Time (GRT) - mono-thread version. +-- Copyright (C) 2005 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Signals; use Grt.Signals; +with Grt.Stack2; use Grt.Stack2; +with Grt.Stacks; use Grt.Stacks; + +package Grt.Unithread is + procedure Init; + procedure Finish; + + type Parallel_Subprg_Acc is access procedure; + procedure Run_Parallel (Subprg : Parallel_Subprg_Acc); + + -- Return the old value of LIST.all and store EL into LIST.all. + function Atomic_Insert (List : access Ghdl_Signal_Ptr; El : Ghdl_Signal_Ptr) + return Ghdl_Signal_Ptr; + + -- Return the old value. + function Atomic_Inc (Val : access Natural) return Natural; + + -- Set and get the current process being executed by the thread. + procedure Set_Current_Process (Proc : Process_Acc); + function Get_Current_Process return Process_Acc; + + -- The secondary stack for the thread. In this implementation, there is + -- only one secondary stack, shared by all processes. This is allowed, + -- because a wait statement cannot appear within a function. So at a wait + -- statement, the secondary stack must be empty. + function Get_Stack2 return Stack2_Ptr; + procedure Set_Stack2 (St : Stack2_Ptr); + + -- The main stack. This is initialized by STACK_INIT. + -- The return point. + function Get_Main_Stack return Stack_Type; + procedure Set_Main_Stack (St : Stack_Type); +private + pragma Inline (Run_Parallel); + pragma Inline (Atomic_Insert); + pragma Inline (Atomic_Inc); + pragma Inline (Get_Stack2); + pragma Inline (Set_Stack2); + + pragma Inline (Get_Main_Stack); + pragma Export (C, Set_Main_Stack, "grt_set_main_stack"); + + pragma Inline (Set_Current_Process); + pragma Inline (Get_Current_Process); + +end Grt.Unithread; diff --git a/src/grt/grt-values.adb b/src/grt/grt-values.adb new file mode 100644 index 000000000..3d703bc85 --- /dev/null +++ b/src/grt/grt-values.adb @@ -0,0 +1,639 @@ +-- GHDL Run Time (GRT) - 'value subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Errors; use Grt.Errors; +with Grt.Rtis_Utils; + +package body Grt.Values is + + NBSP : constant Character := Character'Val (160); + HT : constant Character := Character'Val (9); + + -- Return True IFF C is a whitespace character (as defined in LRM93 14.3) + function Is_Whitespace (C : in Character) return Boolean is + begin + return C = ' ' or C = NBSP or C = HT; + end Is_Whitespace; + + -- Increase POS to skip leading whitespace characters, decrease LEN to + -- skip trailing whitespaces in string S. + procedure Remove_Whitespaces (S : Std_String_Basep; + Len : in out Ghdl_Index_Type; + Pos : in out Ghdl_Index_Type) is + begin + -- GHDL: allow several leading whitespace. + while Pos < Len loop + exit when not Is_Whitespace (S (Pos)); + Pos := Pos + 1; + end loop; + + -- GHDL: allow several leading whitespace. + while Len > Pos loop + exit when not Is_Whitespace (S (Len - 1)); + Len := Len - 1; + end loop; + if Pos = Len then + Error_E ("'value: empty string"); + end if; + end Remove_Whitespaces; + + -- Convert C to lowercase. + function To_LC (C : in Character) return Character is + begin + if C >= 'A' and then C <= 'Z' then + return Character'Val + (Character'Pos (C) + Character'Pos ('a') - Character'Pos ('A')); + else + return C; + end if; + end To_LC; + + -- Return TRUE iff user string S (POS .. LEN - 1) is equal to REF. + -- Comparaison is case insensitive, but REF must be lowercase (REF is + -- supposed to come from an RTI). + function String_Match (S : Std_String_Basep; + Pos : Ghdl_Index_Type; + Len : Ghdl_Index_Type; + Ref : Ghdl_C_String) return Boolean + is + P : Ghdl_Index_Type; + C : Character; + begin + P := 0; + loop + C := Ref (Natural (P + 1)); + if Pos + P = Len then + -- End of string. + return C = ASCII.NUL; + end if; + if To_LC (S (Pos + P)) /= C or else C = ASCII.NUL then + return False; + end if; + P := P + 1; + end loop; + end String_Match; + + -- Return the value of STR for enumerated type RTI. + function Ghdl_Value_Enum (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_Index_Type + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + begin + Remove_Whitespaces (S, Len, Pos); + + for I in 0 .. Enum_Rti.Nbr - 1 loop + if String_Match (S, Pos, Len, Enum_Rti.Names (I)) then + return I; + end if; + end loop; + Error_C ("'value: '"); + Error_C_Std (S (Pos .. Len)); + Error_C ("' not in enumeration '"); + Error_C (Enum_Rti.Name); + Error_E ("'"); + end Ghdl_Value_Enum; + + function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_B1 + is + begin + return Ghdl_B1'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_B1; + + function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E8 + is + begin + return Ghdl_E8'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_E8; + + function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E32 + is + begin + return Ghdl_E32'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_E32; + + -- Convert S (INIT_POS .. LEN) to a signed integer. + function Ghdl_Value_I64 (S : Std_String_Basep; + Len : Ghdl_Index_Type; + Init_Pos : Ghdl_Index_Type) + return Ghdl_I64 + is + Pos : Ghdl_Index_Type := Init_Pos; + C : Character; + Sep : Character; + Val, D, Base : Ghdl_I64; + Exp : Integer; + begin + C := S (Pos); + + -- Be user friendly. + -- FIXME: reference. + if C = '-' or C = '+' then + Error_E ("'value: leading sign +/- not allowed"); + end if; + + Val := 0; + loop + if C in '0' .. '9' then + Val := Val * 10 + Character'Pos (C) - Character'Pos ('0'); + Pos := Pos + 1; + exit when Pos >= Len; + C := S (Pos); + else + Error_E ("'value: decimal digit expected"); + end if; + case C is + when '_' => + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: trailing underscore"); + end if; + C := S (Pos); + when '#' + | ':' + | 'E' + | 'e' => + exit; + when ' ' + | NBSP + | HT => + Pos := Pos + 1; + exit; + when others => + null; + end case; + end loop; + + if Pos >= Len then + return Val; + end if; + + if C = '#' or C = ':' then + Base := Val; + Val := 0; + Sep := C; + Pos := Pos + 1; + if Base < 2 or Base > 16 then + Error_E ("'value: bad base"); + end if; + if Pos >= Len then + Error_E ("'value: missing based integer"); + end if; + C := S (Pos); + loop + case C is + when '0' .. '9' => + D := Character'Pos (C) - Character'Pos ('0'); + when 'a' .. 'f' => + D := Character'Pos (C) - Character'Pos ('a') + 10; + when 'A' .. 'F' => + D := Character'Pos (C) - Character'Pos ('A') + 10; + when others => + Error_E ("'value: digit expected"); + end case; + if D >= Base then + Error_E ("'value: digit >= base"); + end if; + Val := Val * Base + D; + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: missing end sign number"); + end if; + C := S (Pos); + if C = '#' or C = ':' then + if C /= Sep then + Error_E ("'value: sign number mismatch"); + end if; + Pos := Pos + 1; + exit; + elsif C = '_' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after underscore"); + end if; + C := S (Pos); + end if; + end loop; + else + Base := 10; + end if; + + -- Handle exponent. + if C = 'e' or C = 'E' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after exponent"); + end if; + C := S (Pos); + if C = '+' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after sign"); + end if; + C := S (Pos); + elsif C = '-' then + Error_E ("'value: negativ exponent not allowed"); + end if; + Exp := 0; + loop + if C in '0' .. '9' then + Exp := Exp * 10 + Character'Pos (C) - Character'Pos ('0'); + Pos := Pos + 1; + exit when Pos >= Len; + C := S (Pos); + else + Error_E ("'value: decimal digit expected"); + end if; + case C is + when '_' => + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: trailing underscore"); + end if; + C := S (Pos); + when ' ' + | NBSP + | HT => + Pos := Pos + 1; + exit; + when others => + null; + end case; + end loop; + while Exp > 0 loop + if Exp mod 2 = 1 then + Val := Val * Base; + end if; + Exp := Exp / 2; + Base := Base * Base; + end loop; + end if; + + if Pos /= Len then + Error_E ("'value: trailing characters after blank"); + end if; + + return Val; + end Ghdl_Value_I64; + + function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64 + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + begin + -- LRM 14.1 + -- Leading [and trailing] whitespace is allowed and ignored. + -- + -- GHDL: allow several leading whitespace. + Remove_Whitespaces (S, Len, Pos); + + return Ghdl_Value_I64 (S, Len, Pos); + end Ghdl_Value_I64; + + function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32 + is + begin + return Ghdl_I32 (Ghdl_Value_I64 (Str)); + end Ghdl_Value_I32; + + -- From patch attached to https://gna.org/bugs/index.php?18352 + -- thanks to Christophe Curis https://gna.org/users/lobotomy + function Ghdl_Value_F64 (S : Std_String_Basep; + Len : Ghdl_Index_Type; + Init_Pos : Ghdl_Index_Type) + return Ghdl_F64 + is + Pos : Ghdl_Index_Type := Init_Pos; + C : Character; + Is_Negative, Is_Neg_Exp : Boolean := False; + Base : Ghdl_F64; + Intg : Ghdl_I32; + Val, Df : Ghdl_F64; + Sep : Character; + FrcExp : Ghdl_F64; + begin + C := S (Pos); + if C = '-' then + Is_Negative := True; + Pos := Pos + 1; + elsif C = '+' then + Pos := Pos + 1; + end if; + + if Pos >= Len then + Error_E ("'value: decimal digit expected"); + end if; + + -- Read Integer-or-Base part (may be optional) + Intg := 0; + while Pos < Len loop + C := S (Pos); + if C in '0' .. '9' then + Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0'); + elsif C /= '_' then + exit; + end if; + Pos := Pos + 1; + end loop; + + if Pos = Len then + return Ghdl_F64 (Intg); + end if; + + -- Special case: base was specified + if C = '#' or C = ':' then + if Intg < 2 or Intg > 16 then + Error_E ("'value: bad base"); + end if; + Base := Ghdl_F64 (Intg); + Val := 0.0; + Sep := C; + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: missing based decimal"); + end if; + + -- Get the Integer part of the Value + while Pos < Len loop + C := S (Pos); + case C is + when '0' .. '9' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0') ); + when 'A' .. 'F' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10); + when 'a' .. 'f' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10); + when others => + exit; + end case; + if C /= '_' then + if Df >= Base then + Error_E ("'value: digit greater than base"); + end if; + Val := Val * Base + Df; + end if; + Pos := Pos + 1; + end loop; + if Pos >= Len then + Error_E ("'value: missing end sign number"); + end if; + else + Base := 10.0; + Sep := ' '; + Val := Ghdl_F64 (Intg); + end if; + + -- Handle the Fractional part + if C = '.' then + Pos := Pos + 1; + FrcExp := 1.0; + while Pos < Len loop + C := S (Pos); + case C is + when '0' .. '9' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0')); + when 'A' .. 'F' => + exit when Sep = ' '; + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10); + when 'a' .. 'f' => + exit when Sep = ' '; + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10); + when others => + exit; + end case; + if C /= '_' then + FrcExp := FrcExp / Base; + if Df > Base then + Error_E ("'value: digit greater than base"); + end if; + Val := Val + Df * FrcExp; + end if; + Pos := Pos + 1; + end loop; + end if; + + -- If base was specified, we must find here the end marker + if Sep /= ' ' then + if Pos >= Len then + Error_E ("'value: missing end sign number"); + end if; + if C /= Sep then + Error_E ("'value: sign number mismatch"); + end if; + Pos := Pos + 1; + end if; + + -- Handle exponent + if Pos < Len then + C := S (Pos); + if C = 'e' or C = 'E' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after exponent"); + end if; + C := S (Pos); + if C = '-' then + Is_Neg_Exp := True; + Pos := Pos + 1; + elsif C = '+' then + Pos := Pos + 1; + end if; + Intg := 0; + while Pos < Len loop + C := S (Pos); + if C in '0' .. '9' then + Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0'); + else + exit; + end if; + Pos := Pos + 1; + end loop; + -- This Exponentiation method is sub-optimal, + -- but it does not depend on any library + FrcExp := 1.0; + if Is_Neg_Exp then + while Intg > 0 loop + FrcExp := FrcExp / 10.0; + Intg := Intg - 1; + end loop; + else + while Intg > 0 loop + FrcExp := FrcExp * 10.0; + Intg := Intg - 1; + end loop; + end if; + Val := Val * FrcExp; + end if; + end if; + + if Pos /= Len then + Error_E ("'value: trailing characters after blank"); + end if; + + if Is_Negative then + Val := -Val; + end if; + + return Val; + end Ghdl_Value_F64; + + -- From patch attached to https://gna.org/bugs/index.php?18352 + -- thanks to Christophe Curis https://gna.org/users/lobotomy + function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64 + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + begin + -- LRM 14.1 + -- Leading and trailing whitespace is allowed and ignored. + -- + -- GHDL: allow several leading whitespace. + Remove_Whitespaces (S, Len, Pos); + + return Ghdl_Value_F64 (S, Len, Pos); + end Ghdl_Value_F64; + + procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr; + Is_Real : out Boolean; + Lit_Pos : out Ghdl_Index_Type; + Lit_End : out Ghdl_Index_Type; + Unit_Pos : out Ghdl_Index_Type) + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + begin + -- LRM 14.1 + -- Leading and trailing whitespace is allowed and ignored. + Lit_Pos := 0; + Remove_Whitespaces (S, Len, Lit_Pos); + + -- Split between abstract literal (optionnal) and unit name. + Lit_End := Lit_Pos; + Is_Real := False; + while Lit_End < Len loop + exit when Is_Whitespace (S (Lit_End)); + if S (Lit_End) = '.' then + Is_Real := True; + end if; + Lit_End := Lit_End + 1; + end loop; + if Lit_End = Len then + -- No literal + Unit_Pos := Lit_Pos; + Lit_End := 0; + else + Unit_Pos := Lit_End + 1; + while Unit_Pos < Len loop + exit when not Is_Whitespace (S (Unit_Pos)); + Unit_Pos := Unit_Pos + 1; + end loop; + end if; + end Ghdl_Value_Physical_Split; + + function Ghdl_Value_Physical_Type (Str : Std_String_Ptr; + Rti : Ghdl_Rti_Access) + return Ghdl_I64 + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Unit_Pos : Ghdl_Index_Type; + Lit_Pos : Ghdl_Index_Type; + Lit_End : Ghdl_Index_Type; + + Found_Real : Boolean; + + Phys_Rti : constant Ghdl_Rtin_Type_Physical_Acc := + To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Multiple : Ghdl_Rti_Access; + Mult : Ghdl_I64; + begin + -- Remove trailing whitespaces. FIXME: also called in physical_split. + Lit_Pos := 0; + Remove_Whitespaces (S, Len, Lit_Pos); + + -- Extract literal and unit + Ghdl_Value_Physical_Split (Str, Found_Real, Lit_Pos, Lit_End, Unit_Pos); + + -- Find unit value + Multiple := null; + for i in 0 .. Phys_Rti.Nbr - 1 loop + Unit_Name := + Rtis_Utils.Get_Physical_Unit_Name (Phys_Rti.Units (i)); + if String_Match (S, Unit_Pos, Len, Unit_Name) then + Multiple := Phys_Rti.Units (i); + exit; + end if; + end loop; + if Multiple = null then + Error_C ("'value: unit '"); + Error_C_Std (S (Unit_Pos .. Len - 1)); + Error_C ("' not in physical type '"); + Error_C (Phys_Rti.Name); + Error_E ("'"); + end if; + + Mult := Grt.Rtis_Utils.Get_Physical_Unit_Value (Multiple, Rti); + + if Lit_End = 0 then + return Mult; + else + if Found_Real then + return Ghdl_I64 + (Ghdl_Value_F64 (S, Lit_End, Lit_Pos) * Ghdl_F64 (Mult)); + else + return Ghdl_Value_I64 (S, Lit_End, Lit_Pos) * Mult; + end if; + end if; + end Ghdl_Value_Physical_Type; + + function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I64 + is + begin + if Rti.Kind /= Ghdl_Rtik_Type_P64 then + Error_E ("Physical_Type_64'value: incorrect RTI"); + end if; + return Ghdl_Value_Physical_Type (Str, Rti); + end Ghdl_Value_P64; + + function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I32 + is + begin + if Rti.Kind /= Ghdl_Rtik_Type_P32 then + Error_E ("Physical_Type_32'value: incorrect RTI"); + end if; + return Ghdl_I32 (Ghdl_Value_Physical_Type (Str, Rti)); + end Ghdl_Value_P32; + +end Grt.Values; diff --git a/src/grt/grt-values.ads b/src/grt/grt-values.ads new file mode 100644 index 000000000..8df8c3f63 --- /dev/null +++ b/src/grt/grt-values.ads @@ -0,0 +1,69 @@ +-- GHDL Run Time (GRT) - 'value subprograms. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Values is + -- Return True IFF C is a whitespace character (as defined in LRM93 14.3) + function Is_Whitespace (C : in Character) return Boolean; + + -- Convert C to lowercase. + function To_LC (C : in Character) return Character; + + -- Extract position of numeric literal and unit in string STR. + -- Set IS_REAL if the unit is a real number (presence of '.'). + -- Set UNIT_POS to the position of the first character of the unit name. + -- Set LIT_POS to the position of the first character of the numeric + -- literal (after whitespaces are skipped). + -- Set LIT_END to the position of the next character of the numeric lit. + procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr; + Is_Real : out Boolean; + Lit_Pos : out Ghdl_Index_Type; + Lit_End : out Ghdl_Index_Type; + Unit_Pos : out Ghdl_Index_Type); + + function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_B1; + function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E8; + function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E32; + function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32; + function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64; + function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64; + function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I64; + function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I32; +private + pragma Export (Ada, Ghdl_Value_B1, "__ghdl_value_b1"); + pragma Export (C, Ghdl_Value_E8, "__ghdl_value_e8"); + pragma Export (C, Ghdl_Value_E32, "__ghdl_value_e32"); + pragma Export (C, Ghdl_Value_I32, "__ghdl_value_i32"); + pragma Export (C, Ghdl_Value_I64, "__ghdl_value_i64"); + pragma Export (C, Ghdl_Value_F64, "__ghdl_value_f64"); + pragma Export (C, Ghdl_Value_P64, "__ghdl_value_p64"); + pragma Export (C, Ghdl_Value_P32, "__ghdl_value_p32"); +end Grt.Values; diff --git a/src/grt/grt-vcd.adb b/src/grt/grt-vcd.adb new file mode 100644 index 000000000..d4a9ea066 --- /dev/null +++ b/src/grt/grt-vcd.adb @@ -0,0 +1,845 @@ +-- GHDL Run Time (GRT) - VCD generator. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Interfaces; +with Grt.Stdio; use Grt.Stdio; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Errors; use Grt.Errors; +with Grt.Signals; use Grt.Signals; +with Grt.Table; +with Grt.Astdio; use Grt.Astdio; +with Grt.C; use Grt.C; +with Grt.Hooks; use Grt.Hooks; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Types; use Grt.Rtis_Types; +with Grt.Vstrings; +pragma Elaborate_All (Grt.Table); + +package body Grt.Vcd is + -- If TRUE, put $date in vcd file. + -- Can be set to FALSE to make vcd comparaison easier. + Flag_Vcd_Date : Boolean := True; + + Stream : FILEs; + + procedure My_Vcd_Put (Str : String) + is + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (Str'Address, Str'Length, 1, Stream); + end My_Vcd_Put; + + procedure My_Vcd_Putc (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), Stream); + end My_Vcd_Putc; + + procedure My_Vcd_Close is + begin + fclose (Stream); + Stream := NULL_Stream; + end My_Vcd_Close; + + -- VCD filename. + -- Stream corresponding to the VCD filename. + --Vcd_Stream : FILEs; + + -- Index type of the table of vcd variables to dump. + type Vcd_Index_Type is new Integer; + + -- Return TRUE if OPT is an option for VCD. + function Vcd_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + Mode : constant String := "wt" & NUL; + Vcd_Filename : String_Access; + begin + if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vcd" then + return False; + end if; + if Opt'Length = 12 and then Opt (F + 5 .. F + 11) = "-nodate" then + Flag_Vcd_Date := False; + return True; + end if; + if Opt'Length > 6 and then Opt (F + 5) = '=' then + if Vcd_Close /= null then + Error ("--vcd: file already set"); + return True; + end if; + + -- Add an extra NUL character. + Vcd_Filename := new String (1 .. Opt'Length - 6 + 1); + Vcd_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last); + Vcd_Filename (Vcd_Filename'Last) := NUL; + + if Vcd_Filename.all = "-" & NUL then + Stream := stdout; + else + Stream := fopen (Vcd_Filename.all'Address, Mode'Address); + if Stream = NULL_Stream then + Error_C ("cannot open "); + Error_E (Vcd_Filename (Vcd_Filename'First + .. Vcd_Filename'Last - 1)); + return True; + end if; + end if; + Vcd_Putc := My_Vcd_Putc'Access; + Vcd_Put := My_Vcd_Put'Access; + Vcd_Close := My_Vcd_Close'Access; + return True; + else + return False; + end if; + end Vcd_Option; + + procedure Vcd_Help is + begin + Put_Line (" --vcd=FILENAME dump signal values into a VCD file"); + Put_Line (" --vcd-nodate do not write date in VCD file"); + end Vcd_Help; + + procedure Vcd_Newline is + begin + Vcd_Putc (Nl); + end Vcd_Newline; + + procedure Vcd_Putline (Str : String) is + begin + Vcd_Put (Str); + Vcd_Newline; + end Vcd_Putline; + +-- procedure Vcd_Put (Str : Ghdl_Str_Len_Type) +-- is +-- begin +-- Put_Str_Len (Vcd_Stream, Str); +-- end Vcd_Put; + + procedure Vcd_Put_I32 (V : Ghdl_I32) + is + Str : String (1 .. 11); + First : Natural; + begin + Vstrings.To_String (Str, First, V); + Vcd_Put (Str (First .. Str'Last)); + end Vcd_Put_I32; + + procedure Vcd_Put_Idcode (N : Vcd_Index_Type) + is + Str : String (1 .. 8); + V, R : Vcd_Index_Type; + L : Natural; + begin + L := 0; + V := N; + loop + R := V mod 93; + V := V / 93; + L := L + 1; + Str (L) := Character'Val (33 + R); + exit when V = 0; + end loop; + Vcd_Put (Str (1 .. L)); + end Vcd_Put_Idcode; + + procedure Vcd_Put_Name (Obj : VhpiHandleT) + is + Name : String (1 .. 128); + Name_Len : Integer; + begin + Vhpi_Get_Str (VhpiNameP, Obj, Name, Name_Len); + if Name_Len <= Name'Last then + Vcd_Put (Name (1 .. Name_Len)); + else + -- Truncate. + Vcd_Put (Name); + end if; + end Vcd_Put_Name; + + procedure Vcd_Put_End is + begin + Vcd_Putline ("$end"); + end Vcd_Put_End; + + -- Called before elaboration. + procedure Vcd_Init + is + begin + if Vcd_Close = null then + return; + end if; + if Flag_Vcd_Date then + Vcd_Putline ("$date"); + Vcd_Put (" "); + declare + type time_t is new Interfaces.Integer_64; + Cur_Time : time_t; + + function time (Addr : Address) return time_t; + pragma Import (C, time); + + function ctime (Timep: Address) return Ghdl_C_String; + pragma Import (C, ctime); + + Ct : Ghdl_C_String; + begin + Cur_Time := time (Null_Address); + Ct := ctime (Cur_Time'Address); + for I in Positive loop + exit when Ct (I) = NUL; + Vcd_Putc (Ct (I)); + end loop; + -- Note: ctime already append a LF. + end; + Vcd_Put_End; + end if; + Vcd_Putline ("$version"); + Vcd_Putline (" GHDL v0"); + Vcd_Put_End; + Vcd_Putline ("$timescale"); + Vcd_Putline (" 1 fs"); + Vcd_Put_End; + end Vcd_Init; + + package Vcd_Table is new Grt.Table + (Table_Component_Type => Verilog_Wire_Info, + Table_Index_Type => Vcd_Index_Type, + Table_Low_Bound => 0, + Table_Initial => 32); + + procedure Avhpi_Error (Err : AvhpiErrorT) + is + pragma Unreferenced (Err); + begin + Put_Line ("Vcd.Avhpi_Error!"); + null; + end Avhpi_Error; + + function Rti_To_Vcd_Kind (Rti : Ghdl_Rti_Access) return Vcd_Var_Kind + is + Rti1 : Ghdl_Rti_Access; + begin + if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then + Rti1 := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype; + else + Rti1 := Rti; + end if; + + if Rti1 = Std_Standard_Boolean_RTI_Ptr then + return Vcd_Bool; + end if; + if Rti1 = Std_Standard_Bit_RTI_Ptr then + return Vcd_Bit; + end if; + if Rti1 = Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr then + return Vcd_Stdlogic; + end if; + if Rti1.Kind = Ghdl_Rtik_Type_I32 then + return Vcd_Integer32; + end if; + if Rti1.Kind = Ghdl_Rtik_Type_F64 then + return Vcd_Float64; + end if; + return Vcd_Bad; + end Rti_To_Vcd_Kind; + + function Rti_To_Vcd_Kind (Rti : Ghdl_Rtin_Type_Array_Acc) + return Vcd_Var_Kind + is + It : Ghdl_Rti_Access; + begin + if Rti.Nbr_Dim /= 1 then + return Vcd_Bad; + end if; + It := Rti.Indexes (0); + if It.Kind /= Ghdl_Rtik_Subtype_Scalar then + return Vcd_Bad; + end if; + if To_Ghdl_Rtin_Subtype_Scalar_Acc (It).Basetype.Kind + /= Ghdl_Rtik_Type_I32 + then + return Vcd_Bad; + end if; + case Rti_To_Vcd_Kind (Rti.Element) is + when Vcd_Bit => + return Vcd_Bitvector; + when Vcd_Stdlogic => + return Vcd_Stdlogic_Vector; + when others => + return Vcd_Bad; + end case; + end Rti_To_Vcd_Kind; + + procedure Get_Verilog_Wire (Sig : VhpiHandleT; Info : out Verilog_Wire_Info) + is + Sig_Type : VhpiHandleT; + Rti : Ghdl_Rti_Access; + Error : AvhpiErrorT; + Sig_Addr : Address; + begin + -- Extract type of the signal. + Vhpi_Handle (VhpiSubtype, Sig, Sig_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Rti := Avhpi_Get_Rti (Sig_Type); + Sig_Addr := Avhpi_Get_Address (Sig); + Info.Kind := Vcd_Bad; + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Subtype_Scalar => + Info.Kind := Rti_To_Vcd_Kind (Rti); + Info.Addr := Sig_Addr; + Info.Irange := null; + when Ghdl_Rtik_Subtype_Array => + declare + St : Ghdl_Rtin_Subtype_Array_Acc; + begin + St := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Info.Kind := Rti_To_Vcd_Kind (St.Basetype); + Info.Addr := Sig_Addr; + Info.Irange := To_Ghdl_Range_Ptr + (Loc_To_Addr (St.Common.Depth, St.Bounds, + Avhpi_Get_Context (Sig))); + end; + when Ghdl_Rtik_Type_Array => + declare + Uc : Ghdl_Uc_Array_Acc; + begin + Info.Kind := Rti_To_Vcd_Kind + (To_Ghdl_Rtin_Type_Array_Acc (Rti)); + Uc := To_Ghdl_Uc_Array_Acc (Sig_Addr); + Info.Addr := Uc.Base; + Info.Irange := To_Ghdl_Range_Ptr (Uc.Bounds); + end; + when others => + Info.Irange := null; + end case; + + -- Do not allow null-array. + if Info.Irange /= null and then Info.Irange.I32.Len = 0 then + Info.Kind := Vcd_Bad; + Info.Irange := null; + return; + end if; + + if Vhpi_Get_Kind (Sig) = VhpiPortDeclK then + case Vhpi_Get_Mode (Sig) is + when VhpiInMode + | VhpiInoutMode + | VhpiBufferMode + | VhpiLinkageMode => + Info.Val := Vcd_Effective; + when VhpiOutMode => + Info.Val := Vcd_Driving; + when VhpiErrorMode => + Info.Kind := Vcd_Bad; + end case; + else + Info.Val := Vcd_Effective; + end if; + end Get_Verilog_Wire; + + procedure Add_Signal (Sig : VhpiHandleT) + is + N : Vcd_Index_Type; + Vcd_El : Verilog_Wire_Info; + begin + Get_Verilog_Wire (Sig, Vcd_El); + + if Vcd_El.Kind = Vcd_Bad then + Vcd_Put ("$comment "); + Vcd_Put_Name (Sig); + Vcd_Put (" is not handled"); + --Vcd_Put (Ghdl_Type_Kind'Image (Desc.Kind)); + Vcd_Putc (' '); + Vcd_Put_End; + return; + else + Vcd_Table.Increment_Last; + N := Vcd_Table.Last; + + Vcd_Table.Table (N) := Vcd_El; + Vcd_Put ("$var "); + case Vcd_El.Kind is + when Vcd_Integer32 => + Vcd_Put ("integer 32"); + when Vcd_Float64 => + Vcd_Put ("real 64"); + when Vcd_Bool + | Vcd_Bit + | Vcd_Stdlogic => + Vcd_Put ("reg 1"); + when Vcd_Bitvector + | Vcd_Stdlogic_Vector => + Vcd_Put ("reg "); + Vcd_Put_I32 (Ghdl_I32 (Vcd_El.Irange.I32.Len)); + when Vcd_Bad => + null; + end case; + Vcd_Putc (' '); + Vcd_Put_Idcode (N); + Vcd_Putc (' '); + Vcd_Put_Name (Sig); + if Vcd_El.Irange /= null then + Vcd_Putc ('['); + Vcd_Put_I32 (Vcd_El.Irange.I32.Left); + Vcd_Putc (':'); + Vcd_Put_I32 (Vcd_El.Irange.I32.Right); + Vcd_Putc (']'); + end if; + Vcd_Putc (' '); + Vcd_Put_End; + if Boolean'(False) then + Vcd_Put ("$comment "); + Vcd_Put_Name (Sig); + Vcd_Put (" is "); + case Vcd_El.Val is + when Vcd_Effective => + Vcd_Put ("effective "); + when Vcd_Driving => + Vcd_Put ("driving "); + end case; + Vcd_Put_End; + end if; + end if; + end Add_Signal; + + procedure Vcd_Put_Hierarchy (Inst : VhpiHandleT) + is + Decl_It : VhpiHandleT; + Decl : VhpiHandleT; + Error : AvhpiErrorT; + begin + Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + -- Extract signals. + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK + | VhpiSigDeclK => + Add_Signal (Decl); + when others => + null; + end case; + end loop; + + -- Extract sub-scopes. + Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + case Vhpi_Get_Kind (Decl) is + when VhpiIfGenerateK + | VhpiForGenerateK + | VhpiBlockStmtK + | VhpiCompInstStmtK => + Vcd_Put ("$scope module "); + Vcd_Put_Name (Decl); + Vcd_Putc (' '); + Vcd_Put_End; + Vcd_Put_Hierarchy (Decl); + Vcd_Put ("$upscope "); + Vcd_Put_End; + when others => + null; + end case; + end loop; + + end Vcd_Put_Hierarchy; + + procedure Vcd_Put_Bit (V : Ghdl_B1) + is + C : Character; + begin + if V then + C := '1'; + else + C := '0'; + end if; + Vcd_Putc (C); + end Vcd_Put_Bit; + + procedure Vcd_Put_Stdlogic (V : Ghdl_E8) + is + type Map_Type is array (Ghdl_E8 range 0 .. 8) of Character; + -- "UX01ZWLH-" + -- Map_Vlg : constant Map_Type := "xx01zz01x"; + Map_Std : constant Map_Type := "UX01ZWLH-"; + begin + if V not in Map_Type'Range then + Vcd_Putc ('?'); + else + Vcd_Putc (Map_Std (V)); + end if; + end Vcd_Put_Stdlogic; + + procedure Vcd_Put_Integer32 (V : Ghdl_U32) + is + Val : Ghdl_U32; + N : Natural; + begin + Val := V; + N := 32; + while N > 1 loop + exit when (Val and 16#8000_0000#) /= 0; + Val := Val * 2; + N := N - 1; + end loop; + + while N > 0 loop + if (Val and 16#8000_0000#) /= 0 then + Vcd_Putc ('1'); + else + Vcd_Putc ('0'); + end if; + Val := Val * 2; + N := N - 1; + end loop; + end Vcd_Put_Integer32; + + -- Using the floor attribute of Ghdl_F64 will result on a link error while + -- trying to simulate a design. So it was needed to create a floor function + function Digit_Floor (V : Ghdl_F64) return Ghdl_I32 + is + Var : Ghdl_I32; + begin + -- V is always positive here and only of interest when it is a digit + if V > 10.0 then + return -1; + else + Var := Ghdl_I32(V-0.5); --Ghdl_I32 rounds to the nearest integer + -- The rounding made by Ghdl_I32 is asymetric : + -- 0.5 will be rounded to 1, but -0.5 to -1 instead of 0 + if Var > 0 then + return Var; + else + return 0; + end if; + end if; + end Digit_Floor; + + procedure Vcd_Put_Float64 (V : Ghdl_F64) + is + Val_tmp, Fact : Ghdl_F64; + Digit, Exp, Delta_Exp, N_Exp : Ghdl_I32; + -- + begin + Exp := 0; + if V /= V then + Vcd_Put("NaN"); + return; + end if; + if V < 0.0 then + Vcd_Putc ('-'); + Val_tmp := -V; + elsif V = 0.0 then + Vcd_Put("0.0"); + return; + else + Val_tmp := V; + end if; + if Val_tmp > Ghdl_F64'Last then + Vcd_Put("Inf"); + return; + elsif Val_tmp < 1.0 then + Fact := 10.0; + Delta_Exp := -1; + else + Fact := 0.1; + Delta_Exp := 1; + end if; + + -- Seek the first digit + loop + Digit := Digit_Floor(Val_tmp); + if Digit > 0 then + exit; + end if; + Exp := Exp + Delta_Exp; + Val_tmp := Val_tmp * Fact; + end loop; + Vcd_Putc(Character'Val(Digit + 48)); + Vcd_Putc('.'); + for i in 0..4 loop -- 5 digits displayed after the point + Val_tmp := abs(Val_tmp - Ghdl_F64(Digit))*10.0; + Digit := Digit_Floor(Val_tmp); + Vcd_Putc(Character'Val(Digit + 48)); + end loop; + Vcd_Putc('E'); + if Exp < 0 then + Vcd_Putc('-'); + Exp := -Exp; + end if; + N_Exp := 100; + while N_Exp > 0 loop + Vcd_Putc(Character'Val(Exp/N_Exp + 48)); + Exp := Exp mod N_Exp; + N_Exp := N_Exp/10; + end loop; + end Vcd_Put_Float64; + + procedure Vcd_Put_Var (I : Vcd_Index_Type) + is + Addr : Address; + V : Verilog_Wire_Info renames Vcd_Table.Table (I); + Len : Ghdl_Index_Type; + begin + Addr := V.Addr; + if V.Irange = null then + Len := 1; + else + Len := V.Irange.I32.Len; + end if; + case V.Val is + when Vcd_Effective => + case V.Kind is + when Vcd_Bit + | Vcd_Bool => + Vcd_Put_Bit (To_Signal_Arr_Ptr (Addr)(0).Value.B1); + when Vcd_Stdlogic => + Vcd_Put_Stdlogic (To_Signal_Arr_Ptr (Addr)(0).Value.E8); + when Vcd_Integer32 => + Vcd_Putc ('b'); + Vcd_Put_Integer32 (To_Signal_Arr_Ptr (Addr)(0).Value.E32); + Vcd_Putc (' '); + when Vcd_Float64 => + Vcd_Putc ('r'); + Vcd_Put_Float64 (To_Signal_Arr_Ptr (Addr)(0).Value.F64); + Vcd_Putc (' '); + when Vcd_Bitvector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Bit (To_Signal_Arr_Ptr (Addr)(J).Value.B1); + end loop; + Vcd_Putc (' '); + when Vcd_Stdlogic_Vector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Stdlogic (To_Signal_Arr_Ptr (Addr)(J).Value.E8); + end loop; + Vcd_Putc (' '); + when Vcd_Bad => + null; + end case; + when Vcd_Driving => + case V.Kind is + when Vcd_Bit + | Vcd_Bool => + Vcd_Put_Bit + (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.B1); + when Vcd_Stdlogic => + Vcd_Put_Stdlogic + (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.E8); + when Vcd_Integer32 => + Vcd_Putc ('b'); + Vcd_Put_Integer32 + (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.E32); + Vcd_Putc (' '); + when Vcd_Float64 => + Vcd_Putc ('r'); + Vcd_Put_Float64 (To_Signal_Arr_Ptr (Addr)(0) + .Driving_Value.F64); + Vcd_Putc (' '); + when Vcd_Bitvector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Bit + (To_Signal_Arr_Ptr (Addr)(J).Driving_Value.B1); + end loop; + Vcd_Putc (' '); + when Vcd_Stdlogic_Vector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Stdlogic + (To_Signal_Arr_Ptr (Addr)(J).Driving_Value.E8); + end loop; + Vcd_Putc (' '); + when Vcd_Bad => + null; + end case; + end case; + Vcd_Put_Idcode (I); + Vcd_Newline; + end Vcd_Put_Var; + + function Verilog_Wire_Changed (Info : Verilog_Wire_Info; + Last : Std_Time) + return Boolean + is + Len : Ghdl_Index_Type; + begin + if Info.Irange = null then + Len := 1; + else + Len := Info.Irange.I32.Len; + end if; + + case Info.Val is + when Vcd_Effective => + case Info.Kind is + when Vcd_Bit + | Vcd_Bool + | Vcd_Stdlogic + | Vcd_Bitvector + | Vcd_Stdlogic_Vector + | Vcd_Integer32 + | Vcd_Float64 => + for J in 0 .. Len - 1 loop + if To_Signal_Arr_Ptr (Info.Addr)(J).Last_Event = Last then + return True; + end if; + end loop; + when Vcd_Bad => + null; + end case; + when Vcd_Driving => + case Info.Kind is + when Vcd_Bit + | Vcd_Bool + | Vcd_Stdlogic + | Vcd_Bitvector + | Vcd_Stdlogic_Vector + | Vcd_Integer32 + | Vcd_Float64 => + for J in 0 .. Len - 1 loop + if To_Signal_Arr_Ptr (Info.Addr)(J).Last_Active = Last + then + return True; + end if; + end loop; + when Vcd_Bad => + null; + end case; + end case; + return False; + end Verilog_Wire_Changed; + + procedure Vcd_Put_Time + is + Str : String (1 .. 21); + First : Natural; + begin + Vcd_Putc ('#'); + Vstrings.To_String (Str, First, Ghdl_I64 (Cycle_Time)); + Vcd_Put (Str (First .. Str'Last)); + Vcd_Newline; + end Vcd_Put_Time; + + procedure Vcd_Cycle; + + -- Called after elaboration. + procedure Vcd_Start + is + Root : VhpiHandleT; + begin + -- Do nothing if there is no VCD file to generate. + if Vcd_Close = null then + return; + end if; + + -- Be sure the RTI of std_ulogic is set. + Search_Types_RTI; + + -- Put hierarchy. + Get_Root_Inst (Root); + Vcd_Put_Hierarchy (Root); + + -- End of header. + Vcd_Put ("$enddefinitions "); + Vcd_Put_End; + + Register_Cycle_Hook (Vcd_Cycle'Access); + end Vcd_Start; + + -- Called before each non delta cycle. + procedure Vcd_Cycle is + begin + -- Disp values. + Vcd_Put_Time; + if Cycle_Time = 0 then + -- Disp all values. + for I in Vcd_Table.First .. Vcd_Table.Last loop + Vcd_Put_Var (I); + end loop; + else + -- Disp only values changed. + for I in Vcd_Table.First .. Vcd_Table.Last loop + if Verilog_Wire_Changed (Vcd_Table.Table (I), Cycle_Time) then + Vcd_Put_Var (I); + end if; + end loop; + end if; + end Vcd_Cycle; + + -- Called at the end of the simulation. + procedure Vcd_End is + begin + if Vcd_Close /= null then + Vcd_Close.all; + end if; + end Vcd_End; + + Vcd_Hooks : aliased constant Hooks_Type := + (Option => Vcd_Option'Access, + Help => Vcd_Help'Access, + Init => Vcd_Init'Access, + Start => Vcd_Start'Access, + Finish => Vcd_End'Access); + + procedure Register is + begin + Register_Hooks (Vcd_Hooks'Access); + end Register; +end Grt.Vcd; diff --git a/src/grt/grt-vcd.ads b/src/grt/grt-vcd.ads new file mode 100644 index 000000000..ed015af80 --- /dev/null +++ b/src/grt/grt-vcd.ads @@ -0,0 +1,65 @@ +-- GHDL Run Time (GRT) - VCD generator. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System; use System; +with Grt.Types; use Grt.Types; +with Grt.Avhpi; use Grt.Avhpi; + +package Grt.Vcd is + -- Abstract type for IO. + type Vcd_Put_Acc is access procedure (Str : String); + type Vcd_Putc_Acc is access procedure (C : Character); + type Vcd_Close_Acc is access procedure; + + Vcd_Put : Vcd_Put_Acc; + Vcd_Putc : Vcd_Putc_Acc; + Vcd_Close : Vcd_Close_Acc; + + type Vcd_Var_Kind is (Vcd_Bad, + Vcd_Bool, + Vcd_Integer32, + Vcd_Float64, + Vcd_Bit, Vcd_Stdlogic, + Vcd_Bitvector, Vcd_Stdlogic_Vector); + + -- Which value to be displayed: effective or driving (for out signals). + type Vcd_Value_Kind is (Vcd_Effective, Vcd_Driving); + + type Verilog_Wire_Info is record + Addr : Address; + Irange : Ghdl_Range_Ptr; + Kind : Vcd_Var_Kind; + Val : Vcd_Value_Kind; + end record; + + procedure Get_Verilog_Wire (Sig : VhpiHandleT; + Info : out Verilog_Wire_Info); + + -- Return TRUE if last change time of the wire described by INFO is LAST. + function Verilog_Wire_Changed (Info : Verilog_Wire_Info; + Last : Std_Time) + return Boolean; + + procedure Register; +end Grt.Vcd; diff --git a/src/grt/grt-vcdz.adb b/src/grt/grt-vcdz.adb new file mode 100644 index 000000000..8e1ceb6f1 --- /dev/null +++ b/src/grt/grt-vcdz.adb @@ -0,0 +1,116 @@ +-- GHDL Run Time (GRT) - VCD .gz module. +-- Copyright (C) 2005 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Vcd; use Grt.Vcd; +with Grt.Errors; use Grt.Errors; +with Grt.Types; use Grt.Types; +with Grt.Astdio; use Grt.Astdio; +with Grt.Hooks; use Grt.Hooks; +with Grt.Zlib; use Grt.Zlib; +with Grt.C; use Grt.C; + +package body Grt.Vcdz is + Stream : gzFile; + + procedure My_Vcd_Put (Str : String) + is + R : int; + pragma Unreferenced (R); + begin + R := gzwrite (Stream, Str'Address, Str'Length); + end My_Vcd_Put; + + procedure My_Vcd_Putc (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := gzputc (Stream, Character'Pos (C)); + end My_Vcd_Putc; + + procedure My_Vcd_Close is + begin + gzclose (Stream); + Stream := NULL_gzFile; + end My_Vcd_Close; + + -- VCD filename. + + -- Return TRUE if OPT is an option for VCD. + function Vcdz_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + Vcd_Filename : String_Access := null; + Mode : constant String := "wb" & NUL; + begin + if Opt'Length < 7 or else Opt (F .. F + 6) /= "--vcdgz" then + return False; + end if; + if Opt'Length > 7 and then Opt (F + 7) = '=' then + if Vcd_Close /= null then + Error ("--vcdgz: file already set"); + return True; + end if; + + -- Add an extra NUL character. + Vcd_Filename := new String (1 .. Opt'Length - 8 + 1); + Vcd_Filename (1 .. Opt'Length - 8) := Opt (F + 8 .. Opt'Last); + Vcd_Filename (Vcd_Filename'Last) := NUL; + + Stream := gzopen (Vcd_Filename.all'Address, Mode'Address); + if Stream = NULL_gzFile then + Error_C ("cannot open "); + Error_E (Vcd_Filename (Vcd_Filename'First + .. Vcd_Filename'Last - 1)); + return True; + end if; + Vcd_Putc := My_Vcd_Putc'Access; + Vcd_Put := My_Vcd_Put'Access; + Vcd_Close := My_Vcd_Close'Access; + return True; + else + return False; + end if; + end Vcdz_Option; + + procedure Vcdz_Help is + begin + Put_Line + (" --vcdgz=FILENAME dump signal values into a VCD gzip'ed file"); + end Vcdz_Help; + + Vcdz_Hooks : aliased constant Hooks_Type := + (Option => Vcdz_Option'Access, + Help => Vcdz_Help'Access, + Init => Proc_Hook_Nil'Access, + Start => Proc_Hook_Nil'Access, + Finish => Proc_Hook_Nil'Access); + + procedure Register is + begin + Register_Hooks (Vcdz_Hooks'Access); + end Register; +end Grt.Vcdz; diff --git a/src/grt/grt-vcdz.ads b/src/grt/grt-vcdz.ads new file mode 100644 index 000000000..aba61c222 --- /dev/null +++ b/src/grt/grt-vcdz.ads @@ -0,0 +1,28 @@ +-- GHDL Run Time (GRT) - VCD .gz module. +-- Copyright (C) 2005 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +package Grt.Vcdz is + procedure Register; +end Grt.Vcdz; diff --git a/src/grt/grt-vital_annotate.adb b/src/grt/grt-vital_annotate.adb new file mode 100644 index 000000000..93ecb8119 --- /dev/null +++ b/src/grt/grt-vital_annotate.adb @@ -0,0 +1,688 @@ +-- GHDL Run Time (GRT) - VITAL annotator. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Types; use Grt.Types; +with Grt.Hooks; use Grt.Hooks; +with Grt.Astdio; use Grt.Astdio; +with Grt.Stdio; use Grt.Stdio; +with Grt.Options; +with Grt.Avhpi; use Grt.Avhpi; +with Grt.Errors; use Grt.Errors; + +package body Grt.Vital_Annotate is + -- Point of the annotation. + Sdf_Top : VhpiHandleT; + + -- Instance being annotated. + Sdf_Inst : VhpiHandleT; + + Flag_Dump : Boolean := False; + Flag_Verbose : constant Boolean := False; + + function Name_Compare (Handle : VhpiHandleT; + Name : String; + Property : VhpiStrPropertyT := VhpiNameP) + return Boolean + is + Obj_Name : String (1 .. Name'Length); + Len : Natural; + begin + Vhpi_Get_Str (Property, Handle, Obj_Name, Len); + if Len = Name'Length and then Obj_Name = Name then + return True; + else + return False; + end if; + end Name_Compare; + + -- Note: RES may alias CUR. + procedure Find_Instance (Cur : VhpiHandleT; + Res : out VhpiHandleT; + Name : String; + Ok : out Boolean) + is + Error : AvhpiErrorT; + It : VhpiHandleT; + begin + Ok := False; + Vhpi_Iterator (VhpiInternalRegions, Cur, It, Error); + if Error /= AvhpiErrorOk then + return; + end if; + loop + Vhpi_Scan (It, Res, Error); + exit when Error /= AvhpiErrorOk; + if Name_Compare (Res, Name) then + Ok := True; + return; + end if; + end loop; + return; +-- Put ("find instance: "); +-- Put (Name); +-- New_Line; + end Find_Instance; + + procedure Find_Generic (Gen_Name : String; + Gen_Handle : out VhpiHandleT; + Port1_Name : String; + Port1_Handle : out VhpiHandleT; + Port2_Name : String; + Port2_Handle : out VhpiHandleT) + is + Error : AvhpiErrorT; + It : VhpiHandleT; + Decl : VhpiHandleT; + begin + Gen_Handle := Null_Handle; + Port1_Handle := Null_Handle; + Port2_Handle := Null_Handle; + + Vhpi_Iterator (VhpiDecls, Sdf_Inst, It, Error); + if Error /= AvhpiErrorOk then + return; + end if; + + -- Look for the generic. + loop + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then + return; + end if; + exit when Vhpi_Get_Kind (Decl) /= VhpiGenericDeclK; + if Name_Compare (Decl, Gen_Name) then + Gen_Handle := Decl; + exit; + end if; + end loop; + + -- Skip generics. + while Vhpi_Get_Kind (Decl) = VhpiGenericDeclK loop + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then + return; + end if; + end loop; + + -- Look for ports. + loop + exit when Vhpi_Get_Kind (Decl) /= VhpiPortDeclK; + if Name_Compare (Decl, Port1_Name) then + Port1_Handle := Decl; + exit when Port2_Name'Length = 0; + end if; + if Port2_Name'Length > 0 + and then Name_Compare (Decl, Port2_Name) + then + Port2_Handle := Decl; + exit when Vhpi_Get_Kind (Port1_Handle) /= VhpiUndefined; + end if; + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then + return; + end if; + end loop; + + end Find_Generic; + + procedure Sdf_Header (Context : Sdf_Context_Type) + is + begin + if Flag_Dump then + case Context.Version is + when Sdf_2_1 => + Put ("found SDF file version 2.1"); + when Sdf_Version_Unknown => + Put ("found SDF file without version"); + when Sdf_Version_Bad => + Put ("found SDF file with unknown version"); + end case; + New_Line; + end if; + end Sdf_Header; + + procedure Sdf_Celltype (Context : Sdf_Context_Type) + is + begin + if Flag_Dump then + Put ("celltype: "); + Put (Context.Celltype (1 .. Context.Celltype_Len)); + New_Line; + Put ("instance:"); + return; + end if; + Sdf_Inst := Sdf_Top; + end Sdf_Celltype; + + procedure Sdf_Instance (Context : in out Sdf_Context_Type; + Instance : String; + Status : out Boolean) + is + pragma Unreferenced (Context); + begin + if Flag_Dump then + Put (' '); + Put (Instance); + Status := True; + return; + end if; + + Find_Instance (Sdf_Inst, Sdf_Inst, Instance, Status); + end Sdf_Instance; + + procedure Sdf_Instance_End (Context : Sdf_Context_Type; + Status : out Boolean) + is + begin + if Flag_Dump then + Status := True; + New_Line; + return; + end if; + case Vhpi_Get_Kind (Sdf_Inst) is + when VhpiRootInstK => + declare + Hdl : VhpiHandleT; + Error : AvhpiErrorT; + begin + Status := False; + Vhpi_Handle (VhpiDesignUnit, Sdf_Inst, Hdl, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("VhpiDesignUnit"); + return; + end if; + case Vhpi_Get_Kind (Hdl) is + when VhpiArchBodyK => + Vhpi_Handle (VhpiPrimaryUnit, Hdl, Hdl, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("VhpiPrimaryUnit"); + return; + end if; + when others => + Internal_Error ("sdf_instance_end"); + end case; + Status := Name_Compare + (Hdl, Context.Celltype (1 .. Context.Celltype_Len)); + end; + when VhpiCompInstStmtK => + Status := Name_Compare + (Sdf_Inst, + Context.Celltype (1 .. Context.Celltype_Len), + VhpiCompNameP); + when others => + Status := False; + end case; + end Sdf_Instance_End; + + VitalDelayType01 : VhpiHandleT; + VitalDelayType01Z : VhpiHandleT; + VitalDelayType01ZX : VhpiHandleT; + VitalDelayArrayType01 : VhpiHandleT; + VitalDelayType : VhpiHandleT; + VitalDelayArrayType : VhpiHandleT; + + type Map_Type is array (1 .. 12) of Natural; + Map_1 : constant Map_Type := (1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0); + Map_2 : constant Map_Type := (1, 2, 1, 1, 2, 2, 0, 0, 0, 0, 0, 0); + Map_3 : constant Map_Type := (1, 2, 3, 1, 3, 2, 0, 0, 0, 0, 0, 0); + Map_6 : constant Map_Type := (1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0, 0); + --Map_12 : constant Map_Type := (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12); + + function Write_Td_Delay_Generic (Context : Sdf_Context_Type; + Gen : VhpiHandleT; + Nbr : Natural; + Map : Map_Type) + return Boolean + is + It : VhpiHandleT; + El : VhpiHandleT; + Error : AvhpiErrorT; + N : Natural; + begin + Vhpi_Iterator (VhpiIndexedNames, Gen, It, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIndexedNames"); + return False; + end if; + for I in 1 .. Nbr loop + Vhpi_Scan (It, El, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("scan on vhpiIndexedNames"); + return False; + end if; + N := Map (I); + if Context.Timing_Set (N) then + if Vhpi_Put_Value (El, Context.Timing (N) * 1000) /= AvhpiErrorOk + then + Internal_Error ("vhpi_put_value"); + return False; + end if; + end if; + end loop; + return True; + end Write_Td_Delay_Generic; + + function Write_Td_Delay_Generic (Context : Sdf_Context_Type; + Gen : VhpiHandleT) + return Boolean + is + Gen_Basetype : VhpiHandleT; + Error : AvhpiErrorT; + begin + Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("write_td_delay_generic: vhpiBaseType"); + return False; + end if; + if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) then + case Context.Timing_Nbr is + when 1 => + return Write_Td_Delay_Generic (Context, Gen, 2, Map_1); + when 2 => + return Write_Td_Delay_Generic (Context, Gen, 2, Map_2); + when others => + Errors.Error + ("timing generic type mismatch SDF timing specification"); + end case; + elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z) then + case Context.Timing_Nbr is + when 1 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_1); + when 2 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_2); + when 3 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_3); + when 6 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_6); + when others => + Errors.Error + ("timing generic type mismatch SDF timing specification"); + end case; + elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType) then + if Vhpi_Put_Value (Gen, Context.Timing (1) * 1000) /= AvhpiErrorOk + then + Internal_Error ("vhpi_put_value (vitaldelaytype)"); + else + return True; + end if; + else + Internal_Error ("write_td_delay_generic: unhandled generic type"); + end if; + end Write_Td_Delay_Generic; + + procedure Generic_Get_Bounds (Port : VhpiHandleT; + Left : out Ghdl_I32; + Len : out Ghdl_Index_Type; + Up : out Boolean) + is + Port_Type, Port_Range : VhpiHandleT; + Error : AvhpiErrorT; + Right : VhpiIntT; + begin + Vhpi_Handle (VhpiSubtype, Port, Port_Type, Error); + Left := 0; + Len := 0; + Up := True; + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiSubtype - port"); + return; + end if; + Vhpi_Handle_By_Index (VhpiConstraints, Port_Type, 1, Port_Range, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIndexConstraints - port"); + return; + end if; + Vhpi_Get (VhpiLeftBoundP, Port_Range, Left, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiLeftBoundP - port"); + return; + end if; + Vhpi_Get (VhpiRightBoundP, Port_Range, Right, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiRightBoundP - port"); + return; + end if; + Vhpi_Get (VhpiIsUpP, Port_Range, Up, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIsUpP - port"); + return; + end if; + if Up then + Len := Ghdl_Index_Type (Right - Left) + 1; + else + Len := Ghdl_Index_Type (Left - Right) + 1; + end if; + end Generic_Get_Bounds; + + procedure Sdf_Generic (Context : in out Sdf_Context_Type; + Name : String; + Ok : out Boolean) + is + Gen : VhpiHandleT; + Gen_Basetype : VhpiHandleT; + Port1, Port2 : VhpiHandleT; + Error : AvhpiErrorT; + begin + if Flag_Dump then + Put ("generic: "); + Put (Name); + if Context.Timing_Nbr = 0 then + Put (' '); + Put_I64 (stdout, Context.Timing (1)); + else + for I in 1 .. 12 loop + Put (' '); + if Context.Timing_Set (I) then + Put_I64 (stdout, Context.Timing (I)); + else + Put ('?'); + end if; + end loop; + end if; + + New_Line; + Ok := True; + return; + end if; + + Ok := False; + + if Context.Port_Num = 1 then + Context.Ports (2).Name_Len := 0; + end if; + Find_Generic + (Name, Gen, + Context.Ports (1).Name (1 .. Context.Ports (1).Name_Len), Port1, + Context.Ports (2).Name (1 .. Context.Ports (2).Name_Len), Port2); + if Vhpi_Get_Kind (Gen) = VhpiUndefined + or else Vhpi_Get_Kind (Port1) = VhpiUndefined + or else (Context.Port_Num = 2 + and then Vhpi_Get_Kind (Port2) = VhpiUndefined) + then + return; + end if; + + -- Extract subtype. + Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiBaseType"); + return; + end if; + if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) + or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z) + or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01ZX) + then + Ok := Write_Td_Delay_Generic (Context, Gen); + elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType01) + or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType) + then + declare + Left_Gen, Left1, Left2 : Ghdl_I32; + Len_Gen, Len1, Len2 : Ghdl_Index_Type; + Up_Gen, Up1, Up2 : Boolean; + Pos : Ghdl_Index_Type; + Gen_El : VhpiHandleT; + begin + Generic_Get_Bounds (Gen, Left_Gen, Len_Gen, Up_Gen); + if Context.Port_Num >= 1 + and then Context.Ports (1).L /= Invalid_Dnumber + then + Generic_Get_Bounds (Port1, Left1, Len1, Up1); + if Up1 then + Pos := Ghdl_Index_Type (Context.Ports (1).L - Left1); + else + Pos := Ghdl_Index_Type (Left1 - Context.Ports (1).L); + end if; + else + Pos := 0; + end if; + if Context.Port_Num >= 2 + and then Context.Ports (2).L /= Invalid_Dnumber + then + Generic_Get_Bounds (Port2, Left2, Len2, Up2); + Pos := Pos * Len2; + if Up2 then + Pos := Pos + Ghdl_Index_Type (Context.Ports (2).L - Left2); + else + Pos := Pos + Ghdl_Index_Type (Left2 - Context.Ports (2).L); + end if; + end if; + Vhpi_Handle_By_Index + (VhpiIndexedNames, Gen, Integer (Pos), Gen_El, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIndexedNames - gen_el"); + return; + end if; + Ok := Write_Td_Delay_Generic (Context, Gen_El); + end; + else + Errors.Error_C ("vital: unhandled generic type for generic "); + Errors.Error_E (Name); + end if; + end Sdf_Generic; + + + procedure Annotate (Arg : String) + is + S, E : Natural; + Ok : Boolean; + begin + if Flag_Verbose then + Put ("sdf annotate: "); + Put (Arg); + New_Line; + end if; + + -- Find scope by name. + Get_Root_Inst (Sdf_Top); + E := Arg'First; + S := E; + L1: loop + -- Skip path separator. + while Arg (E) = '/' or Arg (E) = '.' loop + E := E + 1; + exit L1 when E > Arg'Last; + end loop; + + exit L1 when E > Arg'Last or else Arg (E) = '='; + + -- Instance element. + S := E; + while Arg (E) /= '=' and Arg (E) /= '.' and Arg (E) /= '/' loop + E := E + 1; + exit L1 when E > Arg'Last; + end loop; + + -- Path element. + if E - 1 >= S then + Find_Instance (Sdf_Top, Sdf_Top, Arg (S .. E - 1), Ok); + if not Ok then + Error_C ("cannot find instance '"); + Error_C (Arg (S .. E - 1)); + Error_E ("' for sdf annotation"); + return; + end if; + end if; + end loop L1; + + -- start annotation. + if E >= Arg'Last or else Arg (E) /= '=' then + Error_C ("no filename in sdf option '"); + Error_C (Arg); + Error_E ("'"); + return; + end if; + if not Sdf.Parse_Sdf_File (Arg (E + 1 .. Arg'Last)) then + null; + end if; + end Annotate; + + procedure Extract_Vital_Delay_Type + is + It : VhpiHandleT; + Pkg : VhpiHandleT; + Decl : VhpiHandleT; + Basetype : VhpiHandleT; + Status : AvhpiErrorT; + begin + Get_Package_Inst (It); + loop + Vhpi_Scan (It, Pkg, Status); + exit when Status /= AvhpiErrorOk; + exit when Name_Compare (Pkg, "vital_timing") + and then Name_Compare (Pkg, "ieee", VhpiLibLogicalNameP); + end loop; + if Status /= AvhpiErrorOk then + Error ("package ieee.vital_timing not found, SDF annotation aborted"); + return; + end if; + Vhpi_Iterator (VhpiDecls, Pkg, It, Status); + if Status /= AvhpiErrorOk then + Error ("cannot iterate on vital_timing"); + return; + end if; + loop + Vhpi_Scan (It, Decl, Status); + exit when Status /= AvhpiErrorOk; + if Vhpi_Get_Kind (Decl) = VhpiSubtypeDeclK + or else Vhpi_Get_Kind (Decl) = VhpiArrayTypeDeclK + then + Vhpi_Handle (VhpiBaseType, Decl, Basetype, Status); + if Status = AvhpiErrorOk then + if Name_Compare (Decl, "vitaldelaytype01") then + VitalDelayType01 := Basetype; + elsif Name_Compare (Decl, "vitaldelaytype01z") then + VitalDelayType01Z := Basetype; + elsif Name_Compare (Decl, "vitaldelaytype01zx") then + VitalDelayType01ZX := Basetype; + elsif Name_Compare (Decl, "vitaldelayarraytype01") then + VitalDelayArrayType01 := Basetype; + elsif Name_Compare (Decl, "vitaldelaytype") then + VitalDelayType := Basetype; + elsif Name_Compare (Decl, "vitaldelayarraytype") then + VitalDelayArrayType := Basetype; + end if; + end if; + end if; + end loop; + if Vhpi_Get_Kind (VitalDelayType01) = VhpiUndefined then + Error ("cannot find VitalDelayType01 in ieee.vital_timing"); + return; + end if; + if Vhpi_Get_Kind (VitalDelayType01Z) = VhpiUndefined then + Error ("cannot find VitalDelayType01Z in ieee.vital_timing"); + return; + end if; + if Vhpi_Get_Kind (VitalDelayType01ZX) = VhpiUndefined then + Error ("cannot find VitalDelayType01ZX in ieee.vital_timing"); + return; + end if; + if Vhpi_Get_Kind (VitalDelayArrayType01) = VhpiUndefined then + Error ("cannot find VitalDelayArrayType01 in ieee.vital_timing"); + return; + end if; + if Vhpi_Get_Kind (VitalDelayType) = VhpiUndefined then + Error ("cannot find VitalDelayType in ieee.vital_timing"); + return; + end if; + end Extract_Vital_Delay_Type; + + Has_Sdf_Option : Boolean := False; + + procedure Sdf_Start + is + use Grt.Options; + Len : Integer; + Beg : Integer; + Arg : Ghdl_C_String; + begin + if not Has_Sdf_Option then + -- Nothing to do. + return; + end if; + Flag_Dump := False; + + -- Extract VitalDelayType(s) from VITAL_Timing package. + Extract_Vital_Delay_Type; + + -- Annotate. + for I in 1 .. Last_Opt loop + Arg := Argv (I); + Len := strlen (Arg); + if Len > 5 and then Arg (1 .. 6) = "--sdf=" then + Sdf_Mtm := Typical; + Beg := 7; + if Len > 10 then + if Arg (7 .. 10) = "typ=" then + Beg := 11; + elsif Arg (7 .. 10) = "min=" then + Sdf_Mtm := Minimum; + Beg := 11; + elsif Arg (7 .. 10) = "max=" then + Sdf_Mtm := Maximum; + Beg := 11; + end if; + end if; + Annotate (Arg (Beg .. Len)); + end if; + end loop; + end Sdf_Start; + + function Sdf_Option (Option : String) return Boolean + is + Opt : constant String (1 .. Option'Length) := Option; + begin + if Opt'Length > 11 and then Opt (1 .. 11) = "--sdf-dump=" then + Flag_Dump := True; + if Sdf.Parse_Sdf_File (Opt (12 .. Opt'Last)) then + null; + end if; + return True; + end if; + if Opt'Length > 5 and then Opt (1 .. 6) = "--sdf=" then + Has_Sdf_Option := True; + return True; + else + return False; + end if; + end Sdf_Option; + + procedure Sdf_Help is + begin + Put_Line (" --sdf=[min=|typ=|max=]TOP=FILENAME"); + Put_Line (" annotate TOP with SDF delay file FILENAME"); + end Sdf_Help; + + Sdf_Hooks : aliased constant Hooks_Type := + (Option => Sdf_Option'Access, + Help => Sdf_Help'Access, + Init => Proc_Hook_Nil'Access, + Start => Sdf_Start'Access, + Finish => Proc_Hook_Nil'Access); + + procedure Register is + begin + Register_Hooks (Sdf_Hooks'Access); + end Register; +end Grt.Vital_Annotate; diff --git a/src/grt/grt-vital_annotate.ads b/src/grt/grt-vital_annotate.ads new file mode 100644 index 000000000..acf82bba2 --- /dev/null +++ b/src/grt/grt-vital_annotate.ads @@ -0,0 +1,42 @@ +-- GHDL Run Time (GRT) - VITAL annotator. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Sdf; use Grt.Sdf; + +package Grt.Vital_Annotate is + pragma Elaborate_Body (Grt.Vital_Annotate); + + procedure Sdf_Header (Context : Sdf_Context_Type); + procedure Sdf_Celltype (Context : Sdf_Context_Type); + procedure Sdf_Instance (Context : in out Sdf_Context_Type; + Instance : String; + Status : out Boolean); + procedure Sdf_Instance_End (Context : Sdf_Context_Type; + Status : out Boolean); + procedure Sdf_Generic (Context : in out Sdf_Context_Type; + Name : String; + Ok : out Boolean); + + procedure Register; +end Grt.Vital_Annotate; diff --git a/src/grt/grt-vpi.adb b/src/grt/grt-vpi.adb new file mode 100644 index 000000000..9b77319f1 --- /dev/null +++ b/src/grt/grt-vpi.adb @@ -0,0 +1,988 @@ +-- GHDL Run Time (GRT) - VPI interface. +-- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +-- Description: VPI interface for GRT runtime +-- the main purpose of this code is to interface with the +-- Icarus Verilog Interactive (IVI) simulator GUI + +------------------------------------------------------------------------------- +-- TODO: +------------------------------------------------------------------------------- +-- DONE: +-- * The GHDL VPI implementation doesn't support time +-- callbacks (cbReadOnlySynch). This is needed to support +-- IVI run. Currently, the GHDL simulation runs until +-- complete once a single 'run' is performed... +-- * You are loading '_'-prefixed symbols when you +-- load the vpi plugin. On Linux, there is no leading +-- '_'. I just added code to try both '_'-prefixed and +-- non-'_'-prefixed symbols. I have placed the changed +-- file in the same download dir as the snapshot +-- * I did find out why restart doesn't work for GHDL. +-- You are passing back the leaf name of signals when the +-- FullName is requested. +------------------------------------------------------------------------------- + +with Ada.Unchecked_Deallocation; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Signals; use Grt.Signals; +with Grt.Table; +with Grt.Astdio; use Grt.Astdio; +with Grt.Hooks; use Grt.Hooks; +with Grt.Vcd; use Grt.Vcd; +with Grt.Errors; use Grt.Errors; +with Grt.Rtis_Types; +pragma Elaborate_All (Grt.Table); + +package body Grt.Vpi is + -- The VPI interface requires libdl (dlopen, dlsym) to be linked in. + -- This is now set in Makefile, since this is target dependent. + -- pragma Linker_Options ("-ldl"); + + --errAnyString: constant String := "grt-vcd.adb: any string" & NUL; + --errNoString: constant String := "grt-vcd.adb: no string" & NUL; + + type Vpi_Index_Type is new Integer; + +------------------------------------------------------------------------------- +-- * * * h e l p e r s * * * * * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + ------------------------------------------------------------------------ + -- debugging helpers + procedure dbgPut (Str : String) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Str'Address, Str'Length, 1, stderr); + end dbgPut; + + procedure dbgPut (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), stderr); + end dbgPut; + + procedure dbgNew_Line is + begin + dbgPut (Nl); + end dbgNew_Line; + + procedure dbgPut_Line (Str : String) + is + begin + dbgPut (Str); + dbgNew_Line; + end dbgPut_Line; + +-- procedure dbgPut_Line (Str : Ghdl_Str_Len_Type) +-- is +-- begin +-- Put_Str_Len(stderr, Str); +-- dbgNew_Line; +-- end dbgPut_Line; + + procedure Free is new Ada.Unchecked_Deallocation + (Name => vpiHandle, Object => struct_vpiHandle); + + ------------------------------------------------------------------------ + -- NUL-terminate strings. + -- note: there are several buffers + -- see IEEE 1364-2001 +-- tmpstring1: string(1..1024); +-- function NulTerminate1 (Str : Ghdl_Str_Len_Type) return Ghdl_C_String +-- is +-- begin +-- for i in 1..Str.Len loop +-- tmpstring1(i):= Str.Str(i); +-- end loop; +-- tmpstring1(Str.Len+1):= NUL; +-- return To_Ghdl_C_String (tmpstring1'Address); +-- end NulTerminate1; + +------------------------------------------------------------------------------- +-- * * * V P I f u n c t i o n s * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + ------------------------------------------------------------------------ + -- vpiHandle vpi_iterate(int type, vpiHandle ref) + -- Obtain an iterator handle to objects with a one-to-many relationship. + -- see IEEE 1364-2001, page 685 + function vpi_iterate (aType: integer; Ref: vpiHandle) return vpiHandle + is + Res : vpiHandle; + Rel : VhpiOneToManyT; + Error : AvhpiErrorT; + begin + --dbgPut_Line ("vpi_iterate"); + + case aType is + when vpiNet => + Rel := VhpiDecls; + when vpiModule => + if Ref = null then + Res := new struct_vpiHandle (vpiModule); + Get_Root_Inst (Res.Ref); + return Res; + else + Rel := VhpiInternalRegions; + end if; + when vpiInternalScope => + Rel := VhpiInternalRegions; + when others => + return null; + end case; + + -- find the proper start object for our scan + if Ref = null then + return null; + end if; + + Res := new struct_vpiHandle (aType); + Vhpi_Iterator (Rel, Ref.Ref, Res.Ref, Error); + + if Error /= AvhpiErrorOk then + Free (Res); + end if; + return Res; + end vpi_iterate; + + ------------------------------------------------------------------------ + -- int vpi_get(int property, vpiHandle ref) + -- Get the value of an integer or boolean property of an object. + -- see IEEE 1364-2001, chapter 27.6, page 667 +-- function ii_vpi_get_type (aRef: Ghdl_Instance_Name_Acc) return Integer +-- is +-- begin +-- case aRef.Kind is +-- when Ghdl_Name_Entity +-- | Ghdl_Name_Architecture +-- | Ghdl_Name_Block +-- | Ghdl_Name_Generate_Iterative +-- | Ghdl_Name_Generate_Conditional +-- | Ghdl_Name_Instance => +-- return vpiModule; +-- when Ghdl_Name_Signal => +-- return vpiNet; +-- when others => +-- return vpiUndefined; +-- end case; +-- end ii_vpi_get_type; + + function vpi_get (Property: integer; Ref: vpiHandle) return Integer + is + begin + case Property is + when vpiType=> + return Ref.mType; + when vpiTimePrecision=> + return -9; -- is this nano-seconds? + when others=> + dbgPut_Line ("vpi_get: unknown property"); + return 0; + end case; + end vpi_get; + + ------------------------------------------------------------------------ + -- vpiHandle vpi_scan(vpiHandle iter) + -- Scan the Verilog HDL hierarchy for objects with a one-to-many + -- relationship. + -- see IEEE 1364-2001, chapter 27.36, page 709 + function vpi_scan (Iter: vpiHandle) return vpiHandle + is + Res : VhpiHandleT; + Error : AvhpiErrorT; + R : vpiHandle; + begin + --dbgPut_Line ("vpi_scan"); + if Iter = null then + return null; + end if; + + -- There is only one top-level module. + if Iter.mType = vpiModule then + case Vhpi_Get_Kind (Iter.Ref) is + when VhpiRootInstK => + R := new struct_vpiHandle (Iter.mType); + R.Ref := Iter.Ref; + Iter.Ref := Null_Handle; + return R; + when VhpiUndefined => + return null; + when others => + -- Fall through. + null; + end case; + end if; + + loop + Vhpi_Scan (Iter.Ref, Res, Error); + exit when Error /= AvhpiErrorOk; + + case Vhpi_Get_Kind (Res) is + when VhpiEntityDeclK + | VhpiArchBodyK + | VhpiBlockStmtK + | VhpiIfGenerateK + | VhpiForGenerateK + | VhpiCompInstStmtK => + case Iter.mType is + when vpiInternalScope + | vpiModule => + return new struct_vpiHandle'(mType => vpiModule, + Ref => Res); + when others => + null; + end case; + when VhpiPortDeclK + | VhpiSigDeclK => + if Iter.mType = vpiNet then + declare + Info : Verilog_Wire_Info; + begin + Get_Verilog_Wire (Res, Info); + if Info.Kind /= Vcd_Bad then + return new struct_vpiHandle'(mType => vpiNet, + Ref => Res); + end if; + end; + end if; + when others => + null; + end case; + end loop; + return null; + end vpi_scan; + + ------------------------------------------------------------------------ + -- char *vpi_get_str(int property, vpiHandle ref) + -- see IEEE 1364-2001, page xxx + Tmpstring2 : String (1 .. 1024); + function vpi_get_str (Property : Integer; Ref : vpiHandle) + return Ghdl_C_String + is + Prop : VhpiStrPropertyT; + Len : Natural; + begin + --dbgPut_Line ("vpiGetStr"); + + if Ref = null then + return null; + end if; + + case Property is + when vpiFullName=> + Prop := VhpiFullNameP; + when vpiName=> + Prop := VhpiNameP; + when others=> + dbgPut_Line ("vpi_get_str: undefined property"); + return null; + end case; + Vhpi_Get_Str (Prop, Ref.Ref, Tmpstring2, Len); + Tmpstring2 (Len + 1) := NUL; + if Property = vpiFullName then + for I in Tmpstring2'First .. Len loop + if Tmpstring2 (I) = ':' then + Tmpstring2 (I) := '.'; + end if; + end loop; + -- Remove the initial '.'. + return To_Ghdl_C_String (Tmpstring2 (2)'Address); + else + return To_Ghdl_C_String (Tmpstring2'Address); + end if; + end vpi_get_str; + + ------------------------------------------------------------------------ + -- vpiHandle vpi_handle(int type, vpiHandle ref) + -- Obtain a handle to an object with a one-to-one relationship. + -- see IEEE 1364-2001, chapter 27.16, page 682 + function vpi_handle (aType : Integer; Ref : vpiHandle) return vpiHandle + is + Res : vpiHandle; + begin + --dbgPut_Line ("vpi_handle"); + + if Ref = null then + return null; + end if; + + case aType is + when vpiScope => + case Ref.mType is + when vpiModule => + Res := new struct_vpiHandle (vpiScope); + Res.Ref := Ref.Ref; + return Res; + when others => + return null; + end case; + when vpiRightRange + | vpiLeftRange => + case Ref.mType is + when vpiNet => + Res := new struct_vpiHandle (aType); + Res.Ref := Ref.Ref; + return Res; + when others => + return null; + end case; + when others => + return null; + end case; + end vpi_handle; + + ------------------------------------------------------------------------ + -- void vpi_get_value(vpiHandle expr, p_vpi_value value); + -- Retrieve the simulation value of an object. + -- see IEEE 1364-2001, chapter 27.14, page 675 + Tmpstring3idx : integer; + Tmpstring3 : String (1 .. 1024); + procedure ii_vpi_get_value_bin_str_B1 (Val : Ghdl_B1) + is + begin + case Val is + when True => + Tmpstring3 (Tmpstring3idx) := '1'; + when False => + Tmpstring3 (Tmpstring3idx) := '0'; + end case; + Tmpstring3idx := Tmpstring3idx + 1; + end ii_vpi_get_value_bin_str_B1; + + procedure ii_vpi_get_value_bin_str_E8 (Val : Ghdl_E8) + is + type Map_Type_E8 is array (Ghdl_E8 range 0..8) of character; + Map_Std_E8: constant Map_Type_E8 := "UX01ZWLH-"; + begin + if Val not in Map_Type_E8'range then + Tmpstring3 (Tmpstring3idx) := '?'; + else + Tmpstring3 (Tmpstring3idx) := Map_Std_E8(Val); + end if; + Tmpstring3idx := Tmpstring3idx + 1; + end ii_vpi_get_value_bin_str_E8; + + function ii_vpi_get_value_bin_str (Obj : VhpiHandleT) + return Ghdl_C_String + is + Info : Verilog_Wire_Info; + Len : Ghdl_Index_Type; + begin + case Vhpi_Get_Kind (Obj) is + when VhpiPortDeclK + | VhpiSigDeclK => + null; + when others => + return null; + end case; + + -- Get verilog compat info. + Get_Verilog_Wire (Obj, Info); + if Info.Kind = Vcd_Bad then + return null; + end if; + + if Info.Irange = null then + Len := 1; + else + Len := Info.Irange.I32.Len; + end if; + + Tmpstring3idx := 1; -- reset string buffer + + case Info.Val is + when Vcd_Effective => + case Info.Kind is + when Vcd_Bad + | Vcd_Integer32 + | Vcd_Float64 => + return null; + when Vcd_Bit + | Vcd_Bool + | Vcd_Bitvector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_B1 + (To_Signal_Arr_Ptr (Info.Addr)(J).Value.B1); + end loop; + when Vcd_Stdlogic + | Vcd_Stdlogic_Vector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_E8 + (To_Signal_Arr_Ptr (Info.Addr)(J).Value.E8); + end loop; + end case; + when Vcd_Driving => + case Info.Kind is + when Vcd_Bad + | Vcd_Integer32 + | Vcd_Float64 => + return null; + when Vcd_Bit + | Vcd_Bool + | Vcd_Bitvector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_B1 + (To_Signal_Arr_Ptr (Info.Addr)(J).Driving_Value.B1); + end loop; + when Vcd_Stdlogic + | Vcd_Stdlogic_Vector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_E8 + (To_Signal_Arr_Ptr (Info.Addr)(J).Driving_Value.E8); + end loop; + end case; + end case; + Tmpstring3 (Tmpstring3idx) := NUL; + return To_Ghdl_C_String (Tmpstring3'Address); + end ii_vpi_get_value_bin_str; + + procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value) + is + begin + case Value.Format is + when vpiObjTypeVal=> + -- fill in the object type and value: + -- For an integer, vpiIntVal + -- For a real, vpiRealVal + -- For a scalar, either vpiScalar or vpiStrength + -- For a time variable, vpiTimeVal with vpiSimTime + -- For a vector, vpiVectorVal + dbgPut_Line ("vpi_get_value: vpiObjTypeVal"); + when vpiBinStrVal=> + Value.Str := ii_vpi_get_value_bin_str (Expr.Ref); + --aValue.mStr := NulTerminate2(aExpr.mRef.Name.all); + when vpiOctStrVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiOctStrVal"); + when vpiDecStrVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiDecStrVal"); + when vpiHexStrVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiHexStrVal"); + when vpiScalarVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiScalarVal"); + when vpiIntVal=> + case Expr.mType is + when vpiLeftRange + | vpiRightRange=> + declare + Info : Verilog_Wire_Info; + begin + Get_Verilog_Wire (Expr.Ref, Info); + if Info.Irange /= null then + if Expr.mType = vpiLeftRange then + Value.Integer_m := Integer (Info.Irange.I32.Left); + else + Value.Integer_m := Integer (Info.Irange.I32.Right); + end if; + else + Value.Integer_m := 0; + end if; + end; + when others=> + dbgPut_Line ("vpi_get_value: vpiIntVal, unknown mType"); + end case; + when vpiRealVal=> dbgPut_Line("vpi_get_value: vpiRealVal"); + when vpiStringVal=> dbgPut_Line("vpi_get_value: vpiStringVal"); + when vpiTimeVal=> dbgPut_Line("vpi_get_value: vpiTimeVal"); + when vpiVectorVal=> dbgPut_Line("vpi_get_value: vpiVectorVal"); + when vpiStrengthVal=> dbgPut_Line("vpi_get_value: vpiStrengthVal"); + when others=> dbgPut_Line("vpi_get_value: unknown mFormat"); + end case; + end vpi_get_value; + + ------------------------------------------------------------------------ + -- void vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, + -- p_vpi_time when, int flags) + -- Alter the simulation value of an object. + -- see IEEE 1364-2001, chapter 27.14, page 675 + -- FIXME + + procedure ii_vpi_put_value_bin_str_B1 (SigPtr : Ghdl_Signal_Ptr; + Value : Character) + is + Tempval : Value_Union; + begin + -- use the Set_Effective_Value procedure to update the signal + case Value is + when '0' => + Tempval.B1 := false; + when '1' => + Tempval.B1 := true; + when others => + dbgPut_Line("ii_vpi_put_value_bin_str_B1: " + & "wrong character - signal wont be set"); + return; + end case; + SigPtr.Driving_Value := Tempval; + Set_Effective_Value (SigPtr, Tempval); + end ii_vpi_put_value_bin_str_B1; + + procedure ii_vpi_put_value_bin_str_E8 (SigPtr : Ghdl_Signal_Ptr; + Value : Character) + is + Tempval : Value_Union; + begin + case Value is + when 'U' => + Tempval.E8 := 0; + when 'X' => + Tempval.E8 := 1; + when '0' => + Tempval.E8 := 2; + when '1' => + Tempval.E8 := 3; + when 'Z' => + Tempval.E8 := 4; + when 'W' => + Tempval.E8 := 5; + when 'L' => + Tempval.E8 := 6; + when 'H' => + Tempval.E8 := 7; + when '-' => + Tempval.E8 := 8; + when others => + dbgPut_Line("ii_vpi_put_value_bin_str_B8: " + & "wrong character - signal wont be set"); + return; + end case; + SigPtr.Driving_Value := Tempval; + Set_Effective_Value (SigPtr, Tempval); + end ii_vpi_put_value_bin_str_E8; + + + procedure ii_vpi_put_value_bin_str(Obj : VhpiHandleT; + ValueStr : Ghdl_C_String) + is + Info : Verilog_Wire_Info; + Len : Ghdl_Index_Type; + begin + -- Check the Obj type. + -- * The vpiHandle has a reference (field Ref) to a VhpiHandleT + -- when it doesnt come from a callback. + case Vhpi_Get_Kind(Obj) is + when VhpiPortDeclK + | VhpiSigDeclK => + null; + when others => + return; + end case; + + -- The following code segment was copied from the + -- ii_vpi_get_value function. + -- Get verilog compat info. + Get_Verilog_Wire (Obj, Info); + if Info.Kind = Vcd_Bad then + return; + end if; + + if Info.Irange = null then + Len := 1; + else + Len := Info.Irange.I32.Len; + end if; + + -- Step 1: convert vpi object to internal format. + -- p_vpi_handle -> Ghdl_Signal_Ptr + -- To_Signal_Arr_Ptr (Info.Addr) does part of the magic + + -- Step 2: convert datum to appropriate type. + -- Ghdl_C_String -> Value_Union + + -- Step 3: assigns value to object using Set_Effective_Value + -- call (from grt-signals) + -- Set_Effective_Value(sig_ptr, conv_value); + + + -- Took the skeleton from ii_vpi_get_value function + -- This point of the function must convert the string value to the + -- native ghdl format. + case Info.Kind is + when Vcd_Bad => + return; + when Vcd_Bit + | Vcd_Bool + | Vcd_Bitvector => + for J in 0 .. Len - 1 loop + ii_vpi_put_value_bin_str_B1( + To_Signal_Arr_Ptr(Info.Addr)(J), ValueStr(Integer(J+1))); + end loop; + when Vcd_Stdlogic + | Vcd_Stdlogic_Vector => + for J in 0 .. Len - 1 loop + ii_vpi_put_value_bin_str_E8( + To_Signal_Arr_Ptr(Info.Addr)(J), ValueStr(Integer(J+1))); + end loop; + when Vcd_Integer32 + | Vcd_Float64 => + null; + end case; + + -- Always return null, because this simulation kernel cannot send + -- a handle to the event back. + return; + end ii_vpi_put_value_bin_str; + + + -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, + -- p_vpi_time when, int flags) + function vpi_put_value (aObj: vpiHandle; + aValue: p_vpi_value; + aWhen: p_vpi_time; + aFlags: integer) + return vpiHandle + is + pragma Unreferenced (aWhen); + pragma Unreferenced (aFlags); + begin + -- A very simple write procedure for VPI. + -- Basically, it accepts bin_str values and converts to appropriate + -- types (only std_logic and bit values and vectors). + + -- It'll use Set_Effective_Value procedure to update signals + + -- Ignoring aWhen and aFlags, for now. + + -- Checks the format of aValue. Only vpiBinStrVal will be accepted + -- for now. + case aValue.Format is + when vpiObjTypeVal => + dbgPut_Line ("vpi_put_value: vpiObjTypeVal"); + when vpiBinStrVal => + ii_vpi_put_value_bin_str(aObj.Ref, aValue.Str); + -- dbgPut_Line ("vpi_put_value: vpiBinStrVal"); + when vpiOctStrVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiOctStrVal"); + when vpiDecStrVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiDecStrVal"); + when vpiHexStrVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiHexStrVal"); + when vpiScalarVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiScalarVal"); + when vpiIntVal => + dbgPut_Line ("vpi_put_value: vpiIntVal"); + when vpiRealVal => + dbgPut_Line("vpi_put_value: vpiRealVal"); + when vpiStringVal => + dbgPut_Line("vpi_put_value: vpiStringVal"); + when vpiTimeVal => + dbgPut_Line("vpi_put_value: vpiTimeVal"); + when vpiVectorVal => + dbgPut_Line("vpi_put_value: vpiVectorVal"); + when vpiStrengthVal => + dbgPut_Line("vpi_put_value: vpiStrengthVal"); + when others => + dbgPut_Line("vpi_put_value: unknown mFormat"); + end case; + + -- Must return a scheduled event caused by vpi_put_value() + -- Still dont know how to do it. + return null; + end vpi_put_value; + + ------------------------------------------------------------------------ + -- void vpi_get_time(vpiHandle obj, s_vpi_time*t); + -- see IEEE 1364-2001, page xxx + Sim_Time : Std_Time; + procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time) + is + pragma Unreferenced (Obj); + begin + --dbgPut_Line ("vpi_get_time"); + Time.mType := vpiSimTime; + Time.mHigh := 0; + Time.mLow := Integer (Sim_Time / 1000000); + Time.mReal := 0.0; + end vpi_get_time; + + ------------------------------------------------------------------------ + -- vpiHandle vpi_register_cb(p_cb_data data) + g_cbEndOfCompile : p_cb_data; + g_cbEndOfSimulation: p_cb_data; + --g_cbValueChange: s_cb_data; + g_cbReadOnlySync: p_cb_data; + + type Vpi_Var_Type is record + Info : Verilog_Wire_Info; + Cb : s_cb_data; + end record; + + package Vpi_Table is new Grt.Table + (Table_Component_Type => Vpi_Var_Type, + Table_Index_Type => Vpi_Index_Type, + Table_Low_Bound => 0, + Table_Initial => 32); + + function vpi_register_cb (Data : p_cb_data) return vpiHandle + is + Res : p_cb_data := null; + begin + --dbgPut_Line ("vpi_register_cb"); + case Data.Reason is + when cbEndOfCompile => + Res := new s_cb_data'(Data.all); + g_cbEndOfCompile := Res; + Sim_Time:= 0; + when cbEndOfSimulation => + Res := new s_cb_data'(Data.all); + g_cbEndOfSimulation := Res; + when cbValueChange => + declare + N : Vpi_Index_Type; + begin + --g_cbValueChange:= aData.all; + Vpi_Table.Increment_Last; + N := Vpi_Table.Last; + Vpi_Table.Table (N).Cb := Data.all; + Get_Verilog_Wire (Data.Obj.Ref, Vpi_Table.Table (N).Info); + end; + when cbReadOnlySynch=> + Res := new s_cb_data'(Data.all); + g_cbReadOnlySync := Res; + when others=> + dbgPut_Line ("vpi_register_cb: unknwon reason"); + end case; + if Res /= null then + return new struct_vpiHandle'(mType => vpiCallback, + Cb => Res); + else + return null; + end if; + end vpi_register_cb; + +------------------------------------------------------------------------------- +-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + -- int vpi_free_object(vpiHandle ref) + function vpi_free_object (aRef: vpiHandle) return integer + is + pragma Unreferenced (aRef); + begin + return 0; + end vpi_free_object; + + -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) + function vpi_get_vlog_info (aVlog_info_p: System.Address) return integer + is + pragma Unreferenced (aVlog_info_p); + begin + return 0; + end vpi_get_vlog_info; + + -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index) + function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer) + return vpiHandle + is + pragma Unreferenced (aRef); + pragma Unreferenced (aIndex); + begin + return null; + end vpi_handle_by_index; + + -- unsigned int vpi_mcd_close(unsigned int mcd) + function vpi_mcd_close (Mcd: integer) return integer + is + pragma Unreferenced (Mcd); + begin + return 0; + end vpi_mcd_close; + + -- char *vpi_mcd_name(unsigned int mcd) + function vpi_mcd_name (Mcd: integer) return integer + is + pragma Unreferenced (Mcd); + begin + return 0; + end vpi_mcd_name; + + -- unsigned int vpi_mcd_open(char *name) + function vpi_mcd_open (Name : Ghdl_C_String) return Integer + is + pragma Unreferenced (Name); + begin + return 0; + end vpi_mcd_open; + + -- void vpi_register_systf(const struct t_vpi_systf_data*ss) + procedure vpi_register_systf(aSs: System.Address) + is + pragma Unreferenced (aSs); + begin + null; + end vpi_register_systf; + + -- int vpi_remove_cb(vpiHandle ref) + function vpi_remove_cb (Ref : vpiHandle) return Integer + is + pragma Unreferenced (Ref); + begin + return 0; + end vpi_remove_cb; + + -- void vpi_vprintf(const char*fmt, va_list ap) + procedure vpi_vprintf (Fmt : Address; Ap : Address) + is + pragma Unreferenced (Fmt); + pragma Unreferenced (Ap); + begin + null; + end vpi_vprintf; + + -- missing here, see grt-cvpi.c: + -- vpi_mcd_open_x + -- vpi_mcd_vprintf + -- vpi_mcd_fputc + -- vpi_mcd_fgetc + -- vpi_sim_vcontrol + -- vpi_chk_error + -- pi_handle_by_name + +------------------------------------------------------------------------------ +-- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------ + + -- VCD filename. + Vpi_Filename : String_Access := null; + + ------------------------------------------------------------------------ + -- Return TRUE if OPT is an option for VPI. + function Vpi_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + begin + if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vpi" then + return False; + end if; + if Opt'Length > 6 and then Opt (F + 5) = '=' then + -- Add an extra NUL character. + Vpi_Filename := new String (1 .. Opt'Length - 6 + 1); + Vpi_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last); + Vpi_Filename (Vpi_Filename'Last) := NUL; + return True; + else + return False; + end if; + end Vpi_Option; + + ------------------------------------------------------------------------ + procedure Vpi_Help is + begin + Put_Line (" --vpi=FILENAME load VPI module"); + end Vpi_Help; + + ------------------------------------------------------------------------ + -- Called before elaboration. + + -- void loadVpiModule(const char* modulename) + function LoadVpiModule (Filename: Address) return Integer; + pragma Import (C, LoadVpiModule, "loadVpiModule"); + + + procedure Vpi_Init + is + begin + Sim_Time:= 0; + + --g_cbEndOfCompile.mCb_rtn:= null; + --g_cbEndOfSimulation.mCb_rtn:= null; + --g_cbValueChange.mCb_rtn:= null; + + if Vpi_Filename /= null then + if LoadVpiModule (Vpi_Filename.all'Address) /= 0 then + Error ("cannot load VPI module"); + end if; + end if; + end Vpi_Init; + + procedure Vpi_Cycle; + + ------------------------------------------------------------------------ + -- Called after elaboration. + procedure Vpi_Start + is + Res : Integer; + pragma Unreferenced (Res); + begin + if Vpi_Filename = null then + return; + end if; + + Grt.Rtis_Types.Search_Types_RTI; + Register_Cycle_Hook (Vpi_Cycle'Access); + if g_cbEndOfCompile /= null then + Res := g_cbEndOfCompile.Cb_Rtn.all (g_cbEndOfCompile); + end if; + end Vpi_Start; + + ------------------------------------------------------------------------ + -- Called before each non delta cycle. + procedure Vpi_Cycle + is + Res : Integer; + pragma Unreferenced (Res); + begin + if g_cbReadOnlySync /= null + and then g_cbReadOnlySync.Time.mLow < Integer (Sim_Time / 1_000_000) + then + Res := g_cbReadOnlySync.Cb_Rtn.all (g_cbReadOnlySync); + end if; + + for I in Vpi_Table.First .. Vpi_Table.Last loop + if Verilog_Wire_Changed (Vpi_Table.Table (I).Info, Sim_Time) then + Res := Vpi_Table.Table (I).Cb.Cb_Rtn.all + (To_p_cb_data (Vpi_Table.Table (I).Cb'Address)); + end if; + end loop; + + if Current_Time /= Std_Time'last then + Sim_Time:= Current_Time; + end if; + end Vpi_Cycle; + + ------------------------------------------------------------------------ + -- Called at the end of the simulation. + procedure Vpi_End + is + Res : Integer; + pragma Unreferenced (Res); + begin + if g_cbEndOfSimulation /= null then + Res := g_cbEndOfSimulation.Cb_Rtn.all (g_cbEndOfSimulation); + end if; + end Vpi_End; + + Vpi_Hooks : aliased constant Hooks_Type := + (Option => Vpi_Option'Access, + Help => Vpi_Help'Access, + Init => Vpi_Init'Access, + Start => Vpi_Start'Access, + Finish => Vpi_End'Access); + + procedure Register is + begin + Register_Hooks (Vpi_Hooks'Access); + end Register; +end Grt.Vpi; diff --git a/src/grt/grt-vpi.ads b/src/grt/grt-vpi.ads new file mode 100644 index 000000000..86fb07374 --- /dev/null +++ b/src/grt/grt-vpi.ads @@ -0,0 +1,252 @@ +-- GHDL Run Time (GRT) - VPI interface. +-- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +-- Description: VPI interface for GRT runtime +-- the main purpose of this code is to interface with the +-- Icarus Verilog Interactive (IVI) simulator GUI + +with System; use System; +with Ada.Unchecked_Conversion; +with Grt.Types; use Grt.Types; +with Grt.Avhpi; use Grt.Avhpi; + +package Grt.Vpi is + + -- properties, see vpi_user.h + vpiUndefined: constant integer := -1; + vpiType: constant integer := 1; + vpiName: constant integer := 2; + vpiFullName: constant integer := 3; + vpiTimePrecision: constant integer := 12; + + -- object codes, see vpi_user.h + vpiModule: constant integer := 32; + vpiNet: constant integer := 36; + vpiScope: constant integer := 84; + vpiInternalScope: constant integer := 92; + vpiLeftRange: constant integer := 79; + vpiRightRange: constant integer := 83; + + -- Additionnal constants. + vpiCallback : constant Integer := 200; + + -- codes for the format tag of the vpi_value structure + vpiBinStrVal: constant integer := 1; + vpiOctStrVal: constant integer := 2; + vpiDecStrVal: constant integer := 3; + vpiHexStrVal: constant integer := 4; + vpiScalarVal: constant integer := 5; + vpiIntVal: constant integer := 6; + vpiRealVal: constant integer := 7; + vpiStringVal: constant integer := 8; + vpiVectorVal: constant integer := 9; + vpiStrengthVal: constant integer := 10; + vpiTimeVal: constant integer := 11; + vpiObjTypeVal: constant integer := 12; + vpiSuppressVal: constant integer := 13; + + -- codes for type tag of vpi_time structure + vpiSimTime: constant integer := 2; + + -- codes for the reason tag of cb_data structure + cbValueChange: constant integer:= 1; + cbReadOnlySynch: constant integer:= 7; + cbEndOfCompile: constant integer:= 10; + cbEndOfSimulation:constant integer:= 12; + + type struct_vpiHandle (mType : Integer := vpiUndefined); + type vpiHandle is access struct_vpiHandle; + + -- typedef struct t_vpi_time { + -- int type; + -- unsigned int high; + -- unsigned int low; + -- double real; + -- } s_vpi_time, *p_vpi_time; + type s_vpi_time is record + mType : Integer; + mHigh : Integer; -- this should be unsigned + mLow : Integer; -- this should be unsigned + mReal : Float; -- this should be double + end record; + type p_vpi_time is access s_vpi_time; + + -- typedef struct t_vpi_value + -- { int format; + -- union + -- { char*str; + -- int scalar; + -- int integer; + -- double real; + -- struct t_vpi_time *time; + -- struct t_vpi_vecval *vector; + -- struct t_vpi_strengthval *strength; + -- char*misc; + -- } value; + -- } s_vpi_value, *p_vpi_value; + type s_vpi_value (Format : integer) is record + case Format is + when vpiBinStrVal + | vpiOctStrVal + | vpiDecStrVal + | vpiHexStrVal + | vpiStringVal => + Str : Ghdl_C_String; + when vpiScalarVal => + Scalar : Integer; + when vpiIntVal => + Integer_m : Integer; + --when vpiRealVal=> null; -- what is the equivalent to double? + --when vpiTimeVal=> mTime: p_vpi_time; + --when vpiVectorVal=> mVector: p_vpi_vecval; + --when vpiStrengthVal=> mStrength: p_vpi_strengthval; + when others => + null; + end case; + end record; + type p_vpi_value is access s_vpi_value; + + --typedef struct t_cb_data { + -- int reason; + -- int (*cb_rtn)(struct t_cb_data*cb); + -- vpiHandle obj; + -- p_vpi_time time; + -- p_vpi_value value; + -- int index; + -- char*user_data; + --} s_cb_data, *p_cb_data; + type s_cb_data; + + type p_cb_data is access all s_cb_data; + function To_p_cb_data is new Ada.Unchecked_Conversion + (Source => Address, Target => p_cb_data); + + type cb_rtn_type is access function (Cb : p_cb_data) return Integer; + pragma Convention (C, cb_rtn_type); + + type s_cb_data is record + Reason : Integer; + Cb_Rtn : cb_rtn_type; + Obj : vpiHandle; + Time : p_vpi_time; + Value : p_vpi_value; + Index : Integer; + User_Data : Address; + end record; + + type struct_vpiHandle (mType : Integer := vpiUndefined) is record + case mType is + when vpiCallback => + Cb : p_cb_data; + when others => + Ref : VhpiHandleT; + end case; + end record; + + -- vpiHandle vpi_iterate(int type, vpiHandle ref) + function vpi_iterate (aType : Integer; Ref : vpiHandle) return vpiHandle; + pragma Export (C, vpi_iterate, "vpi_iterate"); + + -- int vpi_get(int property, vpiHandle ref) + function vpi_get (Property : Integer; Ref : vpiHandle) return Integer; + pragma Export (C, vpi_get, "vpi_get"); + + -- vpiHandle vpi_scan(vpiHandle iter) + function vpi_scan (Iter : vpiHandle) return vpiHandle; + pragma Export (C, vpi_scan, "vpi_scan"); + + -- char *vpi_get_str(int property, vpiHandle ref) + function vpi_get_str (Property : Integer; Ref : vpiHandle) + return Ghdl_C_String; + pragma Export (C, vpi_get_str, "vpi_get_str"); + + -- vpiHandle vpi_handle(int type, vpiHandle ref) + function vpi_handle (aType: integer; Ref: vpiHandle) + return vpiHandle; + pragma Export (C, vpi_handle, "vpi_handle"); + + -- void vpi_get_value(vpiHandle expr, p_vpi_value value); + procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value); + pragma Export (C, vpi_get_value, "vpi_get_value"); + + -- void vpi_get_time(vpiHandle obj, s_vpi_time*t); + procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time); + pragma Export (C, vpi_get_time, "vpi_get_time"); + + -- vpiHandle vpi_register_cb(p_cb_data data) + function vpi_register_cb (Data : p_cb_data) return vpiHandle; + pragma Export (C, vpi_register_cb, "vpi_register_cb"); + +------------------------------------------------------------------------------- +-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + -- int vpi_free_object(vpiHandle ref) + function vpi_free_object(aRef: vpiHandle) return integer; + pragma Export (C, vpi_free_object, "vpi_free_object"); + + -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) + function vpi_get_vlog_info(aVlog_info_p: System.Address) return integer; + pragma Export (C, vpi_get_vlog_info, "vpi_get_vlog_info"); + + -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index) + function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer) + return vpiHandle; + pragma Export (C, vpi_handle_by_index, "vpi_handle_by_index"); + + -- unsigned int vpi_mcd_close(unsigned int mcd) + function vpi_mcd_close (Mcd : Integer) return Integer; + pragma Export (C, vpi_mcd_close, "vpi_mcd_close"); + + -- char *vpi_mcd_name(unsigned int mcd) + function vpi_mcd_name (Mcd : Integer) return Integer; + pragma Export (C, vpi_mcd_name, "vpi_mcd_name"); + + -- unsigned int vpi_mcd_open(char *name) + function vpi_mcd_open (Name : Ghdl_C_String) return Integer; + pragma Export (C, vpi_mcd_open, "vpi_mcd_open"); + + -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, + -- p_vpi_time when, int flags) + function vpi_put_value (aObj : vpiHandle; + aValue : p_vpi_value; + aWhen : p_vpi_time; + aFlags : integer) + return vpiHandle; + pragma Export (C, vpi_put_value, "vpi_put_value"); + + -- void vpi_register_systf(const struct t_vpi_systf_data*ss) + procedure vpi_register_systf (aSs : Address); + pragma Export (C, vpi_register_systf, "vpi_register_systf"); + + -- int vpi_remove_cb(vpiHandle ref) + function vpi_remove_cb (Ref : vpiHandle) return integer; + pragma Export (C, vpi_remove_cb, "vpi_remove_cb"); + + -- void vpi_vprintf(const char*fmt, va_list ap) + procedure vpi_vprintf (Fmt: Address; Ap: Address); + pragma Export (C, vpi_vprintf, "vpi_vprintf"); + +------------------------------------------------------------------------------- +-- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + procedure Register; + +end Grt.Vpi; + diff --git a/src/grt/grt-vstrings.adb b/src/grt/grt-vstrings.adb new file mode 100644 index 000000000..30c58ab41 --- /dev/null +++ b/src/grt/grt-vstrings.adb @@ -0,0 +1,422 @@ +-- GHDL Run Time (GRT) - variable strings. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Errors; use Grt.Errors; +with Grt.C; use Grt.C; + +package body Grt.Vstrings is + procedure Free (Fs : Fat_String_Acc); + pragma Import (C, Free); + + function Malloc (Len : Natural) return Fat_String_Acc; + pragma Import (C, Malloc); + + function Realloc (Ptr : Fat_String_Acc; Len : Natural) + return Fat_String_Acc; + pragma Import (C, Realloc); + + + procedure Free (Vstr : in out Vstring) is + begin + Free (Vstr.Str); + Vstr := (Str => null, + Max => 0, + Len => 0); + end Free; + + procedure Grow (Vstr : in out Vstring; Sum : Natural) + is + Nlen : constant Natural := Vstr.Len + Sum; + Nmax : Natural; + begin + Vstr.Len := Nlen; + if Nlen <= Vstr.Max then + return; + end if; + if Vstr.Max = 0 then + Nmax := 32; + else + Nmax := Vstr.Max; + end if; + while Nmax < Nlen loop + Nmax := Nmax * 2; + end loop; + Vstr.Str := Realloc (Vstr.Str, Nmax); + if Vstr.Str = null then + Internal_Error ("grt.vstrings.grow: memory exhausted"); + end if; + Vstr.Max := Nmax; + end Grow; + + procedure Append (Vstr : in out Vstring; C : Character) + is + begin + Grow (Vstr, 1); + Vstr.Str (Vstr.Len) := C; + end Append; + + procedure Append (Vstr : in out Vstring; Str : String) + is + S : constant Natural := Vstr.Len; + begin + Grow (Vstr, Str'Length); + Vstr.Str (S + 1 .. S + Str'Length) := Str; + end Append; + + procedure Append (Vstr : in out Vstring; Str : Ghdl_C_String) + is + S : constant Natural := Vstr.Len; + L : constant Natural := strlen (Str); + begin + Grow (Vstr, L); + Vstr.Str (S + 1 .. S + L) := Str (1 .. L); + end Append; + + function Length (Vstr : Vstring) return Natural is + begin + return Vstr.Len; + end Length; + + procedure Truncate (Vstr : in out Vstring; Len : Natural) is + begin + if Len > Vstr.Len then + Internal_Error ("grt.vstrings.truncate: bad len"); + end if; + Vstr.Len := Len; + end Truncate; + + procedure Put (Stream : FILEs; Vstr : Vstring) + is + S : size_t; + begin + S := size_t (Vstr.Len); + if S > 0 then + S := fwrite (Vstr.Str (1)'Address, S, 1, Stream); + end if; + end Put; + + procedure Free (Rstr : in out Rstring) is + begin + Free (Rstr.Str); + Rstr := (Str => null, + Max => 0, + First => 0); + end Free; + + function Length (Rstr : Rstring) return Natural is + begin + return Rstr.Max + 1 - Rstr.First; + end Length; + + procedure Grow (Rstr : in out Rstring; Min : Natural) + is + Len : constant Natural := Length (Rstr); + Nlen : constant Natural := Len + Min; + Nstr : Fat_String_Acc; + Nfirst : Natural; + Nmax : Natural; + begin + if Nlen <= Rstr.Max then + return; + end if; + if Rstr.Max = 0 then + Nmax := 32; + else + Nmax := Rstr.Max; + end if; + while Nmax < Nlen loop + Nmax := Nmax * 2; + end loop; + Nstr := Malloc (Nmax); + Nfirst := Nmax + 1 - Len; + if Rstr.Str /= null then + Nstr (Nfirst .. Nmax) := Rstr.Str (Rstr.First .. Rstr.Max); + Free (Rstr.Str); + end if; + Rstr := (Str => Nstr, + Max => Nmax, + First => Nfirst); + end Grow; + + procedure Prepend (Rstr : in out Rstring; C : Character) + is + begin + Grow (Rstr, 1); + Rstr.First := Rstr.First - 1; + Rstr.Str (Rstr.First) := C; + end Prepend; + + procedure Prepend (Rstr : in out Rstring; Str : String) + is + begin + Grow (Rstr, Str'Length); + Rstr.First := Rstr.First - Str'Length; + Rstr.Str (Rstr.First .. Rstr.First + Str'Length - 1) := Str; + end Prepend; + + procedure Prepend (Rstr : in out Rstring; Str : Ghdl_C_String) + is + L : constant Natural := strlen (Str); + begin + Grow (Rstr, L); + Rstr.First := Rstr.First - L; + Rstr.Str (Rstr.First .. Rstr.First + L - 1) := Str (1 .. L); + end Prepend; + + function Get_Address (Rstr : Rstring) return Address + is + begin + return Rstr.Str (Rstr.First)'Address; + end Get_Address; + + procedure Copy (Rstr : Rstring; Str : in out String; Len : out Natural) + is + begin + Len := Length (Rstr); + if Len > Str'Length then + Str := Rstr.Str (Rstr.First .. Rstr.First + Str'Length - 1); + else + Str (Str'First .. Str'First + Len - 1) := + Rstr.Str (Rstr.First .. Rstr.First + Len - 1); + end if; + end Copy; + + procedure Put (Stream : FILEs; Rstr : Rstring) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Get_Address (Rstr), size_t (Length (Rstr)), 1, Stream); + end Put; + + generic + type Ntype is range <>; + --Max_Len : Natural; + procedure Gen_To_String (Str : out String; First : out Natural; N : Ntype); + + procedure Gen_To_String (Str : out String; First : out Natural; N : Ntype) + is + subtype R_Type is String (1 .. Str'Length); + S : R_Type renames Str; + P : Natural := S'Last; + V : Ntype; + begin + if N > 0 then + V := -N; + else + V := N; + end if; + loop + S (P) := Character'Val (48 - (V rem 10)); + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + if N < 0 then + P := P - 1; + S (P) := '-'; + end if; + First := P; + end Gen_To_String; + + procedure To_String_I32 is new Gen_To_String (Ntype => Ghdl_I32); + + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I32) + renames To_String_I32; + + procedure To_String_I64 is new Gen_To_String (Ntype => Ghdl_I64); + + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I64) + renames To_String_I64; + + procedure To_String (Str : out String; Last : out Natural; N : Ghdl_F64) + is + function Trunc (V : Ghdl_F64) return Ghdl_F64; + pragma Import (C, Trunc); + + P : Natural := Str'First; + V : Ghdl_F64; + Vmax : Ghdl_F64; + Vd : Ghdl_F64; + Exp : Integer; + D : Integer; + B : Boolean; + begin + -- Handle sign. + if N < 0.0 then + Str (P) := '-'; + P := P + 1; + V := -N; + else + V := N; + end if; + + -- Compute the mantissa. + -- and normalize V in [0 .. 10.0[ + -- FIXME: should do a dichotomy. + if V = 0.0 then + Exp := 0; + elsif V < 1.0 then + Exp := 0; + loop + exit when V >= 1.0; + Exp := Exp - 1; + V := V * 10.0; + end loop; + else + Exp := 0; + loop + exit when V < 10.0; + Exp := Exp + 1; + V := V / 10.0; + end loop; + end if; + + Vmax := 10.0 ** (1 - 15); + for I in 0 .. 15 loop + -- Vd := Ghdl_F64'Truncation (V); + Vd := Trunc (V); + Str (P) := Character'Val (48 + Integer (Vd)); + P := P + 1; + V := (V - Vd) * 10.0; + + if I = 0 then + Str (P) := '.'; + P := P + 1; + end if; + exit when I > 0 and V < Vmax; + Vmax := Vmax * 10.0; + end loop; + + if Exp /= 0 then + -- LRM93 14.3 + -- if the exponent is present, the `e' is written as a lower case + -- character. + Str (P) := 'e'; + P := P + 1; + + if Exp < 0 then + Str (P) := '-'; + P := P + 1; + Exp := -Exp; + end if; + B := False; + for I in 0 .. 4 loop + D := (Exp / 10000) mod 10; + if D /= 0 or B or I = 4 then + Str (P) := Character'Val (48 + D); + P := P + 1; + B := True; + end if; + Exp := (Exp - D * 10000) * 10; + end loop; + end if; + + Last := P - 1; + end To_String; + + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Nbr_Digits : Ghdl_I32) + is + procedure Snprintf_Nf (Str : in out String; + Len : Natural; + Ndigits : Ghdl_I32; + V : Ghdl_F64); + pragma Import (C, Snprintf_Nf, "__ghdl_snprintf_nf"); + begin + Snprintf_Nf (Str, Str'Length, Nbr_Digits, N); + Last := strlen (To_Ghdl_C_String (Str'Address)); + end To_String; + + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Format : Ghdl_C_String) + is + procedure Snprintf_Fmtf (Str : in out String; + Len : Natural; + Format : Ghdl_C_String; + V : Ghdl_F64); + pragma Import (C, Snprintf_Fmtf, "__ghdl_snprintf_fmtf"); + begin + -- FIXME: check format ('%', f/g/e/a) + Snprintf_Fmtf (Str, Str'Length, Format, N); + Last := strlen (To_Ghdl_C_String (Str'Address)); + end To_String; + + procedure To_String (Str : out String_Time_Unit; + First : out Natural; + Value : Ghdl_I64; + Unit : Ghdl_I64) + is + V, U : Ghdl_I64; + D : Natural; + P : Natural := Str'Last; + Has_Digits : Boolean; + begin + -- Always work on negative values. + if Value > 0 then + V := -Value; + else + V := Value; + end if; + + Has_Digits := False; + U := Unit; + loop + if U = 1 then + if Has_Digits then + Str (P) := '.'; + P := P - 1; + else + Has_Digits := True; + end if; + end if; + + D := Natural (-(V rem 10)); + if D /= 0 or else Has_Digits then + Str (P) := Character'Val (48 + D); + P := P - 1; + Has_Digits := True; + end if; + U := U / 10; + V := V / 10; + exit when V = 0 and then U = 0; + end loop; + if not Has_Digits then + Str (P) := '0'; + else + P := P + 1; + end if; + if Value < 0 then + P := P - 1; + Str (P) := '-'; + end if; + First := P; + end To_String; +end Grt.Vstrings; diff --git a/src/grt/grt-vstrings.ads b/src/grt/grt-vstrings.ads new file mode 100644 index 000000000..94967bb0f --- /dev/null +++ b/src/grt/grt-vstrings.ads @@ -0,0 +1,143 @@ +-- GHDL Run Time (GRT) - variable strings. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Grt.Stdio; use Grt.Stdio; +with Grt.Types; use Grt.Types; +with System; use System; + +package Grt.Vstrings is + -- A Vstring (Variable string) is an object which contains an unbounded + -- string. + type Vstring is limited private; + + -- Deallocate all storage internally allocated. + procedure Free (Vstr : in out Vstring); + + -- Append a character. + procedure Append (Vstr : in out Vstring; C : Character); + + -- Append a string. + procedure Append (Vstr : in out Vstring; Str : String); + + -- Append a C string. + procedure Append (Vstr : in out Vstring; Str : Ghdl_C_String); + + -- Get length of VSTR. + function Length (Vstr : Vstring) return Natural; + + -- Truncate VSTR to LEN. + -- It is an error if LEN is greater than the current length. + procedure Truncate (Vstr : in out Vstring; Len : Natural); + + -- Display VSTR. + procedure Put (Stream : FILEs; Vstr : Vstring); + + + -- A Rstring is link a Vstring but characters can only be prepended. + type Rstring is limited private; + + -- Deallocate storage associated with Rstr. + procedure Free (Rstr : in out Rstring); + + -- Prepend characters or strings. + procedure Prepend (Rstr : in out Rstring; C : Character); + procedure Prepend (Rstr : in out Rstring; Str : String); + procedure Prepend (Rstr : in out Rstring; Str : Ghdl_C_String); + + -- Get the length of RSTR. + function Length (Rstr : Rstring) return Natural; + + -- Return the address of the first character of RSTR. + function Get_Address (Rstr : Rstring) return Address; + + -- Display RSTR. + procedure Put (Stream : FILEs; Rstr : Rstring); + + -- Copy RSTR to STR, and return length of the string to LEN. + procedure Copy (Rstr : Rstring; Str : in out String; Len : out Natural); + + -- Write the image of N into STR padded to the right. FIRST is the index + -- of the first character, so the result is in STR (FIRST .. STR'last). + -- Requires at least 11 characters. + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I32); + + -- Write the image of N into STR padded to the right. FIRST is the index + -- of the first character, so the result is in STR (FIRST .. STR'last). + -- Requires at least 21 characters. + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I64); + + -- Write the image of N into STR. LAST is the index of the last character, + -- so the result is in STR (STR'first .. LAST). + -- Requires at least 24 characters. + -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1) + -- + exp_digits (4) -> 24. + procedure To_String (Str : out String; Last : out Natural; N : Ghdl_F64); + + subtype String_Real_Digits is String (1 .. 128); + + -- Write the image of N into STR using NBR_DIGITS digits after the decimal + -- point. + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Nbr_Digits : Ghdl_I32); + + subtype String_Real_Format is String (1 .. 128); + + -- Write the image of N into STR using NBR_DIGITS digits after the decimal + -- point. + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Format : Ghdl_C_String); + + -- Write the image of VALUE to STR using UNIT as unit. The output is in + -- STR (FIRST .. STR'last). + subtype String_Time_Unit is String (1 .. 22); + procedure To_String (Str : out String_Time_Unit; + First : out Natural; + Value : Ghdl_I64; + Unit : Ghdl_I64); + +private + subtype Fat_String is String (Positive); + type Fat_String_Acc is access Fat_String; + + type Vstring is record + Str : Fat_String_Acc := null; + Max : Natural := 0; + Len : Natural := 0; + end record; + + type Rstring is record + -- String whose bounds is (1 .. Max). + Str : Fat_String_Acc := null; + + -- Last index in STR. + Max : Natural := 0; + + -- Index of the first character. + First : Natural := 1; + end record; +end Grt.Vstrings; diff --git a/src/grt/grt-waves.adb b/src/grt/grt-waves.adb new file mode 100644 index 000000000..63bdb9a54 --- /dev/null +++ b/src/grt/grt-waves.adb @@ -0,0 +1,1632 @@ +-- GHDL Run Time (GRT) - wave dumper (GHW) module. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Interfaces; use Interfaces; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Types; use Grt.Types; +with Grt.Avhpi; use Grt.Avhpi; +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Errors; use Grt.Errors; +with Grt.Astdio; use Grt.Astdio; +with Grt.Hooks; use Grt.Hooks; +with Grt.Table; +with Grt.Avls; use Grt.Avls; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Utils; +with Grt.Rtis_Types; +with Grt.Signals; use Grt.Signals; +with System; use System; +with Grt.Vstrings; use Grt.Vstrings; + +pragma Elaborate_All (Grt.Rtis_Utils); +pragma Elaborate_All (Grt.Table); + +package body Grt.Waves is + -- Waves filename. + Wave_Filename : String_Access := null; + -- Stream corresponding to the GHW filename. + Wave_Stream : FILEs; + + Ghw_Hie_Design : constant Unsigned_8 := 1; + Ghw_Hie_Block : constant Unsigned_8 := 3; + Ghw_Hie_Generate_If : constant Unsigned_8 := 4; + Ghw_Hie_Generate_For : constant Unsigned_8 := 5; + Ghw_Hie_Instance : constant Unsigned_8 := 6; + Ghw_Hie_Package : constant Unsigned_8 := 7; + Ghw_Hie_Process : constant Unsigned_8 := 13; + Ghw_Hie_Generic : constant Unsigned_8 := 14; + Ghw_Hie_Eos : constant Unsigned_8 := 15; -- End of scope. + Ghw_Hie_Signal : constant Unsigned_8 := 16; -- Signal. + Ghw_Hie_Port_In : constant Unsigned_8 := 17; -- Port + Ghw_Hie_Port_Out : constant Unsigned_8 := 18; -- Port + Ghw_Hie_Port_Inout : constant Unsigned_8 := 19; -- Port + Ghw_Hie_Port_Buffer : constant Unsigned_8 := 20; -- Port + Ghw_Hie_Port_Linkage : constant Unsigned_8 := 21; -- Port + + pragma Unreferenced (Ghw_Hie_Design); + pragma Unreferenced (Ghw_Hie_Generic); + + -- Return TRUE if OPT is an option for wave. + function Wave_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + begin + if Opt'Length < 6 or else Opt (F .. F + 5) /= "--wave" then + return False; + end if; + if Opt'Length > 6 and then Opt (F + 6) = '=' then + -- Add an extra NUL character. + Wave_Filename := new String (1 .. Opt'Length - 7 + 1); + Wave_Filename (1 .. Opt'Length - 7) := Opt (F + 7 .. Opt'Last); + Wave_Filename (Wave_Filename'Last) := NUL; + return True; + else + return False; + end if; + end Wave_Option; + + procedure Wave_Help is + begin + Put_Line (" --wave=FILENAME dump signal values into a wave file"); + end Wave_Help; + + procedure Wave_Put (Str : String) + is + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (Str'Address, Str'Length, 1, Wave_Stream); + end Wave_Put; + + procedure Wave_Putc (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), Wave_Stream); + end Wave_Putc; + + procedure Wave_Newline is + begin + Wave_Putc (Nl); + end Wave_Newline; + + procedure Wave_Put_Byte (B : Unsigned_8) + is + V : Unsigned_8 := B; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, 1, 1, Wave_Stream); + end Wave_Put_Byte; + + procedure Wave_Put_ULEB128 (Val : Ghdl_E32) + is + V : Ghdl_E32; + R : Ghdl_E32; + begin + V := Val; + loop + R := V mod 128; + V := V / 128; + if V = 0 then + Wave_Put_Byte (Unsigned_8 (R)); + exit; + else + Wave_Put_Byte (Unsigned_8 (128 + R)); + end if; + end loop; + end Wave_Put_ULEB128; + + procedure Wave_Put_SLEB128 (Val : Ghdl_I32) + is + function To_Ghdl_U32 is new Ada.Unchecked_Conversion + (Ghdl_I32, Ghdl_U32); + V : Ghdl_U32 := To_Ghdl_U32 (Val); + +-- function Shift_Right_Arithmetic (Value : Ghdl_U32; Amount : Natural) +-- return Ghdl_U32; +-- pragma Import (Intrinsic, Shift_Right_Arithmetic); + R : Unsigned_8; + begin + loop + R := Unsigned_8 (V mod 128); + V := Shift_Right_Arithmetic (V, 7); + if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0) + then + Wave_Put_Byte (R); + exit; + else + Wave_Put_Byte (R or 16#80#); + end if; + end loop; + end Wave_Put_SLEB128; + + procedure Wave_Put_LSLEB128 (Val : Ghdl_I64) + is + function To_Ghdl_U64 is new Ada.Unchecked_Conversion + (Ghdl_I64, Ghdl_U64); + V : Ghdl_U64 := To_Ghdl_U64 (Val); + + R : Unsigned_8; + begin + loop + R := Unsigned_8 (V mod 128); + V := Shift_Right_Arithmetic (V, 7); + if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0) + then + Wave_Put_Byte (R); + exit; + else + Wave_Put_Byte (R or 16#80#); + end if; + end loop; + end Wave_Put_LSLEB128; + + procedure Wave_Put_I32 (Val : Ghdl_I32) + is + V : Ghdl_I32 := Val; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, 4, 1, Wave_Stream); + end Wave_Put_I32; + + procedure Wave_Put_I64 (Val : Ghdl_I64) + is + V : Ghdl_I64 := Val; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, 8, 1, Wave_Stream); + end Wave_Put_I64; + + procedure Wave_Put_F64 (F64 : Ghdl_F64) + is + V : Ghdl_F64 := F64; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, Ghdl_F64'Size / Storage_Unit, 1, Wave_Stream); + end Wave_Put_F64; + + procedure Wave_Puts (Str : Ghdl_C_String) is + begin + Put (Wave_Stream, Str); + end Wave_Puts; + + procedure Write_Value (Value : Value_Union; Mode : Mode_Type) is + begin + case Mode is + when Mode_B1 => + Wave_Put_Byte (Ghdl_B1'Pos (Value.B1)); + when Mode_E8 => + Wave_Put_Byte (Ghdl_E8'Pos (Value.E8)); + when Mode_E32 => + Wave_Put_ULEB128 (Value.E32); + when Mode_I32 => + Wave_Put_SLEB128 (Value.I32); + when Mode_I64 => + Wave_Put_LSLEB128 (Value.I64); + when Mode_F64 => + Wave_Put_F64 (Value.F64); + end case; + end Write_Value; + + subtype Section_Name is String (1 .. 4); + type Header_Type is record + Name : Section_Name; + Pos : long; + end record; + + package Section_Table is new Grt.Table + (Table_Component_Type => Header_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 16); + + -- Create a new section. + -- Write the header in the file. + -- Save the location for the directory. + procedure Wave_Section (Name : Section_Name) is + begin + Section_Table.Append (Header_Type'(Name => Name, + Pos => ftell (Wave_Stream))); + Wave_Put (Name); + end Wave_Section; + + procedure Wave_Write_Size_Order is + begin + -- Byte order, 1 byte. + -- 0: bad, 1 : little-endian, 2 : big endian. + declare + type Byte_Arr is array (0 .. 3) of Unsigned_8; + function To_Byte_Arr is new Ada.Unchecked_Conversion + (Source => Unsigned_32, Target => Byte_Arr); + B4 : constant Byte_Arr := To_Byte_Arr (16#11_22_33_44#); + V : Unsigned_8; + begin + if B4 (0) = 16#11# then + -- Big endian. + V := 2; + elsif B4 (0) = 16#44# then + -- Little endian. + V := 1; + else + -- Unknown endian. + V := 0; + end if; + Wave_Put_Byte (V); + end; + -- Word size, 1 byte. + Wave_Put_Byte (Integer'Size / 8); + -- File offset size, 1 byte + Wave_Put_Byte (1); + -- Unused, must be zero (MBZ). + Wave_Put_Byte (0); + end Wave_Write_Size_Order; + + procedure Wave_Write_Directory + is + Pos : long; + begin + Pos := ftell (Wave_Stream); + Wave_Section ("DIR" & NUL); + Wave_Write_Size_Order; + Wave_Put_I32 (Ghdl_I32 (Section_Table.Last)); + for I in Section_Table.First .. Section_Table.Last loop + Wave_Put (Section_Table.Table (I).Name); + Wave_Put_I32 (Ghdl_I32 (Section_Table.Table (I).Pos)); + end loop; + Wave_Put ("EOD" & NUL); + + Wave_Section ("TAI" & NUL); + Wave_Write_Size_Order; + Wave_Put_I32 (Ghdl_I32 (Pos)); + end Wave_Write_Directory; + + -- Called before elaboration. + procedure Wave_Init + is + Mode : constant String := "wb" & NUL; + begin + if Wave_Filename = null then + Wave_Stream := NULL_Stream; + return; + end if; + if Wave_Filename.all = "-" & NUL then + Wave_Stream := stdout; + else + Wave_Stream := fopen (Wave_Filename.all'Address, Mode'Address); + if Wave_Stream = NULL_Stream then + Error_C ("cannot open "); + Error_E (Wave_Filename (Wave_Filename'First + .. Wave_Filename'Last - 1)); + return; + end if; + end if; + end Wave_Init; + + procedure Write_File_Header + is + begin + -- Magic, 9 bytes. + Wave_Put ("GHDLwave" & Nl); + -- Header length. + Wave_Put_Byte (16); + -- Version-major, 1 byte. + Wave_Put_Byte (0); + -- Version-minor, 1 byte. + Wave_Put_Byte (1); + + Wave_Write_Size_Order; + end Write_File_Header; + + procedure Avhpi_Error (Err : AvhpiErrorT) + is + pragma Unreferenced (Err); + begin + Put_Line ("Waves.Avhpi_Error!"); + null; + end Avhpi_Error; + + package Str_Table is new Grt.Table + (Table_Component_Type => Ghdl_C_String, + Table_Index_Type => AVL_Value, + Table_Low_Bound => 1, + Table_Initial => 16); + + package Str_AVL is new Grt.Table + (Table_Component_Type => AVL_Node, + Table_Index_Type => AVL_Nid, + Table_Low_Bound => AVL_Root, + Table_Initial => 16); + + Strings_Len : Natural := 0; + + function Str_Compare (L, R : AVL_Value) return Integer + is + Ls, Rs : Ghdl_C_String; + begin + Ls := Str_Table.Table (L); + Rs := Str_Table.Table (R); + if L = R then + return 0; + end if; + return Strcmp (Ls, Rs); + end Str_Compare; + + procedure Disp_Str_Avl (N : AVL_Nid) is + begin + Put (stdout, "node: "); + Put_I32 (stdout, Ghdl_I32 (N)); + New_Line (stdout); + Put (stdout, " left: "); + Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Left)); + New_Line (stdout); + Put (stdout, " right: "); + Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Right)); + New_Line (stdout); + Put (stdout, " height: "); + Put_I32 (stdout, Str_AVL.Table (N).Height); + New_Line (stdout); + Put (stdout, " str: "); + --Put (stdout, Str_AVL.Table (N).Val); + New_Line (stdout); + end Disp_Str_Avl; + + pragma Unreferenced (Disp_Str_Avl); + + function Create_Str_Index (Str : Ghdl_C_String) return AVL_Value + is + Res : AVL_Nid; + begin + Str_Table.Append (Str); + Str_AVL.Append (AVL_Node'(Val => Str_Table.Last, + Left | Right => AVL_Nil, + Height => 1)); + Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)), + Str_Compare'Access, + Str_AVL.Last, Res); + if Res /= Str_AVL.Last then + Str_AVL.Decrement_Last; + Str_Table.Decrement_Last; + else + Strings_Len := Strings_Len + strlen (Str); + end if; + return Str_AVL.Table (Res).Val; + end Create_Str_Index; + + pragma Unreferenced (Create_Str_Index); + + procedure Create_String_Id (Str : Ghdl_C_String) + is + Res : AVL_Nid; + begin + if Str = null then + return; + end if; + Str_Table.Append (Str); + Str_AVL.Append (AVL_Node'(Val => Str_Table.Last, + Left | Right => AVL_Nil, + Height => 1)); + Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)), + Str_Compare'Access, + Str_AVL.Last, Res); + if Res /= Str_AVL.Last then + Str_AVL.Decrement_Last; + Str_Table.Decrement_Last; + else + Strings_Len := Strings_Len + strlen (Str); + end if; + end Create_String_Id; + + function Get_String (Str : Ghdl_C_String) return AVL_Value + is + H, L, M : AVL_Value; + Diff : Integer; + begin + L := Str_Table.First; + H := Str_Table.Last; + loop + M := (L + H) / 2; + Diff := Strcmp (Str, Str_Table.Table (M)); + if Diff = 0 then + return M; + elsif Diff < 0 then + H := M - 1; + else + L := M + 1; + end if; + exit when L > H; + end loop; + return 0; + end Get_String; + + procedure Write_String_Id (Str : Ghdl_C_String) is + begin + if Str = null then + Wave_Put_Byte (0); + else + Wave_Put_ULEB128 (Ghdl_E32 (Get_String (Str))); + end if; + end Write_String_Id; + + type Type_Node is record + Type_Rti : Ghdl_Rti_Access; + Context : Rti_Context; + end record; + + package Types_Table is new Grt.Table + (Table_Component_Type => Type_Node, + Table_Index_Type => AVL_Value, + Table_Low_Bound => 1, + Table_Initial => 16); + + package Types_AVL is new Grt.Table + (Table_Component_Type => AVL_Node, + Table_Index_Type => AVL_Nid, + Table_Low_Bound => AVL_Root, + Table_Initial => 16); + + function Type_Compare (L, R : AVL_Value) return Integer + is + function To_Ia is new + Ada.Unchecked_Conversion (Ghdl_Rti_Access, Integer_Address); + + function "<" (L, R : Ghdl_Rti_Access) return Boolean is + begin + return To_Ia (L) < To_Ia (R); + end "<"; + + Ls : Type_Node renames Types_Table.Table (L); + Rs : Type_Node renames Types_Table.Table (R); + begin + if Ls.Type_Rti /= Rs.Type_Rti then + if Ls.Type_Rti < Rs.Type_Rti then + return -1; + else + return 1; + end if; + end if; + if Ls.Context.Block /= Rs.Context.Block then + if Ls.Context.Block < Rs.Context.Block then + return -1; + else + return +1; + end if; + end if; + if Ls.Context.Base /= Rs.Context.Base then + if Ls.Context.Base < Rs.Context.Base then + return -1; + else + return +1; + end if; + end if; + return 0; + end Type_Compare; + + -- Try to find type (RTI, CTXT) in the types_AVL table. + -- The first step is to canonicalize CTXT, so that it is the CTXT of + -- the type (and not a sub-scope of it). + procedure Find_Type (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + N_Ctxt : out Rti_Context; + Id : out AVL_Nid) + is + Depth : Ghdl_Rti_Depth; + begin + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 => + N_Ctxt := Null_Context; + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal => + N_Ctxt := Ctxt; + when others => + -- Compute the canonical context. + if Rti.Max_Depth < Rti.Depth then + Internal_Error ("grt.waves.find_type"); + end if; + Depth := Rti.Max_Depth; + if Depth = 0 or else Ctxt.Block = null then + N_Ctxt := Null_Context; + else + N_Ctxt := Ctxt; + while N_Ctxt.Block.Depth > Depth loop + N_Ctxt := Get_Parent_Context (N_Ctxt); + end loop; + end if; + end case; + + -- If the type is already known, return now. + -- Otherwise, ID is set to AVL_Nil. + Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => N_Ctxt)); + Id := Find_Node + (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)), + Type_Compare'Access, + Types_Table.Last); + Types_Table.Decrement_Last; + end Find_Type; + + procedure Write_Type_Id (Tid : AVL_Nid) is + begin + Wave_Put_ULEB128 (Ghdl_E32 (Types_AVL.Table (Tid).Val)); + end Write_Type_Id; + + procedure Write_Type_Id (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + N_Ctxt : Rti_Context; + Res : AVL_Nid; + begin + Find_Type (Rti, Ctxt, N_Ctxt, Res); + if Res = AVL_Nil then + -- raise Program_Error; + Internal_Error ("write_type_id"); + end if; + Write_Type_Id (Res); + end Write_Type_Id; + + procedure Add_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + Res : AVL_Nid; + begin + -- Then, create the type. + Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => Ctxt)); + Types_AVL.Append (AVL_Node'(Val => Types_Table.Last, + Left | Right => AVL_Nil, + Height => 1)); + + Get_Node + (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)), + Type_Compare'Access, + Types_AVL.Last, Res); + if Res /= Types_AVL.Last then + --raise Program_Error; + Internal_Error ("wave.create_type(2)"); + end if; + end Add_Type; + + procedure Create_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + N_Ctxt : Rti_Context; + Res : AVL_Nid; + begin + Find_Type (Rti, Ctxt, N_Ctxt, Res); + if Res /= AVL_Nil then + return; + end if; + + -- First, create all the types it depends on. + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 => + declare + Enum : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Create_String_Id (Enum.Name); + for I in 1 .. Enum.Nbr loop + Create_String_Id (Enum.Names (I - 1)); + end loop; + end; + when Ghdl_Rtik_Subtype_Array => + declare + Arr : Ghdl_Rtin_Subtype_Array_Acc; + B_Ctxt : Rti_Context; + begin + Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Create_String_Id (Arr.Name); + if Rti_Complex_Type (Rti) then + B_Ctxt := Ctxt; + else + B_Ctxt := N_Ctxt; + end if; + Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), B_Ctxt); + end; + when Ghdl_Rtik_Type_Array => + declare + Arr : Ghdl_Rtin_Type_Array_Acc; + begin + Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti); + Create_String_Id (Arr.Name); + Create_Type (Arr.Element, N_Ctxt); + for I in 1 .. Arr.Nbr_Dim loop + Create_Type (Arr.Indexes (I - 1), N_Ctxt); + end loop; + end; + when Ghdl_Rtik_Subtype_Scalar => + declare + Sub : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); + Create_String_Id (Sub.Name); + Create_Type (Sub.Basetype, N_Ctxt); + end; + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 + | Ghdl_Rtik_Type_F64 => + declare + Base : Ghdl_Rtin_Type_Scalar_Acc; + begin + Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti); + Create_String_Id (Base.Name); + end; + when Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 => + declare + Base : Ghdl_Rtin_Type_Physical_Acc; + Unit_Name : Ghdl_C_String; + begin + Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Create_String_Id (Base.Name); + for I in 1 .. Base.Nbr loop + Unit_Name := + Rtis_Utils.Get_Physical_Unit_Name (Base.Units (I - 1)); + Create_String_Id (Unit_Name); + end loop; + end; + when Ghdl_Rtik_Type_Record => + declare + Rec : Ghdl_Rtin_Type_Record_Acc; + El : Ghdl_Rtin_Element_Acc; + begin + Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti); + Create_String_Id (Rec.Name); + for I in 1 .. Rec.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); + Create_String_Id (El.Name); + Create_Type (El.Eltype, N_Ctxt); + end loop; + end; + when others => + Internal_Error ("wave.create_type"); +-- Internal_Error ("wave.create_type: does not handle " & +-- Ghdl_Rtik'Image (Rti.Kind)); + end case; + + -- Then, create the type. + Add_Type (Rti, N_Ctxt); + end Create_Type; + + procedure Create_Object_Type (Obj : VhpiHandleT) + is + Obj_Type : VhpiHandleT; + Error : AvhpiErrorT; + Rti : Ghdl_Rti_Access; + begin + -- Extract type of the signal. + Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Rti := Avhpi_Get_Rti (Obj_Type); + Create_Type (Rti, Avhpi_Get_Context (Obj_Type)); + + -- The the signal type is an unconstrained array, also put the object + -- in the type AVL. + -- The real type will be written to the file. + if Rti.Kind = Ghdl_Rtik_Type_Array then + Add_Type (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj)); + end if; + end Create_Object_Type; + + procedure Write_Object_Type (Obj : VhpiHandleT) + is + Obj_Type : VhpiHandleT; + Error : AvhpiErrorT; + Rti : Ghdl_Rti_Access; + begin + -- Extract type of the signal. + Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Rti := Avhpi_Get_Rti (Obj_Type); + if Rti.Kind = Ghdl_Rtik_Type_Array then + Write_Type_Id (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj)); + else + Write_Type_Id (Rti, Avhpi_Get_Context (Obj_Type)); + end if; + end Write_Object_Type; + + procedure Create_Generate_Type (Gen : VhpiHandleT) + is + Iterator : VhpiHandleT; + Error : AvhpiErrorT; + begin + -- Extract the iterator. + Vhpi_Handle (VhpiIterScheme, Gen, Iterator, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Create_Object_Type (Iterator); + end Create_Generate_Type; + + procedure Write_Generate_Type_And_Value (Gen : VhpiHandleT) + is + Iter : VhpiHandleT; + Iter_Type : VhpiHandleT; + Error : AvhpiErrorT; + Addr : Address; + Mode : Mode_Type; + Rti : Ghdl_Rti_Access; + begin + -- Extract the iterator. + Vhpi_Handle (VhpiIterScheme, Gen, Iter, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Write_Object_Type (Iter); + + Vhpi_Handle (VhpiSubtype, Iter, Iter_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Rti := Avhpi_Get_Rti (Iter_Type); + Addr := Avhpi_Get_Address (Iter); + + case Get_Base_Type (Rti).Kind is + when Ghdl_Rtik_Type_B1 => + Mode := Mode_B1; + when Ghdl_Rtik_Type_E8 => + Mode := Mode_E8; + when Ghdl_Rtik_Type_E32 => + Mode := Mode_E32; + when Ghdl_Rtik_Type_I32 => + Mode := Mode_I32; + when Ghdl_Rtik_Type_I64 => + Mode := Mode_I64; + when Ghdl_Rtik_Type_F64 => + Mode := Mode_F64; + when others => + Internal_Error ("bad iterator type"); + end case; + Write_Value (To_Ghdl_Value_Ptr (Addr).all, Mode); + end Write_Generate_Type_And_Value; + + type Step_Type is (Step_Name, Step_Hierarchy); + + Nbr_Scopes : Natural := 0; + Nbr_Scope_Signals : Natural := 0; + Nbr_Dumped_Signals : Natural := 0; + + -- This is only valid during write_hierarchy. + function Get_Signal_Number (Sig : Ghdl_Signal_Ptr) return Natural + is + function To_Integer_Address is new Ada.Unchecked_Conversion + (Ghdl_Signal_Ptr, Integer_Address); + begin + return Natural (To_Integer_Address (Sig.Alink)); + end Get_Signal_Number; + + procedure Write_Signal_Number (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param_Type : Natural) + is + pragma Unreferenced (Val_Name); + pragma Unreferenced (Val_Type); + pragma Unreferenced (Param_Type); + + Num : Natural; + + function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion + (Source => Integer_Address, Target => Ghdl_Signal_Ptr); + Sig : Ghdl_Signal_Ptr; + begin + -- Convert to signal. + Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); + + -- Get signal number. + Num := Get_Signal_Number (Sig); + + -- If the signal number is 0, then assign a valid signal number. + if Num = 0 then + Nbr_Dumped_Signals := Nbr_Dumped_Signals + 1; + Sig.Alink := To_Ghdl_Signal_Ptr + (Integer_Address (Nbr_Dumped_Signals)); + Num := Nbr_Dumped_Signals; + end if; + + -- Do the real job: write the signal number. + Wave_Put_ULEB128 (Ghdl_E32 (Num)); + end Write_Signal_Number; + + procedure Foreach_Scalar_Signal_Number is new + Grt.Rtis_Utils.Foreach_Scalar (Param_Type => Natural, + Process => Write_Signal_Number); + + procedure Write_Signal_Numbers (Decl : VhpiHandleT) + is + Ctxt : Rti_Context; + Sig : Ghdl_Rtin_Object_Acc; + begin + Ctxt := Avhpi_Get_Context (Decl); + Sig := To_Ghdl_Rtin_Object_Acc (Avhpi_Get_Rti (Decl)); + Foreach_Scalar_Signal_Number + (Ctxt, Sig.Obj_Type, + Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, 0); + end Write_Signal_Numbers; + + procedure Write_Hierarchy_El (Decl : VhpiHandleT) + is + Mode2hie : constant array (VhpiModeT) of Unsigned_8 := + (VhpiErrorMode => Ghw_Hie_Signal, + VhpiInMode => Ghw_Hie_Port_In, + VhpiOutMode => Ghw_Hie_Port_Out, + VhpiInoutMode => Ghw_Hie_Port_Inout, + VhpiBufferMode => Ghw_Hie_Port_Buffer, + VhpiLinkageMode => Ghw_Hie_Port_Linkage); + V : Unsigned_8; + begin + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK => + V := Mode2hie (Vhpi_Get_Mode (Decl)); + when VhpiSigDeclK => + V := Ghw_Hie_Signal; + when VhpiForGenerateK => + V := Ghw_Hie_Generate_For; + when VhpiIfGenerateK => + V := Ghw_Hie_Generate_If; + when VhpiBlockStmtK => + V := Ghw_Hie_Block; + when VhpiCompInstStmtK => + V := Ghw_Hie_Instance; + when VhpiProcessStmtK => + V := Ghw_Hie_Process; + when VhpiPackInstK => + V := Ghw_Hie_Package; + when VhpiRootInstK => + V := Ghw_Hie_Instance; + when others => + --raise Program_Error; + Internal_Error ("write_hierarchy_el"); + end case; + Wave_Put_Byte (V); + Write_String_Id (Avhpi_Get_Base_Name (Decl)); + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK + | VhpiSigDeclK => + Write_Object_Type (Decl); + Write_Signal_Numbers (Decl); + when VhpiForGenerateK => + Write_Generate_Type_And_Value (Decl); + when others => + null; + end case; + end Write_Hierarchy_El; + + -- Create a hierarchy block. + procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type); + + procedure Wave_Put_Hierarchy_1 (Inst : VhpiHandleT; Step : Step_Type) + is + Decl_It : VhpiHandleT; + Decl : VhpiHandleT; + Error : AvhpiErrorT; + begin + Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + -- Extract signals. + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK + | VhpiSigDeclK => + case Step is + when Step_Name => + Create_String_Id (Avhpi_Get_Base_Name (Decl)); + Nbr_Scope_Signals := Nbr_Scope_Signals + 1; + Create_Object_Type (Decl); + when Step_Hierarchy => + Write_Hierarchy_El (Decl); + end case; + --Wave_Put_Name (Decl); + --Wave_Newline; + when others => + null; + end case; + end loop; + + -- No sub-scopes for packages. + if Vhpi_Get_Kind (Inst) = VhpiPackInstK then + return; + end if; + + -- Extract sub-scopes. + Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Nbr_Scopes := Nbr_Scopes + 1; + + case Vhpi_Get_Kind (Decl) is + when VhpiIfGenerateK + | VhpiForGenerateK + | VhpiBlockStmtK + | VhpiCompInstStmtK => + Wave_Put_Hierarchy_Block (Decl, Step); + when VhpiProcessStmtK => + case Step is + when Step_Name => + Create_String_Id (Avhpi_Get_Base_Name (Decl)); + when Step_Hierarchy => + Write_Hierarchy_El (Decl); + end case; + when others => + Internal_Error ("wave_put_hierarchy_1"); +-- Wave_Put ("unknown "); +-- Wave_Put (VhpiClassKindT'Image (Vhpi_Get_Kind (Decl))); +-- Wave_Newline; + end case; + end loop; + end Wave_Put_Hierarchy_1; + + procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type) + is + begin + case Step is + when Step_Name => + Create_String_Id (Avhpi_Get_Base_Name (Inst)); + if Vhpi_Get_Kind (Inst) = VhpiForGenerateK then + Create_Generate_Type (Inst); + end if; + when Step_Hierarchy => + Write_Hierarchy_El (Inst); + end case; + + Wave_Put_Hierarchy_1 (Inst, Step); + + if Step = Step_Hierarchy then + Wave_Put_Byte (Ghw_Hie_Eos); + end if; + end Wave_Put_Hierarchy_Block; + + procedure Wave_Put_Hierarchy (Root : VhpiHandleT; Step : Step_Type) + is + Pack_It : VhpiHandleT; + Pack : VhpiHandleT; + Error : AvhpiErrorT; + begin + -- First packages. + Get_Package_Inst (Pack_It); + loop + Vhpi_Scan (Pack_It, Pack, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Wave_Put_Hierarchy_Block (Pack, Step); + end loop; + + -- Then top entity. + Wave_Put_Hierarchy_Block (Root, Step); + end Wave_Put_Hierarchy; + + procedure Disp_Str_AVL (Str : AVL_Nid; Indent : Natural) + is + begin + if Str = AVL_Nil then + return; + end if; + Disp_Str_AVL (Str_AVL.Table (Str).Left, Indent + 1); + for I in 1 .. Indent loop + Wave_Putc (' '); + end loop; + Wave_Puts (Str_Table.Table (Str_AVL.Table (Str).Val)); +-- Wave_Putc ('('); +-- Put_I32 (Wave_Stream, Ghdl_I32 (Str)); +-- Wave_Putc (')'); +-- Put_I32 (Wave_Stream, Get_Height (Str)); + Wave_Newline; + Disp_Str_AVL (Str_AVL.Table (Str).Right, Indent + 1); + end Disp_Str_AVL; + + procedure Write_Strings + is + begin +-- Wave_Put ("AVL height: "); +-- Put_I32 (Wave_Stream, Ghdl_I32 (Check_AVL (Str_Root))); +-- Wave_Newline; + Wave_Put ("strings length: "); + Put_I32 (Wave_Stream, Ghdl_I32 (Strings_Len)); + Wave_Newline; + Disp_Str_AVL (AVL_Root, 0); + fflush (Wave_Stream); + end Write_Strings; + + pragma Unreferenced (Write_Strings); + + procedure Freeze_Strings + is + type Str_Table1_Type is array (1 .. Str_Table.Last) of Ghdl_C_String; + type Str_Table1_Acc is access Str_Table1_Type; + Idx : AVL_Value; + Table1 : Str_Table1_Acc; + + procedure Free is new Ada.Unchecked_Deallocation + (Str_Table1_Type, Str_Table1_Acc); + + procedure Store_Strings (N : AVL_Nid) is + begin + if N = AVL_Nil then + return; + end if; + Store_Strings (Str_AVL.Table (N).Left); + Table1 (Idx) := Str_Table.Table (Str_AVL.Table (N).Val); + Idx := Idx + 1; + Store_Strings (Str_AVL.Table (N).Right); + end Store_Strings; + begin + Table1 := new Str_Table1_Type; + Idx := 1; + Store_Strings (AVL_Root); + Str_Table.Release; + Str_AVL.Free; + for I in Table1.all'Range loop + Str_Table.Table (I) := Table1 (I); + end loop; + Free (Table1); + end Freeze_Strings; + + procedure Write_Strings_Compress + is + Last : Ghdl_C_String; + V : Ghdl_C_String; + L : Natural; + L1 : Natural; + begin + Wave_Section ("STR" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I32 (Ghdl_I32 (Str_Table.Last)); + Wave_Put_I32 (Ghdl_I32 (Strings_Len)); + for I in Str_Table.First .. Str_Table.Last loop + V := Str_Table.Table (I); + if I = Str_Table.First then + L := 1; + else + Last := Str_Table.Table (I - 1); + + for I in Positive loop + if V (I) /= Last (I) then + L := I; + exit; + end if; + end loop; + L1 := L - 1; + loop + if L1 >= 32 then + Wave_Put_Byte (Unsigned_8 (L1 mod 32) + 16#80#); + else + Wave_Put_Byte (Unsigned_8 (L1 mod 32)); + end if; + L1 := L1 / 32; + exit when L1 = 0; + end loop; + end if; + + if Boolean'(False) then + Put ("string "); + Put_I32 (stdout, Ghdl_I32 (I)); + Put (": "); + Put (V); + New_Line; + end if; + + loop + exit when V (L) = NUL; + Wave_Putc (V (L)); + L := L + 1; + end loop; + end loop; + -- Last string length. + Wave_Put_Byte (0); + -- End marker. + Wave_Put ("EOS" & NUL); + end Write_Strings_Compress; + + procedure Write_Range (Rti : Ghdl_Rti_Access; Rng : Ghdl_Range_Ptr) + is + Kind : Ghdl_Rtik; + begin + Kind := Rti.Kind; + if Kind = Ghdl_Rtik_Subtype_Scalar then + Kind := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype.Kind; + end if; + case Kind is + when Ghdl_Rtik_Type_B1 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.B1.Dir) * 16#80#); + Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Left)); + Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Right)); + when Ghdl_Rtik_Type_E8 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.E8.Dir) * 16#80#); + Wave_Put_Byte (Unsigned_8 (Rng.E8.Left)); + Wave_Put_Byte (Unsigned_8 (Rng.E8.Right)); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_P32 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.I32.Dir) * 16#80#); + Wave_Put_SLEB128 (Rng.I32.Left); + Wave_Put_SLEB128 (Rng.I32.Right); + when Ghdl_Rtik_Type_P64 + | Ghdl_Rtik_Type_I64 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.P64.Dir) * 16#80#); + Wave_Put_LSLEB128 (Rng.P64.Left); + Wave_Put_LSLEB128 (Rng.P64.Right); + when Ghdl_Rtik_Type_F64 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.F64.Dir) * 16#80#); + Wave_Put_F64 (Rng.F64.Left); + Wave_Put_F64 (Rng.F64.Right); + when others => + Internal_Error ("waves.write_range: unhandled kind"); + --Internal_Error ("waves.write_range: unhandled kind " + -- & Ghdl_Rtik'Image (Kind)); + end case; + end Write_Range; + + procedure Write_Types + is + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + begin + Wave_Section ("TYP" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I32 (Ghdl_I32 (Types_Table.Last)); + for I in Types_Table.First .. Types_Table.Last loop + Rti := Types_Table.Table (I).Type_Rti; + Ctxt := Types_Table.Table (I).Context; + + if Rti.Kind = Ghdl_Rtik_Signal or Rti.Kind = Ghdl_Rtik_Port then + declare + Obj_Rti : constant Ghdl_Rtin_Object_Acc := + To_Ghdl_Rtin_Object_Acc (Rti); + Arr : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type); + Addr : Ghdl_Uc_Array_Acc; + begin + Wave_Put_Byte (Ghdl_Rtik'Pos (Ghdl_Rtik_Subtype_Array)); + Write_String_Id (null); + Write_Type_Id (Obj_Rti.Obj_Type, Ctxt); + Addr := To_Ghdl_Uc_Array_Acc + (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); + declare + Rngs : Ghdl_Range_Array (0 .. Arr.Nbr_Dim - 1); + begin + Bound_To_Range (Addr.Bounds, Arr, Rngs); + for I in Rngs'Range loop + Write_Range (Arr.Indexes (I), Rngs (I)); + end loop; + end; + end; + else + -- Kind. + Wave_Put_Byte (Ghdl_Rtik'Pos (Rti.Kind)); + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 => + declare + Enum : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Write_String_Id (Enum.Name); + Wave_Put_ULEB128 (Ghdl_E32 (Enum.Nbr)); + for I in 1 .. Enum.Nbr loop + Write_String_Id (Enum.Names (I - 1)); + end loop; + end; + when Ghdl_Rtik_Subtype_Array => + declare + Arr : Ghdl_Rtin_Subtype_Array_Acc; + begin + Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Write_String_Id (Arr.Name); + Write_Type_Id (To_Ghdl_Rti_Access (Arr.Basetype), Ctxt); + declare + Rngs : Ghdl_Range_Array + (0 .. Arr.Basetype.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt), + Arr.Basetype, Rngs); + for I in Rngs'Range loop + Write_Range (Arr.Basetype.Indexes (I), Rngs (I)); + end loop; + end; + end; + when Ghdl_Rtik_Type_Array => + declare + Arr : Ghdl_Rtin_Type_Array_Acc; + begin + Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti); + Write_String_Id (Arr.Name); + Write_Type_Id (Arr.Element, Ctxt); + Wave_Put_ULEB128 (Ghdl_E32 (Arr.Nbr_Dim)); + for I in 1 .. Arr.Nbr_Dim loop + Write_Type_Id (Arr.Indexes (I - 1), Ctxt); + end loop; + end; + when Ghdl_Rtik_Type_Record => + declare + Rec : Ghdl_Rtin_Type_Record_Acc; + El : Ghdl_Rtin_Element_Acc; + begin + Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti); + Write_String_Id (Rec.Name); + Wave_Put_ULEB128 (Ghdl_E32 (Rec.Nbrel)); + for I in 1 .. Rec.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); + Write_String_Id (El.Name); + Write_Type_Id (El.Eltype, Ctxt); + end loop; + end; + when Ghdl_Rtik_Subtype_Scalar => + declare + Sub : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); + Write_String_Id (Sub.Name); + Write_Type_Id (Sub.Basetype, Ctxt); + Write_Range + (Sub.Basetype, + To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth, + Sub.Range_Loc, + Ctxt))); + end; + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 + | Ghdl_Rtik_Type_F64 => + declare + Base : Ghdl_Rtin_Type_Scalar_Acc; + begin + Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti); + Write_String_Id (Base.Name); + end; + when Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 => + declare + Base : Ghdl_Rtin_Type_Physical_Acc; + Unit : Ghdl_Rti_Access; + begin + Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Write_String_Id (Base.Name); + Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr)); + for I in 1 .. Base.Nbr loop + Unit := Base.Units (I - 1); + Write_String_Id + (Rtis_Utils.Get_Physical_Unit_Name (Unit)); + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + Wave_Put_LSLEB128 + (To_Ghdl_Rtin_Unit64_Acc (Unit).Value); + when Ghdl_Rtik_Unitptr => + case Rti.Kind is + when Ghdl_Rtik_Type_P64 => + Wave_Put_LSLEB128 + (To_Ghdl_Rtin_Unitptr_Acc (Unit). + Addr.I64); + when Ghdl_Rtik_Type_P32 => + Wave_Put_SLEB128 + (To_Ghdl_Rtin_Unitptr_Acc (Unit). + Addr.I32); + when others => + Internal_Error + ("wave.write_types(P32/P64-1)"); + end case; + when others => + Internal_Error + ("wave.write_types(P32/P64-2)"); + end case; + end loop; + end; + when others => + Internal_Error ("wave.write_types"); + -- Internal_Error ("wave.write_types: does not handle " & + -- Ghdl_Rtik'Image (Rti.Kind)); + end case; + end if; + end loop; + Wave_Put_Byte (0); + end Write_Types; + + procedure Write_Known_Types + is + use Grt.Rtis_Types; + + Boolean_Type_Id : AVL_Nid; + Bit_Type_Id : AVL_Nid; + Std_Ulogic_Type_Id : AVL_Nid; + + function Search_Type_Id (Rti : Ghdl_Rti_Access) return AVL_Nid + is + Ctxt : Rti_Context; + Tid : AVL_Nid; + begin + Find_Type (Rti, Null_Context, Ctxt, Tid); + return Tid; + end Search_Type_Id; + begin + Search_Types_RTI; + + Boolean_Type_Id := Search_Type_Id (Std_Standard_Boolean_RTI_Ptr); + + Bit_Type_Id := Search_Type_Id (Std_Standard_Bit_RTI_Ptr); + + if Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr /= null then + Std_Ulogic_Type_Id := Search_Type_Id + (Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr); + else + Std_Ulogic_Type_Id := AVL_Nil; + end if; + + Wave_Section ("WKT" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + + if Boolean_Type_Id /= AVL_Nil then + Wave_Put_Byte (1); + Write_Type_Id (Boolean_Type_Id); + end if; + + if Bit_Type_Id /= AVL_Nil then + Wave_Put_Byte (2); + Write_Type_Id (Bit_Type_Id); + end if; + + if Std_Ulogic_Type_Id /= AVL_Nil then + Wave_Put_Byte (3); + Write_Type_Id (Std_Ulogic_Type_Id); + end if; + + Wave_Put_Byte (0); + end Write_Known_Types; + + -- Table of signals to be dumped. + package Dump_Table is new Grt.Table + (Table_Component_Type => Ghdl_Signal_Ptr, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 32); + + function Get_Dump_Entry (N : Natural) return Ghdl_Signal_Ptr is + begin + return Dump_Table.Table (N); + end Get_Dump_Entry; + + pragma Unreferenced (Get_Dump_Entry); + + procedure Write_Hierarchy (Root : VhpiHandleT) + is + N : Natural; + begin + -- Check Alink is 0. + for I in Sig_Table.First .. Sig_Table.Last loop + if Sig_Table.Table (I).Alink /= null then + Internal_Error ("wave.write_hierarchy"); + end if; + end loop; + + Wave_Section ("HIE" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I32 (Ghdl_I32 (Nbr_Scopes)); + Wave_Put_I32 (Ghdl_I32 (Nbr_Scope_Signals)); + Wave_Put_I32 (Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1)); + Wave_Put_Hierarchy (Root, Step_Hierarchy); + Wave_Put_Byte (0); + + Dump_Table.Set_Last (Nbr_Dumped_Signals); + for I in Dump_Table.First .. Dump_Table.Last loop + Dump_Table.Table (I) := null; + end loop; + + -- Save and clear. + for I in Sig_Table.First .. Sig_Table.Last loop + N := Get_Signal_Number (Sig_Table.Table (I)); + if N /= 0 then + if Dump_Table.Table (N) /= null then + Internal_Error ("wave.write_hierarchy(2)"); + end if; + Dump_Table.Table (N) := Sig_Table.Table (I); + Sig_Table.Table (I).Alink := null; + end if; + end loop; + end Write_Hierarchy; + + procedure Write_Signal_Value (Sig : Ghdl_Signal_Ptr) is + begin + -- FIXME: for some signals, the significant value is the driving value! + Write_Value (Sig.Value, Sig.Mode); + end Write_Signal_Value; + + procedure Write_Snapshot is + begin + Wave_Section ("SNP" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I64 (Ghdl_I64 (Cycle_Time)); + + for I in Dump_Table.First .. Dump_Table.Last loop + Write_Signal_Value (Dump_Table.Table (I)); + end loop; + Wave_Put ("ESN" & NUL); + end Write_Snapshot; + + procedure Wave_Cycle; + + -- Called after elaboration. + procedure Wave_Start + is + Root : VhpiHandleT; + begin + -- Do nothing if there is no VCD file to generate. + if Wave_Stream = NULL_Stream then + return; + end if; + + Write_File_Header; + + -- FIXME: write infos + -- * date + -- * timescale + -- * design name ? + -- ... + + -- Put hierarchy. + Get_Root_Inst (Root); + -- Vcd_Search_Packages; + Wave_Put_Hierarchy (Root, Step_Name); + + Freeze_Strings; + + -- Register_Cycle_Hook (Vcd_Cycle'Access); + Write_Strings_Compress; + Write_Types; + Write_Known_Types; + Write_Hierarchy (Root); + + -- End of header mark. + Wave_Section ("EOH" & NUL); + + Write_Snapshot; + + Register_Cycle_Hook (Wave_Cycle'Access); + + fflush (Wave_Stream); + end Wave_Start; + + Wave_Time : Std_Time := 0; + In_Cyc : Boolean := False; + + procedure Wave_Close_Cyc + is + begin + Wave_Put_LSLEB128 (-1); + Wave_Put ("ECY" & NUL); + In_Cyc := False; + end Wave_Close_Cyc; + + procedure Wave_Cycle + is + Diff : Std_Time; + Sig : Ghdl_Signal_Ptr; + Last : Natural; + begin + if not In_Cyc then + Wave_Section ("CYC" & NUL); + Wave_Put_I64 (Ghdl_I64 (Cycle_Time)); + In_Cyc := True; + else + Diff := Cycle_Time - Wave_Time; + Wave_Put_LSLEB128 (Ghdl_I64 (Diff)); + end if; + Wave_Time := Cycle_Time; + + -- Dump signals. + Last := 0; + for I in Dump_Table.First .. Dump_Table.Last loop + Sig := Dump_Table.Table (I); + if Sig.Flags.Cyc_Event then + Wave_Put_ULEB128 (Ghdl_U32 (I - Last)); + Last := I; + Write_Signal_Value (Sig); + Sig.Flags.Cyc_Event := False; + end if; + end loop; + Wave_Put_Byte (0); + end Wave_Cycle; + + -- Called at the end of the simulation. + procedure Wave_End is + begin + if Wave_Stream = NULL_Stream then + return; + end if; + if In_Cyc then + Wave_Close_Cyc; + end if; + Wave_Write_Directory; + fflush (Wave_Stream); + end Wave_End; + + Wave_Hooks : aliased constant Hooks_Type := + (Option => Wave_Option'Access, + Help => Wave_Help'Access, + Init => Wave_Init'Access, + Start => Wave_Start'Access, + Finish => Wave_End'Access); + + procedure Register is + begin + Register_Hooks (Wave_Hooks'Access); + end Register; +end Grt.Waves; diff --git a/src/grt/grt-waves.ads b/src/grt/grt-waves.ads new file mode 100644 index 000000000..72d7ea6e1 --- /dev/null +++ b/src/grt/grt-waves.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - wave dumper (GHW) module. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +package Grt.Waves is + procedure Register; +end Grt.Waves; diff --git a/src/grt/grt-zlib.ads b/src/grt/grt-zlib.ads new file mode 100644 index 000000000..9dfee3665 --- /dev/null +++ b/src/grt/grt-zlib.ads @@ -0,0 +1,47 @@ +-- GHDL Run Time (GRT) - Zlib binding. +-- Copyright (C) 2005 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +with System; use System; +with Grt.C; use Grt.C; + +package Grt.Zlib is + pragma Linker_Options ("-lz"); + + type gzFile is new System.Address; + + NULL_gzFile : constant gzFile := gzFile (System'To_Address (0)); + + function gzputc (File : gzFile; C : int) return int; + pragma Import (C, gzputc); + + function gzwrite (File : gzFile; Buf : voids; Len : int) return int; + pragma Import (C, gzwrite); + + function gzopen (Path : chars; Mode : chars) return gzFile; + pragma Import (C, gzopen); + + procedure gzclose (File : gzFile); + pragma Import (C, gzclose); +end Grt.Zlib; diff --git a/src/grt/grt.adc b/src/grt/grt.adc new file mode 100644 index 000000000..f2284997d --- /dev/null +++ b/src/grt/grt.adc @@ -0,0 +1,46 @@ +-- GHDL Run Time (GRT) - Configuration pragmas. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +-- The GRT library is built with a lot of restrictions. +-- The purpose of these restrictions (mainly No_Run_Time) is not to link with +-- the GNAT run time library. The user does not need to download or compile +-- it. +-- +-- However, GRT works without these restrictions. If you want to use GRT +-- in Ada, you may compile GRT without these restrictions (remove the -gnatec +-- flag). +-- +-- This files is *not* names gnat.adc, in order to ease the possibility of +-- not using it. +pragma Restrictions (No_Exception_Handlers); +--pragma restrictions (No_Exceptions); +pragma Restrictions (No_Secondary_Stack); +--pragma Restrictions (No_Elaboration_Code); +pragma Restrictions (No_Io); +pragma restrictions (no_dependence => Ada.Tags); +pragma restrictions (no_dependence => GNAT); +pragma Restrictions (Max_Tasks => 0); +pragma Restrictions (No_Implicit_Heap_Allocations); +pragma No_Run_Time; diff --git a/src/grt/grt.ads b/src/grt/grt.ads new file mode 100644 index 000000000..9727d0430 --- /dev/null +++ b/src/grt/grt.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - Top of hierarchy. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +package Grt is + pragma Pure (Grt); +end Grt; diff --git a/src/grt/grt.ver b/src/grt/grt.ver new file mode 100644 index 000000000..031c20761 --- /dev/null +++ b/src/grt/grt.ver @@ -0,0 +1,25 @@ +{ + global: +vpi_free_object; +vpi_get; +vpi_get_str; +vpi_get_time; +vpi_get_value; +vpi_get_vlog_info; +vpi_handle; +vpi_handle_by_index; +vpi_iterate; +vpi_mcd_close; +vpi_mcd_name; +vpi_mcd_open; +vpi_put_value; +vpi_register_cb; +vpi_register_systf; +vpi_remove_cb; +vpi_scan; +vpi_vprintf; +vpi_printf; + local: + *; +}; + diff --git a/src/grt/main.adb b/src/grt/main.adb new file mode 100644 index 000000000..5de379449 --- /dev/null +++ b/src/grt/main.adb @@ -0,0 +1,32 @@ +-- GHDL Run Time (GRT) - C-like entry point. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. +with Ghdl_Main; + +function Main (Argc : Integer; Argv : System.Address) + return Integer +is +begin + return Ghdl_Main (Argc, Argv); +end Main; diff --git a/src/grt/main.ads b/src/grt/main.ads new file mode 100644 index 000000000..f7c414274 --- /dev/null +++ b/src/grt/main.ads @@ -0,0 +1,34 @@ +-- GHDL Run Time (GRT) - C-like entry point. +-- Copyright (C) 2002 - 2014 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- As a special exception, if other files instantiate generics from this +-- unit, or you link this unit with other files to produce an executable, +-- this unit does not by itself cause the resulting executable to be +-- covered by the GNU General Public License. This exception does not +-- however invalidate any other reasons why the executable file might be +-- covered by the GNU Public License. + +-- In the usual case of a standalone executable, this file defines the +-- standard entry point, ie the main() function. +-- +-- However, as explained in the manual, the user can use its own main() +-- function, and calls the ghdl entry point ghdl_main. +with System; + +function Main (Argc : Integer; Argv : System.Address) return Integer; +pragma Export (C, Main, "main"); diff --git a/src/translate/gcc/ANNOUNCE b/src/translate/gcc/ANNOUNCE deleted file mode 100644 index 7b1060e20..000000000 --- a/src/translate/gcc/ANNOUNCE +++ /dev/null @@ -1,21 +0,0 @@ -I am happy to introduce GHDL. - -GHDL is a GCC front-end for the VHDL (IEEE 1076) language, an hardware design -language. - -Currently, GHDL implements most of VHDL-1987 and some features of -VHDL-1993. It is mature enough to compile and run some complex design (such -as a DLX processor and leon1, a SPARCv7 processor) - -GHDL has been developped on a GNU/Linux x86 system, and only this configuration -has been tested (porting to other processor or system should not be an hard -task, but there are system dependent files in the run time). - -GHDL is written in Ada95 (using GNAT) and relies on agcc, an Ada -binding for GCC. It also includes a run-time library (written in Ada), named -grt. The front-end and the library are both distributed under the GPL licence. - -For sources, binary tarballs, or for more information, go to -http://ghdl.free.fr - -Tristan Gingold. diff --git a/src/translate/gcc/INSTALL b/src/translate/gcc/INSTALL deleted file mode 100644 index e710f9110..000000000 --- a/src/translate/gcc/INSTALL +++ /dev/null @@ -1,24 +0,0 @@ -Install file for the binary distribution of GHDL. - -GHDL is Copyright 2002 - 2010 Tristan Gingold. -GHDL is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -The binary are installed in /usr/local directory. You cannot change this -default location, unless you set links. - -You must be root to install this distribution. - -To install ghdl: -$ su -# tar -C / -jxvf @TARFILE@.tar.bz2 - -Note: you must also have a C compiler and zlib installed. - -There is a mailing list for any questions. You can subscribe via: - https://mail.gna.org/listinfo/ghdl-discuss/ - -Tristan Gingold. - diff --git a/src/translate/gcc/Make-lang.in b/src/translate/gcc/Make-lang.in deleted file mode 100644 index cde3e6c07..000000000 --- a/src/translate/gcc/Make-lang.in +++ /dev/null @@ -1,190 +0,0 @@ -# Top level -*- makefile -*- fragment for vhdl (GHDL). -# Copyright (C) 2002 -# Free Software Foundation, Inc. - -#This file is part of GNU CC. - -#GNU CC is free software; you can redistribute it and/or modify -#it under the terms of the GNU General Public License as published by -#the Free Software Foundation; either version 2, or (at your option) -#any later version. - -#GNU CC is distributed in the hope that it will be useful, -#but WITHOUT ANY WARRANTY; without even the implied warranty of -#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -#GNU General Public License for more details. - -#You should have received a copy of the GNU General Public License -#along with GNU CC; see the file COPYING. If not, write to -#the Free Software Foundation, 59 Temple Place - Suite 330, -#Boston, MA 02111-1307, USA. - -# This file provides the language dependent support in the main Makefile. -# Each language makefile fragment must provide the following targets: -# -# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap, -# foo.info, foo.dvi, -# foo.install-normal, foo.install-common, foo.install-info, foo.install-man, -# foo.uninstall, foo.mostlyclean, foo.clean, foo.distclean, foo.extraclean, -# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4 -# -# where `foo' is the name of the language. -# -# It should also provide rules for: -# -# - making any compiler driver (eg: g++) -# - the compiler proper (eg: cc1plus) -# - define the names for selecting the language in LANGUAGES. -# tool definitions -MV = mv -RM = rm -f - -# Extra flags to pass to recursive makes. -GHDL_ADAFLAGS= -Wall -gnata -VHDL_LIB_DIR=$(libsubdir)/vhdl -GNATBIND = gnatbind -GNATMAKE = gnatmake -VHDL_FLAGS_TO_PASS = \ - "GHDL_ADAFLAGS=$(GHDL_ADAFLAGS)" \ - "GNATMAKE=$(GNATMAKE)" \ - "GNATBIND=$(GNATBIND)" \ - "CFLAGS=$(CFLAGS)" \ - "VHDL_LIB_DIR=$(VHDL_LIB_DIR)" \ - "INSTALL_DATA=$(INSTALL_DATA)" \ - "INSTALL_PROGRAM=$(INSTALL_PROGRAM)" \ - "libexecsubdir=$(libexecsubdir)" - -MAKE_IN_VHDL=$(MAKE) -C vhdl $(FLAGS_TO_PASS) $(VHDL_FLAGS_TO_PASS) - -# Define the names for selecting vhdl in LANGUAGES. -vhdl VHDL: ghdl1$(exeext) ghdl$(exeext) ghdllib - -# Tell GNU Make to ignore these, if they exist. -.PHONY: vhdl VHDL ghdllib - -#ortho-lang.o: $(agcc_srcdir)/ortho-lang.c \ -# $(AGCC_GCCOBJ_DIR)gcc/gtype-vhdl.h \ -# $(AGCC_GCCOBJ_DIR)gcc/gt-vhdl-ortho-lang.h -# $(COMPILER) -c -o $@ $< $(AGCC_CFLAGS) $(INCLUDES) - -GHDL1_OBJS = attribs.o vhdl/ortho-lang.o - -# To be put in ALL_HOST_FRONTEND_OBJS, so that generated files are created -# before. -vhdl_OBJS=vhdl/ortho-lang.o - -# The compiler proper. -# It is compiled into the vhdl/ subdirectory to avoid file name clashes but -# linked in in gcc directory to be able to access to gcc object files. -ghdl1$(exeext): force $(GHDL1_OBJS) $(BACKEND) $(LIBDEPS) - CURDIR=`pwd`; cd $(srcdir)/vhdl; VHDLSRCDIR=`pwd`; cd $$CURDIR/vhdl; \ - $(GNATMAKE) -c -aI$$VHDLSRCDIR ortho_gcc-main \ - -cargs $(CFLAGS) $(GHDL_ADAFLAGS) - $(GNATMAKE) -o $@ -aI$(srcdir)/vhdl -aOvhdl ortho_gcc-main \ - -bargs -E -cargs $(CFLAGS) $(GHDL_ADAFLAGS) \ - -largs --LINK=$(LLINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) $(GHDL1_OBJS) \ - $(filter-out main.o,$(BACKEND)) $(LIBS) $(BACKENDLIBS) - -# The driver for ghdl. -ghdl$(exeext): force - $(MAKE_IN_VHDL) ../ghdl$(exeext) - -# Ghdl libraries. -ghdllib: ghdl$(exeext) ghdl1$(exeext) $(GCC_PASSES) force - $(MAKE_IN_VHDL) GRT_FLAGS="-O -g" $(FLAGS_TO_PASS) \ - ADAC=$(COMPILER_FOR_BUILD) ghdllib - -# Build hooks: - -vhdl.all.build: - -vhdl.all.cross: - @echo "No support for building vhdl cross-compiler" - exit 1 - -vhdl.start.encap: -vhdl.rest.encap: - -# Documentation hooks -doc/ghdl.info: vhdl/ghdl.texi - -rm -f doc/ghdl.info* - $(MAKEINFO) $(MAKEINFOFLAGS) -o $@ $< - -doc/ghdl.dvi: vhdl/ghdl.texi - $(TEXI2DVI) -o $@ $< - -vhdl.info: doc/ghdl.info - -vhdl.man: - -vhdl.dvi: doc/ghdl.dvi - -vhdl.generated-manpages: - -# Install hooks: -# ghdl1 is installed elsewhere as part of $(COMPILERS). - -vhdl.install-normal: - -vhdl.install-plugin: - -# Install the driver program as ghdl. -vhdl.install-common: ghdl$(exeext) - -mkdir $(DESTDIR)$(bindir) - -$(RM) $(DESTDIR)$(bindir)/ghdl$(exeext) - $(INSTALL_PROGRAM) ghdl$(exeext) $(DESTDIR)$(bindir)/ghdl$(exeext) -# Install the library - $(MAKE_IN_VHDL) install-ghdllib - -install-info:: $(DESTDIR)$(infodir)/ghdl.info - -vhdl.install-info: doc/ghdl.info - -rm -rf $(infodir)/ghdl.info* - $(INSTALL_DATA) doc/ghdl.info* $(DESTDIR)$(infodir) - -chmod a-x $(DESTDIR)$(infodir)/ghdl.info* - -install-ghdllib: - $(MAKE) -f vhdl/Makefile $(FLAGS_TO_PASS) $(VHDL_FLAGS_TO_PASS) install-ghdllib - -vhdl.install-man: $(DESTDIR)$(man1dir)/ghdl$(man1ext) - -$(DESTDIR)$(man1dir)/ghdl$(man1ext): $(srcdir)/vhdl/ghdl.1 - -rm -f $@ - -$(INSTALL_DATA) $< $@ - -chmod a-x $@ - -vhdl.uninstall: - -$(RM) $(DESTDIR)$(bindir)/ghdl$(exeext) - - -# Clean hooks: -# A lot of the ancillary files are deleted by the main makefile. -# We just have to delete files specific to us. - -vhdl.mostlyclean: - -$(RM) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c -vhdl.clean: - -$(RM) vhdl/*$(objext) -vhdl.distclean: - -$(RM) vhdl/Makefile - -$(RM) ghdl$(exeext) -vhdl.extraclean: - -vhdl.maintainer-clean: - - -# Stage hooks: -# The main makefile has already created stage?/vhdl - -vhdl.stage1: - -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage1/vhdl - -$(MV) vhdl/stamp-* stage1/vhdl -vhdl.stage2: - -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage2/vhdl - -$(MV) vhdl/stamp-* stage2/vhdl -vhdl.stage3: - -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage3/vhdl - -$(MV) vhdl/stamp-* stage3/vhdl -vhdl.stage4: - -$(MV) vhdl/*$(objext) vhdl/*.ali vhdl/b_*.c stage4/vhdl - -$(MV) vhdl/stamp-* stage4/vhdl diff --git a/src/translate/gcc/Makefile.in b/src/translate/gcc/Makefile.in deleted file mode 100644 index 13f329660..000000000 --- a/src/translate/gcc/Makefile.in +++ /dev/null @@ -1,299 +0,0 @@ -# Makefile for GNU vhdl Compiler (GHDL). -# Copyright (C) 2002 Free Software Foundation, Inc. - -#This file is part of GNU CC. - -#GNU CC is free software; you can redistribute it and/or modify -#it under the terms of the GNU General Public License as published by -#the Free Software Foundation; either version 2, or (at your option) -#any later version. - -#GNU CC is distributed in the hope that it will be useful, -#but WITHOUT ANY WARRANTY; without even the implied warranty of -#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -#GNU General Public License for more details. - -#You should have received a copy of the GNU General Public License -#along with GNU CC; see the file COPYING. If not, write to -#the Free Software Foundation, 59 Temple Place - Suite 330, -#Boston, MA 02111-1307, USA. - -# The makefile built from this file lives in the language subdirectory. -# It's purpose is to provide support for: -# -# 1) recursion where necessary, and only then (building .o's), and -# 2) building and debugging cc1 from the language subdirectory, and -# 3) nothing else. -# -# The parent makefile handles all other chores, with help from the -# language makefile fragment, of course. -# -# The targets for external use are: -# all, TAGS, ???mostlyclean, ???clean. - -# This makefile will only work with Gnu make. -# The rules are written assuming a minimum subset of tools are available: -# -# Required: -# MAKE: Only Gnu make will work. -# MV: Must accept (at least) one, maybe wildcard, source argument, -# a file or directory destination, and support creation/ -# modification date preservation. Gnu mv -f works. -# RM: Must accept an arbitrary number of space separated file -# arguments, or one wildcard argument. Gnu rm works. -# RMDIR: Must delete a directory and all its contents. Gnu rm -rf works. -# ECHO: Must support command line redirection. Any Unix-like -# shell will typically provide this, otherwise a custom version -# is trivial to write. -# LN: ln -s works, cp should work bu was not tested. -# CP: GNU cp -p works. -# AR: Gnu ar works. -# MKDIR: Gnu mkdir works. -# CHMOD: Gnu chmod works. -# true: Does nothing and returns a normal successful return code. -# pwd: Prints the current directory on stdout. -# cd: Change directory. - -# Tell GNU make 3.79 not to run this directory in parallel. -# Not all of the required dependencies are present. -.NOTPARALLEL: - -# Variables that exist for you to override. -# See below for how to change them for certain systems. - -ALLOCA = -# Various ways of specifying flags for compilations: -# CFLAGS is for the user to override to, e.g., do a bootstrap with -O2. -# BOOT_CFLAGS is the value of CFLAGS to pass -# to the stage2 and stage3 compilations -# XCFLAGS is used for most compilations but not when using the GCC just built. -XCFLAGS = -CFLAGS = -g -BOOT_CFLAGS = -O $(CFLAGS) -# These exists to be overridden by the x-* and t-* files, respectively. -X_CFLAGS = -T_CFLAGS = - -X_CPPFLAGS = -T_CPPFLAGS = - -X_ADAFLAGS = -T_ADAFLAGS = - -ADAC = $(CC) - -ECHO = echo -CHMOD = chmod -CP = cp -p -MV = mv -f -RM = rm -f -RMDIR = rm -rf -MKDIR = mkdir -p -LN = ln -s -AR = ar -# How to invoke ranlib. -RANLIB = ranlib -# Test to use to see whether ranlib exists on the system. -RANLIB_TEST = [ -f /usr/bin/ranlib -o -f /bin/ranlib ] -SHELL = /bin/sh -INSTALL_DATA = install -m 644 -MAKEINFO = makeinfo -TEXI2DVI = texi2dvi -GNATBIND = gnatbind -GNATMAKE = gnatmake -ADA_CFLAGS = $(CFLAGS) -GHDL_ADAFLAGS = -Wall -gnata - -objext = .o -exeext = -arext = .a -soext = .so -shext = - -HOST_CC=$(CC) -HOST_CFLAGS=$(ALL_CFLAGS) -HOST_CLIB=$(CLIB) -HOST_LDFLAGS=$(LDFLAGS) -HOST_CPPFLAGS=$(ALL_CPPFLAGS) -HOST_ALLOCA=$(ALLOCA) -HOST_MALLOC=$(MALLOC) -HOST_OBSTACK=$(OBSTACK) - -# We don't use cross-make. Instead we use the tools from the build tree, -# if they are available. -# program_transform_name and objdir are set by configure.in. -program_transform_name = -objdir = . - -target=@target@ -target_alias=@target_alias@ -target_noncanonical:=@target_noncanonical@ -xmake_file=@dep_host_xmake_file@ -tmake_file=@dep_tmake_file@ -#version=`sed -e 's/.*\"\([^ \"]*\)[ \"].*/\1/' < $(srcdir)/version.c` -#mainversion=`sed -e 's/.*\"\([0-9]*\.[0-9]*\).*/\1/' < $(srcdir)/version.c` - -# Directory where sources are, from where we are. -srcdir = @srcdir@ -VPATH = @srcdir@ - -# Top build directory, relative to here. -top_builddir = .. - -version := $(shell cat $(srcdir)/../BASE-VER) - -# End of variables for you to override. - -# Definition of `all' is here so that new rules inserted by sed -# do not specify the default target. -all: all.indirect - -# This tells GNU Make version 3 not to put all variables in the environment. -.NOEXPORT: - -# Now figure out from those variables how to compile and link. - -all.indirect: Makefile - -# This tells GNU make version 3 not to export all the variables -# defined in this file into the environment. -.NOEXPORT: - -Makefile: $(srcdir)/Makefile.in $(srcdir)/../configure - cd ..; $(SHELL) config.status - -force: - -SED=sed - -drvdir/default_pathes.ads: drvdir Makefile - echo "-- DO NOT EDIT" > tmp-dpathes.ads - echo "-- This file is created by Makefile" >> tmp-dpathes.ads - echo "package Default_Pathes is" >> tmp-dpathes.ads - echo " -- Accept long lines." >> tmp-dpathes.ads - echo " pragma Style_Checks (\"M999\");" >> tmp-dpathes.ads - echo " Install_Prefix : constant String :=" >> tmp-dpathes.ads - echo " \"$(exec_prefix)\";" >> tmp-dpathes.ads - echo " Compiler_Gcc : constant String :=" >> tmp-dpathes.ads - echo " \"libexec/gcc/$(target_noncanonical)/$(version)/ghdl1$(exeext)\";" >> tmp-dpathes.ads - echo " Compiler_Debug : constant String := \"\";" >> tmp-dpathes.ads - echo " Compiler_Mcode : constant String := \"\";" >> tmp-dpathes.ads - echo " Compiler_Llvm : constant String := \"\";" >> tmp-dpathes.ads - echo " Post_Processor : constant String := \"\";" >> tmp-dpathes.ads - echo " Lib_Prefix : constant String :=">> tmp-dpathes.ads - echo " \"lib/gcc/$(target_noncanonical)/$(version)/vhdl/lib/\";" >> tmp-dpathes.ads - echo "end Default_Pathes;" >> tmp-dpathes.ads - $(srcdir)/../../move-if-change tmp-dpathes.ads $@ - -../ghdl$(exeext): drvdir drvdir/default_pathes.ads force - CURDIR=`pwd`; cd $(srcdir); SRCDIR=`pwd`; cd $$CURDIR/drvdir; \ - $(GNATMAKE) -o ../$@ -aI$$SRCDIR/ghdldrv -aI$$SRCDIR -aO.. ghdl_gcc \ - -bargs -E -cargs $(ADA_CFLAGS) $(GHDL_ADAFLAGS) -largs $(LIBS) - -drvdir: - mkdir $@ - -clean: grt-clean ghdllibs-clean force - $(RM) *.o *.ali - $(RM) default_pathes.ads - -# Additionnal rules - -LIB87_DIR:=./lib/v87 -LIB93_DIR:=./lib/v93 -LIB08_DIR:=./lib/v08 -LIBSRC_DIR:=$(srcdir)/libraries -ANALYZE=../ghdl -a --GHDL1=../ghdl1 --ieee=none - -$(LIB93_DIR) $(LIB87_DIR): - $(srcdir)/../../mkinstalldirs $@ - -####libraries Makefile.inc - -std87_standard.o: $(GHDL1) - $(GHDL1) --std=87 -quiet -o std_standard.s --compile-standard - ../xgcc -c -o std_standard.o std_standard.s - $(MV) std_standard.o $@ - -std93_standard.o: $(GHDL1) - $(GHDL1) --std=93 -quiet -o std_standard.s --compile-standard - ../xgcc -c -o std_standard.o std_standard.s - $(MV) std_standard.o $@ - -std08_standard.o: $(GHDL1) - $(GHDL1) --std=08 -quiet -o std_standard.s --compile-standard - ../xgcc -c -o std_standard.o std_standard.s - $(MV) std_standard.o $@ - -ghdllib: std87_standard.o std93_standard.o std08_standard.o libgrt.a - -ghdllibs-clean: force - $(RM) -rf $(LIB87_DIR) $(LIB93_DIR) $(LIB08_DIR) - -PHONY: ghdllib ghdllibs-clean - -GHDL1=../ghdl1 -GRTSRCDIR=$(srcdir)/grt -GRT_RANLIB=$(RANLIB) - -####grt Makefile.inc - -install-ghdllib: ghdllib grt.lst $(STD93_SRCS) $(STD87_SRCS) \ - $(IEEE93_SRCS) $(IEEE87_SRCS) $(SYNOPSYS_SRCS) \ - $(STD08_SRCS) $(IEEE08_SRCS) - $(RM) -rf $(DESTDIR)$(VHDL_LIB_DIR) - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR) -# Install libgrt - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib - $(INSTALL_DATA) libgrt.a $(DESTDIR)$(VHDL_LIB_DIR)/lib/libgrt.a - $(INSTALL_DATA) grt.lst $(DESTDIR)$(VHDL_LIB_DIR)/lib/grt.lst - $(INSTALL_DATA) $(GRTSRCDIR)/grt.ver $(DESTDIR)$(VHDL_LIB_DIR)/lib/grt.ver -# Install VHDL sources. - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/std - for i in $(STD93_SRCS) $(STD87_SRCS) $(STD08_SRCS); do \ - $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/std; \ - done - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee - for i in $(IEEE93_SRCS) $(IEEE87_SRCS); do \ - $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee; \ - done - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/vital95 - for i in $(VITAL95_SRCS); do \ - $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/vital95; \ - done - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/vital2000 - for i in $(VITAL2000_SRCS); do \ - $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/vital2000; \ - done - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/synopsys - for i in $(SYNOPSYS_SRCS); do \ - $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/synopsys; \ - done - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/mentor - for i in $(MENTOR93_SRCS); do \ - $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/mentor; \ - done - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee2008 - for i in $(IEEE08_SRCS); do \ - $(INSTALL_DATA) $$i $(DESTDIR)$(VHDL_LIB_DIR)/src/ieee2008; \ - done -# Create library dirs - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib/v93 - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib/v87 - $(MKDIR) $(DESTDIR)$(VHDL_LIB_DIR)/lib/v08 -# Compile in place. - PDIR=`pwd` && cd $(DESTDIR)$(VHDL_LIB_DIR) && \ - $(MAKE) -f $$PDIR/Makefile REL_DIR=../../.. LIBSRC_DIR="src" \ - LIB93_DIR=lib/v93 LIB87_DIR=lib/v87 LIB08_DIR=lib/v08 \ - ANALYZE="$$PDIR/../ghdl -a --GHDL1=$$PDIR/../ghdl1 --ieee=none" \ - std.v87 ieee.v87 synopsys.v87 \ - std.v93 ieee.v93 synopsys.v93 mentor.v93 \ - std.v08 ieee.v08 -# Copy std_standard (this is done after libraries, since they remove dirs). - $(INSTALL_DATA) std87_standard.o \ - $(DESTDIR)$(VHDL_LIB_DIR)/lib/v87/std/std_standard.o - $(INSTALL_DATA) std93_standard.o \ - $(DESTDIR)$(VHDL_LIB_DIR)/lib/v93/std/std_standard.o - $(INSTALL_DATA) std08_standard.o \ - $(DESTDIR)$(VHDL_LIB_DIR)/lib/v08/std/std_standard.o diff --git a/src/translate/gcc/README b/src/translate/gcc/README deleted file mode 100644 index 1152e9908..000000000 --- a/src/translate/gcc/README +++ /dev/null @@ -1,87 +0,0 @@ -This is the README from the source distribution of GHDL. - -To get the binary distribution or more information, go to http://ghdl.free.fr - -Copyright: -********** -GHDL is copyright (c) 2002 - 2010 Tristan Gingold. -See the GHDL manual for more details. - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. - - -Building GHDL from sources: -*************************** - -Required: -* the sources of @GCCVERSION@ (at least the core part). - Note: other versions of gcc sources have not been tested. -* the Ada95 GNAT compiler (GNAT GPL 2008 are known to work; - Ada compilers in most Linux distributions are more or less buggy) -* GNU/Linux for ix86 (pc systems) (porting is necessary for other systems) - -Procedure: -* Check your Ada compiler. On some systems (or with some distribution), the - GNAT compiler seems broken. Try this very simple example, using file - example.adb -<<<<<<<<<<<<<<<<<< -procedure Example is -begin - null; -end Example; -<<<<<<<<<<<<<<<<<< - Compile with - $ gnatmake example - It should create an executable, 'example'. - If this doesn't work, your GNAT installation is broken. It may be a PATH - problem or something else. -* untar the gcc tarball -* untar the ghdl tarball (this sould have been done, since you are reading a - file from it). -* move or copy the vhdl directory of ghdl into the gcc subdirectory of - the gcc distribution. - You should have a @GCCVERSION@/gcc/vhdl directory. -* configure gcc with the --enable-languages=vhdl option. You may of course - add other languages. Also you'd better to disable bootstraping using - --disable-bootstrap. - Refer to the gcc installation documentation. -* compile gcc. - 'make CFLAGS="-O"' is OK -* install gcc. This installs the ghdl driver too. - 'make install' is OK. - -There is a mailing list for any questions. You can subscribe via: - https://mail.gna.org/listinfo/ghdl-discuss/ -Please report bugs on https://gna.org/bugs/?group=ghdl - -If you cannot compile, please report the gcc version, GNAT version and gcc -source version. - -* Note for ppc64 (and AIX ?) platform: -The object file format contains an identifier for the source language. Because -gcc doesn't know about the VHDL, gcc crashes very early. This could be fixed -with a very simple change in gcc/config/rs6000/rs6000.c, -function rs6000_output_function_epilogue (as of gcc 4.8): - else if (! strcmp (language_string, "GNU Objective-C")) - i = 14; - else -- gcc_unreachable (); -+ i = 0; - fprintf (file, "%d,", i); - - /* 8 single bit fields: global linkage (not set for C extern linkage, - -Tristan Gingold. diff --git a/src/translate/gcc/config-lang.in b/src/translate/gcc/config-lang.in deleted file mode 100644 index 7010b1127..000000000 --- a/src/translate/gcc/config-lang.in +++ /dev/null @@ -1,38 +0,0 @@ -# Top level configure fragment for GNU vhdl (GHDL). -# Copyright (C) 1994-2001 Free Software Foundation, Inc. - -#This file is part of GNU CC. - -#GNU CC is free software; you can redistribute it and/or modify -#it under the terms of the GNU General Public License as published by -#the Free Software Foundation; either version 2, or (at your option) -#any later version. - -#GNU CC is distributed in the hope that it will be useful, -#but WITHOUT ANY WARRANTY; without even the implied warranty of -#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -#GNU General Public License for more details. - -#You should have received a copy of the GNU General Public License -#along with GNU CC; see the file COPYING. If not, write to -#the Free Software Foundation, 59 Temple Place - Suite 330, -#Boston, MA 02111-1307, USA. - -# Configure looks for the existence of this file to auto-config each language. -# We define several parameters used by configure: -# -# language - name of language as it would appear in $(LANGUAGES) -# boot_language - "yes" if we need to build this language in stage1 -# compilers - value to add to $(COMPILERS) -# stagestuff - files to add to $(STAGESTUFF) - -language="vhdl" -boot_language=no - -compilers="ghdl1\$(exeext)" - -stagestuff="ghdl\$(exeext) ghdl1\$(exeext)" - -outputs=vhdl/Makefile - -gtfiles="\$(srcdir)/vhdl/ortho-lang.c" diff --git a/src/translate/gcc/dist-common.sh b/src/translate/gcc/dist-common.sh deleted file mode 100644 index ad2229734..000000000 --- a/src/translate/gcc/dist-common.sh +++ /dev/null @@ -1,337 +0,0 @@ -# ghdl core files -cfiles=" -evaluation.adb -evaluation.ads -scanner.ads -scanner.adb -scanner-scan_literal.adb -back_end.ads -back_end.adb -files_map.adb -files_map.ads -sem.adb -sem.ads -sem_expr.adb -sem_expr.ads -sem_names.adb -sem_names.ads -sem_scopes.adb -sem_scopes.ads -sem_decls.ads -sem_decls.adb -sem_inst.ads -sem_inst.adb -sem_specs.ads -sem_specs.adb -sem_stmts.ads -sem_stmts.adb -sem_types.ads -sem_types.adb -sem_assocs.ads -sem_assocs.adb -sem_psl.ads -sem_psl.adb -canon.adb -canon.ads -canon_psl.ads -canon_psl.adb -flags.adb -flags.ads -configuration.adb -configuration.ads -nodes.ads -nodes.adb -nodes_gc.ads -nodes_gc.adb -nodes_meta.ads -nodes_meta.adb -options.ads -options.adb -psl-errors.ads -lists.ads -lists.adb -iirs.adb -iirs.ads -iir_chains.ads -iir_chains.adb -iir_chain_handling.ads -iir_chain_handling.adb -iirs_walk.ads -iirs_walk.adb -std_names.adb -std_names.ads -disp_tree.adb -disp_tree.ads -iirs_utils.adb -iirs_utils.ads -std_package.adb -std_package.ads -disp_vhdl.adb -disp_vhdl.ads -libraries.adb -libraries.ads -tokens.adb -tokens.ads -name_table.adb -name_table.ads -str_table.ads -str_table.adb -types.ads -version.ads -errorout.adb -errorout.ads -parse.adb -parse.ads -parse_psl.ads -parse_psl.adb -post_sems.ads -post_sems.adb -ieee.ads -ieee-std_logic_1164.ads -ieee-std_logic_1164.adb -ieee-vital_timing.ads -ieee-vital_timing.adb -xrefs.ads -xrefs.adb -bug.ads -bug.adb -" - -# translation file -tfiles=" -translation.adb -ortho_front.adb -translation.ads -trans_decls.ads -trans_be.ads -trans_be.adb -trans_analyzes.ads -trans_analyzes.adb" - -ortho_files=" -ortho_front.ads" - -ortho_gcc_files=" -lang.opt -ortho-lang.c -ortho_gcc-main.adb -ortho_gcc-main.ads -ortho_gcc.adb -ortho_gcc.ads -ortho_gcc_front.ads -ortho_ident.adb -ortho_ident.ads -ortho_nodes.ads -" - -ghdl_files=" -ghdl_gcc.adb -ghdldrv.ads -ghdldrv.adb -ghdlprint.ads -ghdlprint.adb -ghdllocal.ads -ghdllocal.adb -ghdlmain.ads -ghdlmain.adb -" - -libraries_files=" -std/textio.vhdl -std/textio_body.vhdl -std/env.vhdl -std/env_body.vhdl -ieee/README.ieee -ieee/numeric_bit-body.vhdl -ieee/numeric_bit.vhdl -ieee/numeric_std-body.vhdl -ieee/numeric_std.vhdl -ieee/std_logic_1164.vhdl -ieee/std_logic_1164_body.vhdl -ieee/math_real.vhdl -ieee/math_real-body.vhdl -ieee/math_complex.vhdl -ieee/math_complex-body.vhdl -ieee2008/README.ieee -ieee2008/fixed_float_types.vhdl -ieee2008/fixed_generic_pkg-body.vhdl -ieee2008/fixed_generic_pkg.vhdl -ieee2008/fixed_pkg.vhdl -ieee2008/float_generic_pkg-body.vhdl -ieee2008/float_generic_pkg.vhdl -ieee2008/float_pkg.vhdl -ieee2008/math_complex-body.vhdl -ieee2008/math_complex.vhdl -ieee2008/math_real-body.vhdl -ieee2008/math_real.vhdl -ieee2008/numeric_bit-body.vhdl -ieee2008/numeric_bit.vhdl -ieee2008/numeric_bit_unsigned-body.vhdl -ieee2008/numeric_bit_unsigned.vhdl -ieee2008/numeric_std-body.vhdl -ieee2008/numeric_std.vhdl -ieee2008/numeric_std_unsigned-body.vhdl -ieee2008/numeric_std_unsigned.vhdl -ieee2008/std_logic_1164-body.vhdl -ieee2008/std_logic_1164.vhdl -ieee2008/std_logic_textio.vhdl -vital95/vital_primitives.vhdl -vital95/vital_primitives_body.vhdl -vital95/vital_timing.vhdl -vital95/vital_timing_body.vhdl -vital2000/memory_b.vhdl -vital2000/memory_p.vhdl -vital2000/prmtvs_b.vhdl -vital2000/prmtvs_p.vhdl -vital2000/timing_b.vhdl -vital2000/timing_p.vhdl -synopsys/std_logic_arith.vhdl -synopsys/std_logic_misc.vhdl -synopsys/std_logic_misc-body.vhdl -synopsys/std_logic_signed.vhdl -synopsys/std_logic_textio.vhdl -synopsys/std_logic_unsigned.vhdl -mentor/std_logic_arith.vhdl -mentor/std_logic_arith_body.vhdl -" - -grt_files=" -grt-cbinding.c -grt-cvpi.c -grt.adc -grt-astdio.ads -grt-astdio.adb -grt-avhpi.adb -grt-avhpi.ads -grt-avls.ads -grt-avls.adb -grt-c.ads -grt-disp.adb -grt-disp.ads -grt-disp_rti.adb -grt-disp_rti.ads -grt-disp_tree.adb -grt-disp_tree.ads -grt-disp_signals.adb -grt-disp_signals.ads -grt-errors.adb -grt-errors.ads -grt-files.adb -grt-files.ads -grt-hooks.adb -grt-hooks.ads -grt-images.adb -grt-images.ads -grt-lib.adb -grt-lib.ads -grt-main.adb -grt-main.ads -grt-modules.ads -grt-modules.adb -grt-names.adb -grt-names.ads -grt-options.adb -grt-options.ads -grt-processes.adb -grt-processes.ads -grt-rtis.ads -grt-rtis.adb -grt-rtis_addr.adb -grt-rtis_addr.ads -grt-rtis_utils.adb -grt-rtis_utils.ads -grt-rtis_binding.ads -grt-rtis_types.ads -grt-rtis_types.adb -grt-sdf.adb -grt-sdf.ads -grt-shadow_ieee.ads -grt-shadow_ieee.adb -grt-signals.adb -grt-signals.ads -grt-stack2.adb -grt-stack2.ads -grt-stacks.adb -grt-stacks.ads -grt-stats.ads -grt-stats.adb -grt-stdio.ads -grt-table.ads -grt-table.adb -grt-types.ads -grt-unithread.ads -grt-unithread.adb -grt-values.adb -grt-values.ads -grt-vcd.adb -grt-vcd.ads -grt-vcdz.adb -grt-vcdz.ads -grt-vital_annotate.adb -grt-vital_annotate.ads -grt-vpi.adb -grt-vpi.ads -grt-vstrings.adb -grt-vstrings.ads -grt-waves.ads -grt-waves.adb -grt-zlib.ads -grt-threads.ads -grt-arch_none.ads -grt-arch_none.adb -grt-std_logic_1164.ads -grt-std_logic_1164.adb -grt.ads -main.adb -main.ads -ghdl_main.ads -ghdl_main.adb -ghwlib.h -ghwlib.c -ghwdump.c -grt.ver -" - -grt_config_files=" -i386.S -sparc.S -ppc.S -ia64.S -amd64.S -times.c -clock.c -linux.c -pthread.c -win32.c" - -psl_files=" -psl.ads -psl-build.adb -psl-build.ads -psl-cse.adb -psl-cse.ads -psl-disp_nfas.adb -psl-disp_nfas.ads -psl-dump_tree.adb -psl-dump_tree.ads -psl-hash.adb -psl-hash.ads -psl-nfas.adb -psl-nfas.ads -psl-nfas-utils.adb -psl-nfas-utils.ads -psl-nodes.adb -psl-nodes.ads -psl-optimize.adb -psl-optimize.ads -psl-prints.adb -psl-prints.ads -psl-priorities.ads -psl-qm.adb -psl-qm.ads -psl-rewrites.adb -psl-rewrites.ads -psl-subsets.adb -psl-subsets.ads -psl-tprint.adb -psl-tprint.ads" diff --git a/src/translate/gcc/dist.sh b/src/translate/gcc/dist.sh deleted file mode 100755 index 8632dc574..000000000 --- a/src/translate/gcc/dist.sh +++ /dev/null @@ -1,471 +0,0 @@ -#!/bin/sh - -# Script used to create tar balls. -# Copyright (C) 2002, 2003, 2004, 2005, 2006 Tristan Gingold -# -# GHDL is free software; you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free -# Software Foundation; either version 2, or (at your option) any later -# version. -# -# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or -# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -# for more details. -# -# You should have received a copy of the GNU General Public License -# along with GCC; see the file COPYING. If not, write to the Free -# Software Foundation, 59 Temple Place - Suite 330, Boston, MA -# 02111-1307, USA. - -# Building a distribution: -# * update the 'version' variable in ../../Makefile -# * Regenerate version.ads: make -f ../../Makefile version.ads -# * Check NEWS, README and INSTALL files. -# * Check version and copyright years in doc/ghdl.texi, ghdlmain.adb -# * Check GCCVERSION below. -# * Check lists of exported files in this file. -# * Create source tar and build binaries: ./dist.sh dist_phase1 -# * su root -# * Build binary tar: HOME=~user ./dist.sh dist_phase2 -# * Run the testsuites: GHDL=ghdl ./testsuite.sh gcc -# * Update website/index.html (./dist.sh website helps) -# * upload (./dist upload) -# * CVS commit, tag + cd image. -# * remove previous version in /usr/local - -## DO NOT MODIFY this file while it is running... - -set -e - -# GCC version -GCCVERSION=4.9.2 -# Machine name used by GCC -MACHINE=${MACHINE:i686-pc-linux-gnu} -# Directory where GCC sources (and objects) stay. -DISTDIR=${DISTDIR:-$HOME/dist} -# GTKWave version. -GTKWAVE_VERSION=3.3.50 - -# GHDL version (extracted from version.ads) -VERSION=`sed -n -e 's/.*GHDL \([0-9.a-z]*\) (.*/\1/p' ../../version.ads` - -CWD=`pwd` - -distdir=ghdl-$VERSION -tarfile=$distdir.tar - -GTKWAVE_BASE=$HOME/devel/gtkwave-$GTKWAVE_VERSION - -GCCDIST=$DISTDIR/gcc-$GCCVERSION -GCCDISTOBJ=$GCCDIST-objs -PREFIX=/usr/local -GCCLIBDIR=$PREFIX/lib/gcc/$MACHINE/$GCCVERSION -GCCLIBEXECDIR=$PREFIX/libexec/gcc/$MACHINE/$GCCVERSION -bindirname=ghdl-$VERSION-$MACHINE -TARINSTALL=$DISTDIR/$bindirname.tar.bz2 -VHDLDIR=$distdir/vhdl -DOWNLOAD_HTML=../../website/download.html -DESTDIR=$CWD/ -UNSTRIPDIR=${distdir}-unstripped - -PATH=/usr/gnat/bin:$PATH - -do_clean () -{ - rm -rf $VHDLDIR - mkdir $VHDLDIR - mkdir $VHDLDIR/ghdldrv - mkdir $VHDLDIR/libraries - mkdir $VHDLDIR/libraries/std $VHDLDIR/libraries/ieee - mkdir $VHDLDIR/libraries/vital95 $VHDLDIR/libraries/vital2000 - mkdir $VHDLDIR/libraries/synopsys $VHDLDIR/libraries/mentor - mkdir $VHDLDIR/libraries/ieee2008 - mkdir $VHDLDIR/grt - mkdir $VHDLDIR/grt/config -} - -# Build Makefile -do_Makefile () -{ - sed -e "/^####libraries Makefile.inc/r ../../libraries/Makefile.inc" \ - -e "/^####grt Makefile.inc/r ../grt/Makefile.inc" \ - < Makefile.in > $VHDLDIR/Makefile.in - cp Make-lang.in $VHDLDIR/Make-lang.in -} - -# Copy (or link) sources files into $VHDLDIR -do_files () -{ -. ./dist-common.sh - -# Local files -lfiles="config-lang.in lang-options.h lang-specs.h" -for i in $lfiles; do ln -sf $CWD/$i $VHDLDIR/$i; done - -for i in $cfiles; do ln -sf $CWD/../../$i $VHDLDIR/$i; done - -for i in ghdl.texi ghdl.1; do ln -sf $CWD/../../doc/$i $VHDLDIR/$i; done - -for i in $tfiles; do ln -sf $CWD/../$i $VHDLDIR/$i; done - -for i in $ortho_files; do ln -sf $CWD/../../ortho/$i $VHDLDIR/$i; done - -for i in $ortho_gcc_files; do - ln -sf $CWD/../../ortho/gcc/$i $VHDLDIR/$i -done - -for i in $ghdl_files; do - ln -sf $CWD/../ghdldrv/$i $VHDLDIR/ghdldrv/$i -done - -for i in $libraries_files; do - ln -sf $CWD/../../libraries/$i $VHDLDIR/libraries/$i -done - -for i in $grt_files; do - ln -sf $CWD/../grt/$i $VHDLDIR/grt/$i -done - -for i in $grt_config_files; do - ln -sf $CWD/../grt/config/$i $VHDLDIR/grt/config/$i -done - -for i in $psl_files; do - ln -sf $CWD/../../psl/$i $VHDLDIR/$i -done -} - -# Create the tar of sources. -do_sources () -{ - \rm -rf $distdir - mkdir $distdir - VHDLDIR=$distdir/vhdl - do_clean $VHDLDIR - do_Makefile - do_files - ln -sf ../../../COPYING $distdir - sed -e "s/@GCCVERSION@/gcc-$GCCVERSION/g" < README > $distdir/README - tar cvhf $tarfile $distdir - bzip2 -f $tarfile - rm -rf $distdir -} - -# Put GHDL sources in GCC. -do_update_gcc_sources () -{ - set -x - - cd $GCCDIST/.. - tar jxvf $CWD/$tarfile.bz2 - rm -rf $GCCDIST/gcc/vhdl - mv $distdir/vhdl $GCCDIST/gcc -} - -# Extract the source, configure and make. -do_compile () -{ - #set -x - - do_update_gcc_sources; - -# gmp build with: -# CFLAGS="-O -m32" ./configure --prefix=$HOME/dist/build \ -# --disable-shared --build=i686-pc-linux-gnu -# make -# make install -# make check - - # usegnat32! - - rm -rf $GCCDISTOBJ - mkdir $GCCDISTOBJ - cd $GCCDISTOBJ - export CFLAGS="-O -g" - - case $MACHINE in - i?86-*-linux*) - # gmp location (mpfr and mpc are supposed to be at the same place) - CONFIG_LIBS="--with-gmp=$PWD/../build" - ;; - x86_64-*-linux*) - CONFIG_LIBS="" - ;; - x86_64-*-darwin*) - CONFIG_LIBS="--with-gmp=$HOME/local --with-stage1-ldflags=" - ;; - *) - exit 1 - ;; - esac - ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX --disable-bootstrap --with-bugurl="" --build=$MACHINE $CONFIG_LIBS --disable-shared --disable-libmudflap --disable-libssp --disable-libgomp --disable-libquadmath - - make -j4 - make -C gcc vhdl.info - cd $CWD -} - -# Re-package sources, update gcc sources and recompile without reconfiguring. -do_recompile () -{ - do_sources - do_update_gcc_sources; - cd $GCCDISTOBJ - export CFLAGS="-O -g" - make -j4 -} - -check_root () -{ - if [ $UID -ne 0 ]; then - echo "$0: you must be root"; - exit 1; - fi -} - -# Do a make install -do_gcc_install () -{ - set -x - cd $GCCDISTOBJ - # Check the info file is not empty. - if [ -s gcc/doc/ghdl.info ]; then - echo "info file found" - else - echo "Error: ghdl.info not found". - exit 1; - fi - mkdir -p $DESTDIR/usr/local || true - make DESTDIR=$DESTDIR install - cd $CWD - if [ -d $UNSTRIPDIR ]; then - rm -rf $UNSTRIPDIR - fi - mkdir $UNSTRIPDIR - cp ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl $UNSTRIPDIR - chmod -w $UNSTRIPDIR/* - strip ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl -} - -# Create the tar file from the current installation. -do_tar_install () -{ - tar -C $DESTDIR -jcvf $TARINSTALL \ - ./$PREFIX/bin/ghdl ./$PREFIX/info/ghdl.info ./$PREFIX/man/man1/ghdl.1 \ - ./$GCCLIBDIR/vhdl \ - ./$GCCLIBEXECDIR/ghdl1 -} - -do_extract_tar_install () -{ - check_root; - cd / - tar jxvf $TARINSTALL - cd $CWD -} - -# Create the tar file to be distributed. -do_tar_dist () -{ - rm -rf $bindirname - mkdir $bindirname - sed -e "s/@TARFILE@/$bindirname/" < INSTALL > $bindirname/INSTALL - ln ../../COPYING $bindirname - cp $TARINSTALL $bindirname - tar cvf $bindirname.tar $bindirname -} - -# Remove the non-ghdl files of gcc in the current installation. -do_distclean_gcc () -{ - set -x - rm -f ${DESTDIR}${PREFIX}/bin/cpp ${DESTDIR}${PREFIX}/bin/gcc - rm -f ${DESTDIR}${PREFIX}/bin/gcc-* - rm -f ${DESTDIR}${PREFIX}/bin/gccbug ${DESTDIR}${PREFIX}/bin/gcov - rm -f ${DESTDIR}${PREFIX}/bin/${MACHINE}-gcc* - rm -f ${DESTDIR}${PREFIX}/info/cpp.info* - rm -f ${DESTDIR}${PREFIX}/info/cppinternals.info* - rm -f ${DESTDIR}${PREFIX}/info/gcc.info* - rm -f ${DESTDIR}${PREFIX}/info/gccinstall.info* - rm -f ${DESTDIR}${PREFIX}/info/gccint.info* - rm -f ${DESTDIR}${PREFIX}/lib/*.a - rm -f ${DESTDIR}${PREFIX}/lib/*.so* - rm -f ${DESTDIR}${PREFIX}/lib/*.la - rm -rf ${DESTDIR}${PREFIX}/share - rm -rf ${DESTDIR}${PREFIX}/man/man7 - rm -rf ${DESTDIR}${PREFIX}/man/man1/{cpp,gcc,gcov}.1 - rm -rf ${DESTDIR}${PREFIX}/include - rm -f ${DESTDIR}${GCCLIBEXECDIR}/cc1 ${DESTDIR}${GCCLIBEXECDIR}/collect2 - rm -f ${DESTDIR}${GCCLIBEXECDIR}/cpp0 ${DESTDIR}${GCCLIBEXECDIR}/tradcpp0 - rm -rf ${DESTDIR}${GCCLIBEXECDIR}/plugin - rm -rf ${DESTDIR}${GCCLIBEXECDIR}/lto-wrapper - rm -f ${DESTDIR}${GCCLIBDIR}/*.o ${DESTDIR}$GCCLIBDIR/*.a - rm -f ${DESTDIR}${GCCLIBDIR}/specs - rm -rf ${DESTDIR}${GCCLIBDIR}/plugin - rm -rf ${DESTDIR}${GCCLIBDIR}/include - rm -rf ${DESTDIR}${GCCLIBDIR}/include-fixed - rm -rf ${DESTDIR}${GCCLIBDIR}/install-tools - rm -rf ${DESTDIR}${GCCLIBEXECDIR}/install-tools -} - -# Remove ghdl files in the current installation. -do_distclean_ghdl () -{ - check_root; - set -x - rm -f $PREFIX/bin/ghdl - rm -f $PREFIX/info/ghdl.info* - rm -f $GCCLIBEXECDIR/ghdl1 - rm -rf $GCCLIBDIR/vhdl -} - -# Build the source tar, and build the binaries. -do_dist_phase1 () -{ - do_sources; - do_compile; - do_gcc_install; - do_distclean_gcc; - do_tar_install; - do_tar_dist; - rm -rf ./$PREFIX -} - -# Install the binaries and create the binary tar. -do_dist_phase2 () -{ - check_root; - do_distclean_ghdl; - do_extract_tar_install; - echo "dist_phase2 success" -} - -# Create gtkwave patch -do_gtkwave_patch () -{ -# rm -rf gtkwave-patch - mkdir gtkwave-patch - diff -rc -x Makefile.in $GTKWAVE_BASE.orig $GTKWAVE_BASE | \ - sed -e "/^Only in/d" \ - > gtkwave-patch/gtkwave-$GTKWAVE_VERSION.diffs - cp ../grt/ghwlib.c ../grt/ghwlib.h $GTKWAVE_BASE/src/ghw.c gtkwave-patch - sed -e "s/VERSION/$GTKWAVE_VERSION/g" < README.gtkwave > gtkwave-patch/README - tar zcvf ../../website/gtkwave-patch.tgz gtkwave-patch - rm -rf gtkwave-patch -} - -# Update the index.html -# Update the doc -do_website () -{ - cp "$DOWNLOAD_HTML" "$DOWNLOAD_HTML".old - sed -e " -/SRC-HREF/ s/href=\".*\"/href=\"$tarfile.bz2\"/ -/BIN-HREF/ s/href=\".*\"/href=\"$bindirname.tar\"/ -/HISTORY/ a \\ - \\ - $VERSION\\ - `date +'%b %e %Y'`\\ - $GCCVERSION\\ - $tarfile.bz2\\ - \\ - $bindirname.tar\\ - -" < "$DOWNLOAD_HTML".old > "$DOWNLOAD_HTML" - dir=../../website/ghdl - echo "Updating $dir" - rm -rf $dir - makeinfo --html -o $dir ../../doc/ghdl.texi -} - -# Do ftp commands to upload -do_upload () -{ -if tty -s; then - echo -n "Please, enter password: " - stty -echo - read pass - stty echo - echo -else - echo "$0: upload must be done from a tty" - exit 1; -fi -ftp -n < $@ - echo "package Ortho_Code.X86.Flags renames Ortho_Code.X86.$(ORTHO_X86_FLAGS);" >> $@ - -ghdl_mcode: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME -ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) memsegs_c.o chkstk.o force - $(GNATMAKE) -o $@ -aI../../ortho/mcode -aI../../ortho $(GNATFLAGS) ghdl_jit.adb $(GNAT_BARGS) -largs memsegs_c.o chkstk.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) - -memsegs_c.o: ../../ortho/mcode/memsegs_c.c - $(CC) -c -g -o $@ $< - -ghdl_llvm_jit: GRT_FLAGS+=-DWITH_GNAT_RUN_TIME -ghdl_llvm_jit: default_pathes.ads $(GRT_ADD_OBJS) $(ORTHO_DEPS) llvm-cbindings.o force - $(GNATMAKE) -o $@ -aI../../ortho/llvm -aI../../ortho $(GNATFLAGS) ghdl_jit.adb $(GNAT_BARGS) -largs llvm-cbindings.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) `$(LLVM_CONFIG) --ldflags --libs --system-libs` -lc++ - -llvm-cbindings.o: ../../ortho/llvm/llvm-cbindings.cpp - $(CXX) -c -m64 `$(LLVM_CONFIG) --includedir --cxxflags` -g -o $@ $< - -ghdl_simul: default_pathes.ads $(GRT_ADD_OBJS) force - $(GNATMAKE) -aI../../simulate $(GNATFLAGS) ghdl_simul $(GNAT_BARGS) -largs $(GNAT_LARGS) $(GRT_ADD_OBJS) $(subst @,$(GRTSRCDIR),$(GRT_EXTRA_LIB)) - -ghdl_gcc: default_pathes.ads force - $(GNATMAKE) $(GNATFLAGS) ghdl_gcc $(GNAT_BARGS) -largs $(GNAT_LARGS) - -ghdl_llvm: default_pathes.ads force - $(GNATMAKE) $(GNATFLAGS) ghdl_llvm $(GNAT_BARGS) -largs $(GNAT_LARGS) - -default_pathes.ads: default_pathes.ads.in Makefile - curdir=`cd ..; pwd`; \ - sed -e "s%@COMPILER_GCC@%$$curdir/ghdl1-gcc%" \ - -e "s%@COMPILER_DEBUG@%$$curdir/ghdl1-debug%" \ - -e "s%@COMPILER_MCODE@%$$curdir/ghdl1-mcode%" \ - -e "s%@COMPILER_LLVM@%$$curdir/ghdl1-llvm%" \ - -e "s%@POST_PROCESSOR@%$$curdir/../ortho/oread/oread-gcc%" \ - -e "s%@INSTALL_PREFIX@%%" \ - -e "s%@LIB_PREFIX@%$$curdir/lib/%" < $< > $@ - -bootstrap.old: force - $(RM) ../../libraries/std-obj87.cf - $(MAKE) -C ../../libraries EXT=obj \ - ANALYSE="$(PWD)/ghdl -a -g" std-obj87.cf - $(RM) ../../libraries/std-obj93.cf - $(MAKE) -C ../../libraries EXT=obj \ - ANALYSE="$(PWD)/ghdl -a -g" std-obj93.cf - -LIB87_DIR:=../lib/v87 -LIB93_DIR:=../lib/v93 -LIB08_DIR:=../lib/v08 - -LIBSRC_DIR:=../../libraries -REL_DIR:=../.. -GHDL=ghdl -ANALYZE:=../../../ghdldrv/$(GHDL) -a $(LIB_CFLAGS) -LN=ln -s -CP=cp - -$(LIB87_DIR) $(LIB93_DIR) $(LIB08_DIR): - [ -d ../lib ] || mkdir ../lib - [ -d $@ ] || mkdir $@ - -include ../../libraries/Makefile.inc - -GHDL1=../ghdl1-gcc -$(LIB93_DIR)/std/std_standard.o: $(GHDL1) -ifeq ($(GHDL),ghdl_llvm) - $(GHDL1) --std=93 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard -else - $(GHDL1) --std=93 -quiet $(LIB_CFLAGS) -o std_standard.s \ - --compile-standard - $(CC) -c -o $@ std_standard.s - $(RM) std_standard.s -endif - -$(LIB87_DIR)/std/std_standard.o: $(GHDL1) -ifeq ($(GHDL),ghdl_llvm) - $(GHDL1) --std=87 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard -else - $(GHDL1) --std=87 -quiet $(LIB_CFLAGS) -o std_standard.s \ - --compile-standard - $(CC) -c -o $@ std_standard.s - $(RM) std_standard.s -endif - -$(LIB08_DIR)/std/std_standard.o: $(GHDL1) -ifeq ($(GHDL),ghdl_llvm) - $(GHDL1) --std=08 -quiet $(LIB_CFLAGS) -c -o $@ --compile-standard -else - $(GHDL1) --std=08 -quiet $(LIB_CFLAGS) -o std_standard.s \ - --compile-standard - $(CC) -c -o $@ std_standard.s - $(RM) std_standard.s -endif - -install.v93: std.v93 ieee.v93 synopsys.v93 mentor.v93 -install.v87: std.v87 ieee.v87 synopsys.v87 -install.v08: std.v08 ieee.v08 - -install.standard: $(LIB93_DIR)/std/std_standard.o \ - $(LIB87_DIR)/std/std_standard.o \ - $(LIB08_DIR)/std/std_standard.o - -grt.links: - cd ../lib; ln -sf $(GRTSRCDIR)/grt.lst .; ln -sf $(GRTSRCDIR)/libgrt.a .; ln -sf $(GRTSRCDIR)/grt.ver . - -install.all: install.v87 install.v93 install.v08 - -install.gcc: - $(MAKE) GHDL=ghdl_gcc install.all - $(MAKE) GHDL1=../ghdl1-gcc install.standard - -install.mcode: - $(MAKE) GHDL=ghdl_mcode install.all - -install.simul: - $(MAKE) GHDL=ghdl_simul install.all - -install.llvm: - $(MAKE) GHDL=ghdl_llvm install.all - $(MAKE) GHDL1=../ghdl1-llvm install.standard - -clean: force - $(RM) -f *.o *.ali ghdl_gcc ghdl_mcode ghdl_llvm ghdl_llvm_jit - $(RM) -f b~*.ad? *~ default_pathes.ads ghdl_simul - $(RM) -rf ../lib - -clean-c: force - $(RM) -f memsegs_c.o chkstk.o linux.o times.o grt-cbinding.o grt-cvpi.o - -force: - -.PHONY: force clean diff --git a/src/translate/ghdldrv/default_pathes.ads.in b/src/translate/ghdldrv/default_pathes.ads.in deleted file mode 100644 index 7f471a5ed..000000000 --- a/src/translate/ghdldrv/default_pathes.ads.in +++ /dev/null @@ -1,39 +0,0 @@ --- GHDL driver pathes -*- ada -*-. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -package Default_Pathes is - - -- Accept long lines. - pragma Style_Checks ("M999"); - - Install_Prefix : constant String := - "@INSTALL_PREFIX@"; - Lib_Prefix : constant String := - "@LIB_PREFIX@"; - - Compiler_Gcc : constant String := - "@COMPILER_GCC@"; - Compiler_Mcode : constant String := - "@COMPILER_MCODE@"; - Compiler_Llvm : constant String := - "@COMPILER_LLVM@"; - Compiler_Debug : constant String := - "@COMPILER_DEBUG@"; - Post_Processor : constant String := - "@POST_PROCESSOR@"; -end Default_Pathes; diff --git a/src/translate/ghdldrv/foreigns.adb b/src/translate/ghdldrv/foreigns.adb deleted file mode 100644 index 15e3dd009..000000000 --- a/src/translate/ghdldrv/foreigns.adb +++ /dev/null @@ -1,64 +0,0 @@ -with Interfaces.C; use Interfaces.C; - -package body Foreigns is - function Sin (Arg : double) return double; - pragma Import (C, Sin); - - function Log (Arg : double) return double; - pragma Import (C, Log); - - function Exp (Arg : double) return double; - pragma Import (C, Exp); - - function Sqrt (Arg : double) return double; - pragma Import (C, Sqrt); - - function Asin (Arg : double) return double; - pragma Import (C, Asin); - - function Acos (Arg : double) return double; - pragma Import (C, Acos); - - function Asinh (Arg : double) return double; - pragma Import (C, Asinh); - - function Acosh (Arg : double) return double; - pragma Import (C, Acosh); - - function Atanh (X : double) return double; - pragma Import (C, Atanh); - - function Atan2 (X, Y : double) return double; - pragma Import (C, Atan2); - - type String_Cacc is access constant String; - type Foreign_Record is record - Name : String_Cacc; - Addr : Address; - end record; - - - Foreign_Arr : constant array (Natural range <>) of Foreign_Record := - ( - (new String'("sin"), Sin'Address), - (new String'("log"), Log'Address), - (new String'("exp"), Exp'Address), - (new String'("sqrt"), Sqrt'Address), - (new String'("asin"), Asin'Address), - (new String'("acos"), Acos'Address), - (new String'("asinh"), Asinh'Address), - (new String'("acosh"), Acosh'Address), - (new String'("atanh"), Atanh'Address), - (new String'("atan2"), Atan2'Address) - ); - - function Find_Foreign (Name : String) return Address is - begin - for I in Foreign_Arr'Range loop - if Foreign_Arr(I).Name.all = Name then - return Foreign_Arr(I).Addr; - end if; - end loop; - return Null_Address; - end Find_Foreign; -end Foreigns; diff --git a/src/translate/ghdldrv/foreigns.ads b/src/translate/ghdldrv/foreigns.ads deleted file mode 100644 index 5759ae4f5..000000000 --- a/src/translate/ghdldrv/foreigns.ads +++ /dev/null @@ -1,5 +0,0 @@ -with System; use System; - -package Foreigns is - function Find_Foreign (Name : String) return Address; -end Foreigns; diff --git a/src/translate/ghdldrv/ghdl_gcc.adb b/src/translate/ghdldrv/ghdl_gcc.adb deleted file mode 100644 index 615a8c5d6..000000000 --- a/src/translate/ghdldrv/ghdl_gcc.adb +++ /dev/null @@ -1,34 +0,0 @@ --- GHDL driver for gcc. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ghdlmain; -with Ghdllocal; -with Ghdldrv; -with Ghdlprint; - -procedure Ghdl_Gcc is -begin - -- Manual elaboration so that the order is known (because it is the order - -- used to display help). - Ghdlmain.Version_String := new String'("GCC back-end code generator"); - Ghdldrv.Compile_Kind := Ghdldrv.Compile_Gcc; - Ghdldrv.Register_Commands; - Ghdllocal.Register_Commands; - Ghdlprint.Register_Commands; - Ghdlmain.Register_Commands; - Ghdlmain.Main; -end Ghdl_Gcc; diff --git a/src/translate/ghdldrv/ghdl_jit.adb b/src/translate/ghdldrv/ghdl_jit.adb deleted file mode 100644 index ba7087492..000000000 --- a/src/translate/ghdldrv/ghdl_jit.adb +++ /dev/null @@ -1,35 +0,0 @@ --- GHDL driver for jit. --- Copyright (C) 2002-2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ghdlmain; -with Ghdllocal; -with Ghdlprint; -with Ghdlrun; -with Ortho_Jit; - -procedure Ghdl_Jit is -begin - -- Manual elaboration so that the order is known (because it is the order - -- used to display help). - Ghdlmain.Version_String := - new String'(Ortho_Jit.Get_Jit_Name & " code generator"); - Ghdlrun.Register_Commands; - Ghdllocal.Register_Commands; - Ghdlprint.Register_Commands; - Ghdlmain.Register_Commands; - Ghdlmain.Main; -end Ghdl_Jit; diff --git a/src/translate/ghdldrv/ghdl_simul.adb b/src/translate/ghdldrv/ghdl_simul.adb deleted file mode 100644 index d4d0abd7a..000000000 --- a/src/translate/ghdldrv/ghdl_simul.adb +++ /dev/null @@ -1,33 +0,0 @@ --- GHDL driver for simulator. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ghdlmain; -with Ghdllocal; -with Ghdlprint; -with Ghdlsimul; - -procedure Ghdl_Simul is -begin - -- Manual elaboration so that the order is known (because it is the order - -- used to display help). - Ghdlmain.Version_String := new String'("interpretation"); - Ghdlsimul.Register_Commands; - Ghdllocal.Register_Commands; - Ghdlprint.Register_Commands; - Ghdlmain.Register_Commands; - Ghdlmain.Main; -end Ghdl_Simul; diff --git a/src/translate/ghdldrv/ghdlcomp.adb b/src/translate/ghdldrv/ghdlcomp.adb deleted file mode 100644 index ba755af8a..000000000 --- a/src/translate/ghdldrv/ghdlcomp.adb +++ /dev/null @@ -1,757 +0,0 @@ --- GHDL driver - compile commands. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ghdlmain; use Ghdlmain; -with Ghdllocal; use Ghdllocal; - -with Ada.Command_Line; -with Ada.Characters.Latin_1; -with Ada.Text_IO; - -with Types; -with Iirs; use Iirs; -with Nodes_GC; -with Flags; -with Back_End; -with Sem; -with Name_Table; -with Errorout; use Errorout; -with Libraries; -with Std_Package; -with Files_Map; -with Version; -with Default_Pathes; - -package body Ghdlcomp is - - Flag_Expect_Failure : Boolean := False; - - Flag_Debug_Nodes_Leak : Boolean := False; - -- If True, detect unreferenced nodes at the end of analysis. - - -- Commands which use the mcode compiler. - type Command_Comp is abstract new Command_Lib with null record; - procedure Decode_Option (Cmd : in out Command_Comp; - Option : String; - Arg : String; - Res : out Option_Res); - procedure Disp_Long_Help (Cmd : Command_Comp); - - procedure Decode_Option (Cmd : in out Command_Comp; - Option : String; - Arg : String; - Res : out Option_Res) - is - begin - if Option = "--expect-failure" then - Flag_Expect_Failure := True; - Res := Option_Ok; - elsif Option = "--debug-nodes-leak" then - Flag_Debug_Nodes_Leak := True; - Res := Option_Ok; - elsif Hooks.Decode_Option.all (Option) then - Res := Option_Ok; - else - Decode_Option (Command_Lib (Cmd), Option, Arg, Res); - end if; - end Decode_Option; - - - procedure Disp_Long_Help (Cmd : Command_Comp) - is - use Ada.Text_IO; - begin - Disp_Long_Help (Command_Lib (Cmd)); - Hooks.Disp_Long_Help.all; - Put_Line (" --expect-failure Expect analysis/elaboration failure"); - end Disp_Long_Help; - - -- Command -r - type Command_Run is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Run; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Run) return String; - - procedure Perform_Action (Cmd : in out Command_Run; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Run; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-r" or Name = "--elab-run"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Run) return String - is - pragma Unreferenced (Cmd); - begin - return "-r,--elab-run [OPTS] UNIT [ARCH] [RUNOPTS] Run UNIT"; - end Get_Short_Help; - - - procedure Perform_Action (Cmd : in out Command_Run; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - Opt_Arg : Natural; - begin - begin - Hooks.Compile_Init.all (False); - - Libraries.Load_Work_Library (False); - Flags.Flag_Elaborate_With_Outdated := False; - Flags.Flag_Only_Elab_Warnings := True; - - Hooks.Compile_Elab.all ("-r", Args, Opt_Arg); - exception - when Compilation_Error => - if Flag_Expect_Failure then - return; - else - raise; - end if; - end; - Hooks.Set_Run_Options (Args (Opt_Arg .. Args'Last)); - Hooks.Run.all; - end Perform_Action; - - - -- Command -c xx -r - type Command_Compile is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Compile; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Compile) return String; - procedure Decode_Option (Cmd : in out Command_Compile; - Option : String; - Arg : String; - Res : out Option_Res); - procedure Perform_Action (Cmd : in out Command_Compile; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Compile; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-c"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Compile) return String - is - pragma Unreferenced (Cmd); - begin - return "-c [OPTS] FILEs -r UNIT [ARCH] [RUNOPTS] " - & "Compile, elaborate and run UNIT"; - end Get_Short_Help; - - procedure Decode_Option (Cmd : in out Command_Compile; - Option : String; - Arg : String; - Res : out Option_Res) - is - begin - if Option = "-r" or else Option = "-e" then - Res := Option_End; - else - Decode_Option (Command_Comp (Cmd), Option, Arg, Res); - end if; - end Decode_Option; - - procedure Perform_Action (Cmd : in out Command_Compile; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - Elab_Arg : Natural; - Run_Arg : Natural; - begin - begin - Hooks.Compile_Init.all (False); - - Flags.Flag_Elaborate_With_Outdated := True; - Flags.Flag_Only_Elab_Warnings := False; - - if Args'Length > 1 and then - (Args (Args'First).all = "-r" or else Args (Args'First).all = "-e") - then - -- If there is no files, then load the work library. - Libraries.Load_Work_Library (False); - -- Also, load all libraries and files, so that every design unit - -- is known. - Load_All_Libraries_And_Files; - Elab_Arg := Args'First + 1; - else - -- If there is at least one file, do not load the work library. - Libraries.Load_Work_Library (True); - Elab_Arg := Natural'Last; - for I in Args'Range loop - declare - Arg : constant String := Args (I).all; - Res : Iir_Design_File; - Design : Iir; - Next_Design : Iir; - begin - if Arg = "-r" or else Arg = "-e" then - Elab_Arg := I + 1; - exit; - else - Res := Libraries.Load_File - (Name_Table.Get_Identifier (Arg)); - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - -- Put units into library. - Design := Get_First_Design_Unit (Res); - while not Is_Null (Design) loop - Next_Design := Get_Chain (Design); - Set_Chain (Design, Null_Iir); - Libraries.Add_Design_Unit_Into_Library (Design); - Design := Next_Design; - end loop; - end if; - end; - end loop; - if Elab_Arg = Natural'Last then - Libraries.Save_Work_Library; - return; - end if; - end if; - - Hooks.Compile_Elab.all ("-c", Args (Elab_Arg .. Args'Last), Run_Arg); - exception - when Compilation_Error => - if Flag_Expect_Failure then - return; - else - raise; - end if; - end; - if Args (Elab_Arg - 1).all = "-r" then - Hooks.Set_Run_Options (Args (Run_Arg .. Args'Last)); - Hooks.Run.all; - else - if Run_Arg <= Args'Last then - Error_Msg_Option ("options after unit are ignored"); - end if; - end if; - end Perform_Action; - - -- Command -a - type Command_Analyze is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Analyze; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Analyze) return String; - - procedure Perform_Action (Cmd : in out Command_Analyze; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Analyze; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-a"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Analyze) return String - is - pragma Unreferenced (Cmd); - begin - return "-a [OPTS] FILEs Analyze FILEs"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Analyze; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Types; - Id : Name_Id; - Design_File : Iir_Design_File; - New_Design_File : Iir_Design_File; - Unit : Iir; - Next_Unit : Iir; - begin - Setup_Libraries (True); - - Hooks.Compile_Init.all (True); - - -- Parse all files. - for I in Args'Range loop - Id := Name_Table.Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if False then - -- Speed up analysis: remove all previous designs. - -- However, this is not in the LRM... - Libraries.Purge_Design_File (Design_File); - end if; - - if Design_File /= Null_Iir then - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - Back_End.Finish_Compilation (Unit, True); - - Next_Unit := Get_Chain (Unit); - - if Errorout.Nbr_Errors = 0 then - Set_Chain (Unit, Null_Iir); - Libraries.Add_Design_Unit_Into_Library (Unit); - New_Design_File := Get_Design_File (Unit); - end if; - - Unit := Next_Unit; - end loop; - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - Free_Iir (Design_File); - - -- Do late analysis checks. - Unit := Get_First_Design_Unit (New_Design_File); - while Unit /= Null_Iir loop - Sem.Sem_Analysis_Checks_List (Unit, Flags.Warn_Delayed_Checks); - Unit := Get_Chain (Unit); - end loop; - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - end if; - end loop; - - if Flag_Expect_Failure then - raise Compilation_Error; - end if; - - if Flag_Debug_Nodes_Leak then - Nodes_GC.Report_Unreferenced; - end if; - - Libraries.Save_Work_Library; - - exception - when Compilation_Error => - if Flag_Expect_Failure and Errorout.Nbr_Errors /= 0 then - return; - else - raise; - end if; - end Perform_Action; - - -- Command -e - type Command_Elab is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Elab; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Elab) return String; - procedure Decode_Option (Cmd : in out Command_Elab; - Option : String; - Arg : String; - Res : out Option_Res); - - procedure Perform_Action (Cmd : in out Command_Elab; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Elab; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-e"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Elab) return String - is - pragma Unreferenced (Cmd); - begin - return "-e [OPTS] UNIT [ARCH] Elaborate UNIT"; - end Get_Short_Help; - - procedure Decode_Option (Cmd : in out Command_Elab; - Option : String; - Arg : String; - Res : out Option_Res) - is - begin - if Option = "--expect-failure" then - Flag_Expect_Failure := True; - Res := Option_Ok; - elsif Option = "-o" then - if Arg'Length = 0 then - Res := Option_Arg_Req; - else - -- Silently accepted. - Res := Option_Arg; - end if; - --elsif Option'Length >= 4 and then Option (1 .. 4) = "-Wl," then - -- Res := Option_Ok; - else - Decode_Option (Command_Lib (Cmd), Option, Arg, Res); - end if; - end Decode_Option; - - procedure Perform_Action (Cmd : in out Command_Elab; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - Run_Arg : Natural; - begin - Hooks.Compile_Init.all (False); - - Libraries.Load_Work_Library (False); - Flags.Flag_Elaborate_With_Outdated := False; - Flags.Flag_Only_Elab_Warnings := True; - - Hooks.Compile_Elab.all ("-e", Args, Run_Arg); - if Run_Arg <= Args'Last then - Error_Msg_Option ("options after unit are ignored"); - end if; - if Flag_Expect_Failure then - raise Compilation_Error; - end if; - exception - when Compilation_Error => - if Flag_Expect_Failure and then Errorout.Nbr_Errors > 0 then - return; - else - raise; - end if; - end Perform_Action; - - -- Command dispconfig. - type Command_Dispconfig is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Dispconfig; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Dispconfig) return String; - procedure Perform_Action (Cmd : in out Command_Dispconfig; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Dispconfig; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--dispconfig"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Dispconfig) return String - is - pragma Unreferenced (Cmd); - begin - return "--dispconfig Disp tools path"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Dispconfig; - Args : Argument_List) - is - use Ada.Text_IO; - use Libraries; - pragma Unreferenced (Cmd); - begin - if Args'Length /= 0 then - Error ("--dispconfig does not accept any argument"); - raise Errorout.Option_Error; - end if; - - Put ("command line prefix (--PREFIX): "); - if Prefix_Path = null then - Put_Line ("(not set)"); - else - Put_Line (Prefix_Path.all); - end if; - Setup_Libraries (False); - - Put ("environment prefix (GHDL_PREFIX): "); - if Prefix_Env = null then - Put_Line ("(not set)"); - else - Put_Line (Prefix_Env.all); - end if; - - Put_Line ("default prefix: " & Default_Pathes.Prefix); - Put_Line ("actual prefix: " & Prefix_Path.all); - Put_Line ("command_name: " & Ada.Command_Line.Command_Name); - Put_Line ("default library pathes:"); - for I in 2 .. Get_Nbr_Pathes loop - Put (' '); - Put_Line (Name_Table.Image (Get_Path (I))); - end loop; - end Perform_Action; - - -- Command Make. - type Command_Make is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Make; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Make) return String; - procedure Perform_Action (Cmd : in out Command_Make; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Make; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-m"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Make) return String - is - pragma Unreferenced (Cmd); - begin - return "-m [OPTS] UNIT [ARCH] Make UNIT"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Types; - - Files_List : Iir_List; - File : Iir_Design_File; - - Next_Arg : Natural; - Date : Date_Type; - Unit : Iir_Design_Unit; - begin - Extract_Elab_Unit ("-m", Args, Next_Arg); - Setup_Libraries (True); - - -- Create list of files. - Files_List := Build_Dependence (Prim_Name, Sec_Name); - - Date := Get_Date (Libraries.Work_Library); - for I in Natural loop - File := Get_Nth_Element (Files_List, I); - exit when File = Null_Iir; - - if Get_Library (File) = Libraries.Work_Library then - -- Mark this file as analyzed. - Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp); - - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - if Get_Date (Unit) = Date_Analyzed - or else Get_Date (Unit) in Date_Valid - then - Date := Date + 1; - Set_Date (Unit, Date); - end if; - Unit := Get_Chain (Unit); - end loop; - end if; - end loop; - Set_Date (Libraries.Work_Library, Date); - Libraries.Save_Work_Library; - exception - when Compilation_Error => - if Flag_Expect_Failure then - return; - else - raise; - end if; - end Perform_Action; - - -- Command Gen_Makefile. - type Command_Gen_Makefile is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Gen_Makefile) return String; - procedure Perform_Action (Cmd : in out Command_Gen_Makefile; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--gen-makefile"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Gen_Makefile) return String - is - pragma Unreferenced (Cmd); - begin - return "--gen-makefile [OPTS] UNIT [ARCH] Generate a Makefile for UNIT"; - end Get_Short_Help; - - function Is_Makeable_File (File : Iir_Design_File) return Boolean is - begin - if File = Std_Package.Std_Standard_File then - return False; - end if; - return True; - end Is_Makeable_File; - - procedure Perform_Action (Cmd : in out Command_Gen_Makefile; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Types; - use Ada.Text_IO; - use Ada.Command_Line; - use Name_Table; - - HT : constant Character := Ada.Characters.Latin_1.HT; - Files_List : Iir_List; - File : Iir_Design_File; - - Lib : Iir_Library_Declaration; - Dir_Id : Name_Id; - - Next_Arg : Natural; - begin - Extract_Elab_Unit ("--gen-makefile", Args, Next_Arg); - Setup_Libraries (True); - Files_List := Build_Dependence (Prim_Name, Sec_Name); - - Put_Line ("# Makefile automatically generated by ghdl"); - Put ("# Version: "); - Put (Version.Ghdl_Release); - Put (" - "); - if Version_String /= null then - Put (Version_String.all); - end if; - New_Line; - Put_Line ("# Command used to generate this makefile:"); - Put ("# "); - Put (Command_Name); - for I in 1 .. Argument_Count loop - Put (' '); - Put (Argument (I)); - end loop; - New_Line; - - New_Line; - - Put ("GHDL="); - Put_Line (Command_Name); - - -- Extract options for command line. - Put ("GHDLFLAGS="); - for I in 2 .. Argument_Count loop - declare - Arg : constant String := Argument (I); - begin - if Arg (1) = '-' then - if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=") - or else (Arg'Length > 7 and then Arg (1 .. 7) = "--ieee=") - or else (Arg'Length > 6 and then Arg (1 .. 6) = "--std=") - or else (Arg'Length > 7 and then Arg (1 .. 7) = "--work=") - or else (Arg'Length > 2 and then Arg (1 .. 2) = "-P") - then - Put (" "); - Put (Arg); - end if; - end if; - end; - end loop; - New_Line; - - Put ("GHDLRUNFLAGS="); - for I in Next_Arg .. Args'Last loop - Put (' '); - Put (Args (I).all); - end loop; - New_Line; - New_Line; - - Put_Line ("# Default target : elaborate"); - Put_Line ("all : elab"); - New_Line; - - Put_Line ("# Elaborate target. Almost useless"); - Put_Line ("elab : force"); - Put (HT & "$(GHDL) -c $(GHDLFLAGS) -e "); - Put (Prim_Name.all); - if Sec_Name /= null then - Put (' '); - Put (Sec_Name.all); - end if; - New_Line; - New_Line; - - Put_Line ("# Run target"); - Put_Line ("run : force"); - Put (HT & "$(GHDL) -c $(GHDLFLAGS) -r "); - Put (Prim_Name.all); - if Sec_Name /= null then - Put (' '); - Put (Sec_Name.all); - end if; - Put (" $(GHDLRUNFLAGS)"); - New_Line; - New_Line; - - Put_Line ("# Targets to analyze libraries"); - Put_Line ("init: force"); - for I in Natural loop - File := Get_Nth_Element (Files_List, I); - exit when File = Null_Iir; - Dir_Id := Get_Design_File_Directory (File); - if not Is_Makeable_File (File) then - -- Builtin file. - null; - elsif Dir_Id /= Files_Map.Get_Home_Directory then - -- Not locally built file. - Put (HT & "# "); - Put (Image (Dir_Id)); - Put (Image (Get_Design_File_Filename (File))); - New_Line; - else - - Put (HT & "$(GHDL) -a $(GHDLFLAGS)"); - Lib := Get_Library (File); - if Lib /= Libraries.Work_Library then - -- Overwrite some options. - Put (" --work="); - Put (Image (Get_Identifier (Lib))); - Dir_Id := Get_Library_Directory (Lib); - Put (" --workdir="); - if Dir_Id = Libraries.Local_Directory then - Put ("."); - else - Put (Image (Dir_Id)); - end if; - end if; - Put (' '); - Put (Image (Get_Design_File_Filename (File))); - New_Line; - end if; - end loop; - New_Line; - - Put_Line ("force:"); - end Perform_Action; - - procedure Register_Commands is - begin - Register_Command (new Command_Analyze); - Register_Command (new Command_Elab); - Register_Command (new Command_Run); - Register_Command (new Command_Compile); - Register_Command (new Command_Make); - Register_Command (new Command_Gen_Makefile); - Register_Command (new Command_Dispconfig); - end Register_Commands; - -end Ghdlcomp; diff --git a/src/translate/ghdldrv/ghdlcomp.ads b/src/translate/ghdldrv/ghdlcomp.ads deleted file mode 100644 index f803ca4fa..000000000 --- a/src/translate/ghdldrv/ghdlcomp.ads +++ /dev/null @@ -1,67 +0,0 @@ --- GHDL driver - compile commands. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with GNAT.OS_Lib; use GNAT.OS_Lib; - -package Ghdlcomp is - -- This procedure is called at start of commands which call - -- finish_compilation to generate code. - type Compile_Init_Acc is access procedure (Analyze_Only : Boolean); - - -- This procedure is called for elaboration. - -- CMD_NAME is the name of the command, used to report errors. - -- ARGS is the argument list, starting from the unit name to be elaborated. - -- The procedure should extract the unit. - -- OPT_ARG is the index of the first argument from ARGS to be used as - -- a run option. - type Compile_Elab_Acc is access procedure - (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural); - - -- Use ARGS as run options. - -- Should do all the work. - type Set_Run_Options_Acc is access - procedure (Args : Argument_List); - - -- Run the simulation. - -- All the parameters were set through calling Compile_Elab and - -- Set_Run_Options. - type Run_Acc is access procedure; - - -- Called when an analysis/elaboration option is decoded. - -- Return True if OPTION is known (and do the side effects). - -- No parameters are allowed. - type Decode_Option_Acc is access function (Option : String) return Boolean; - - -- Disp help for options decoded by Decode_Option. - type Disp_Long_Help_Acc is access procedure; - - -- All the hooks gathered. - -- A record is used to be sure all hooks are set. - type Hooks_Type is record - Compile_Init : Compile_Init_Acc := null; - Compile_Elab : Compile_Elab_Acc := null; - Set_Run_Options : Set_Run_Options_Acc := null; - Run : Run_Acc := null; - Decode_Option : Decode_Option_Acc := null; - Disp_Long_Help : Disp_Long_Help_Acc := null; - end record; - - Hooks : Hooks_Type; - - -- Register commands. - procedure Register_Commands; -end Ghdlcomp; diff --git a/src/translate/ghdldrv/ghdldrv.adb b/src/translate/ghdldrv/ghdldrv.adb deleted file mode 100644 index be905f1af..000000000 --- a/src/translate/ghdldrv/ghdldrv.adb +++ /dev/null @@ -1,1818 +0,0 @@ --- GHDL driver - commands invoking gcc. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Characters.Latin_1; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Table; -with GNAT.Dynamic_Tables; -with Libraries; -with Name_Table; use Name_Table; -with Std_Package; -with Types; use Types; -with Iirs; use Iirs; -with Files_Map; -with Flags; -with Configuration; ---with Disp_Tree; -with Default_Pathes; -with Interfaces.C_Streams; -with System; -with Ghdlmain; use Ghdlmain; -with Ghdllocal; use Ghdllocal; -with Errorout; -with Version; -with Options; - -package body Ghdldrv is - -- Name of the tools used. - Compiler_Cmd : String_Access := null; - Post_Processor_Cmd : String_Access := null; - Assembler_Cmd : constant String := "as"; - Linker_Cmd : constant String := "gcc"; - - -- Path of the tools. - Compiler_Path : String_Access; - Post_Processor_Path : String_Access; - Assembler_Path : String_Access; - Linker_Path : String_Access; - - -- Set by the '-o' option: the output filename. If the option is not - -- present, then null. - Output_File : String_Access; - - -- "-o" string. - Dash_o : constant String_Access := new String'("-o"); - - -- "-c" string. - Dash_c : constant String_Access := new String'("-c"); - - -- "-quiet" option. - Dash_Quiet : constant String_Access := new String'("-quiet"); - - -- If set, do not assmble - Flag_Asm : Boolean; - - -- If true, executed commands are displayed. - Flag_Disp_Commands : Boolean; - - -- Flag not quiet - Flag_Not_Quiet : Boolean; - - -- True if failure expected. - Flag_Expect_Failure : Boolean; - - -- Argument table for the tools. - -- Each table low bound is 1 so that the length of a table is equal to - -- the last bound. - package Argument_Table_Pkg is new GNAT.Dynamic_Tables - (Table_Component_Type => String_Access, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 4, - Table_Increment => 100); - use Argument_Table_Pkg; - - -- Arguments for tools. - Compiler_Args : Argument_Table_Pkg.Instance; - Postproc_Args : Argument_Table_Pkg.Instance; - Assembler_Args : Argument_Table_Pkg.Instance; - Linker_Args : Argument_Table_Pkg.Instance; - - -- Display the program spawned in Flag_Disp_Commands is TRUE. - -- Raise COMPILE_ERROR in case of failure. - procedure My_Spawn (Program_Name : String; Args : Argument_List) - is - Status : Integer; - begin - if Flag_Disp_Commands then - Put (Program_Name); - for I in Args'Range loop - Put (' '); - Put (Args (I).all); - end loop; - New_Line; - end if; - Status := Spawn (Program_Name, Args); - if Status = 0 then - return; - elsif Status = 1 then - Error ("compilation error"); - raise Compile_Error; - elsif Status > 127 then - Error ("executable killed by a signal"); - raise Exec_Error; - else - Error ("exec error"); - raise Exec_Error; - end if; - end My_Spawn; - - -- Compile FILE with additional argument OPTS. - procedure Do_Compile (Options : Argument_List; File : String) - is - Obj_File : String_Access; - Asm_File : String_Access; - Post_File : String_Access; - Success : Boolean; - begin - -- Create post file. - case Compile_Kind is - when Compile_Debug => - Post_File := Append_Suffix (File, Post_Suffix); - when others => - null; - end case; - - -- Create asm file. - case Compile_Kind is - when Compile_Gcc - | Compile_Debug => - Asm_File := Append_Suffix (File, Asm_Suffix); - when Compile_Llvm - | Compile_Mcode => - null; - end case; - - -- Create obj file (may not be used, but the condition isn't simple). - Obj_File := Append_Suffix (File, Get_Object_Suffix.all); - - -- Compile. - declare - P : Natural; - Nbr_Args : constant Natural := - Last (Compiler_Args) + Options'Length + 4; - Args : Argument_List (1 .. Nbr_Args); - begin - P := 0; - for I in First .. Last (Compiler_Args) loop - P := P + 1; - Args (P) := Compiler_Args.Table (I); - end loop; - for I in Options'Range loop - P := P + 1; - Args (P) := Options (I); - end loop; - - -- Add -quiet. - case Compile_Kind is - when Compile_Gcc => - if not Flag_Not_Quiet then - P := P + 1; - Args (P) := Dash_Quiet; - end if; - when Compile_Llvm => - P := P + 1; - Args (P) := Dash_c; - when Compile_Debug - | Compile_Mcode => - null; - end case; - - Args (P + 1) := Dash_o; - case Compile_Kind is - when Compile_Debug => - Args (P + 2) := Post_File; - when Compile_Gcc => - Args (P + 2) := Asm_File; - when Compile_Mcode - | Compile_Llvm => - Args (P + 2) := Obj_File; - end case; - Args (P + 3) := new String'(File); - - My_Spawn (Compiler_Path.all, Args (1 .. P + 3)); - Free (Args (P + 3)); - exception - when Compile_Error => - -- Delete temporary file in case of error. - Delete_File (Args (P + 2).all, Success); - -- FIXME: delete object file too ? - raise; - end; - - -- Post-process. - if Compile_Kind = Compile_Debug then - declare - P : Natural; - Nbr_Args : constant Natural := Last (Postproc_Args) + 4; - Args : Argument_List (1 .. Nbr_Args); - begin - P := 0; - for I in First .. Last (Postproc_Args) loop - P := P + 1; - Args (P) := Postproc_Args.Table (I); - end loop; - - if not Flag_Not_Quiet then - P := P + 1; - Args (P) := Dash_Quiet; - end if; - - Args (P + 1) := Dash_o; - Args (P + 2) := Asm_File; - Args (P + 3) := Post_File; - My_Spawn (Post_Processor_Path.all, Args (1 .. P + 3)); - end; - - Free (Post_File); - end if; - - -- Assemble. - if Compile_Kind >= Compile_Gcc then - if Flag_Expect_Failure then - Delete_File (Asm_File.all, Success); - elsif not Flag_Asm then - declare - P : Natural; - Nbr_Args : constant Natural := Last (Assembler_Args) + 4; - Args : Argument_List (1 .. Nbr_Args); - Success : Boolean; - begin - P := 0; - for I in First .. Last (Assembler_Args) loop - P := P + 1; - Args (P) := Assembler_Args.Table (I); - end loop; - - Args (P + 1) := Dash_o; - Args (P + 2) := Obj_File; - Args (P + 3) := Asm_File; - My_Spawn (Assembler_Path.all, Args (1 .. P + 3)); - Delete_File (Asm_File.all, Success); - end; - end if; - end if; - - Free (Asm_File); - Free (Obj_File); - end Do_Compile; - - package Filelist is new GNAT.Table - (Table_Component_Type => String_Access, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 16, - Table_Increment => 100); - - Link_Obj_Suffix : String_Access; - - -- Read a list of files from file FILENAME. - -- Lines starting with a '#' are ignored (comments) - -- Lines starting with a '>' are directory lines - -- If first character of a line is a '@', it is replaced with - -- the lib_prefix_path. - -- If TO_OBJ is true, then each file is converted to an object file name - -- (suffix is replaced by the object file extension). - procedure Add_File_List (Filename : String; To_Obj : Boolean) - is - use Interfaces.C_Streams; - use System; - use Ada.Characters.Latin_1; - - -- Replace the first '@' with the machine path. - function Substitute (Str : String) return String - is - begin - for I in Str'Range loop - if Str (I) = '@' then - return Str (Str'First .. I - 1) - & Get_Machine_Path_Prefix - & Str (I + 1 .. Str'Last); - end if; - end loop; - return Str; - end Substitute; - - Dir : String (1 .. max_path_len); - Dir_Len : Natural; - Line : String (1 .. max_path_len); - Stream : Interfaces.C_Streams.FILEs; - Mode : constant String := "rt" & Ghdllocal.Nul; - L : Natural; - File : String_Access; - begin - Line (1 .. Filename'Length) := Filename; - Line (Filename'Length + 1) := Ghdllocal.Nul; - Stream := fopen (Line'Address, Mode'Address); - if Stream = NULL_Stream then - Error ("cannot open " & Filename); - raise Compile_Error; - end if; - Dir_Len := 0; - loop - exit when fgets (Line'Address, Line'Length, Stream) = NULL_Stream; - if Line (1) /= '#' then - -- Compute string length. - L := 0; - while Line (L + 1) /= Ghdllocal.Nul loop - L := L + 1; - end loop; - - -- Remove trailing NL. - while L > 0 and then (Line (L) = LF or Line (L) = CR) loop - L := L - 1; - end loop; - - if Line (1) = '>' then - Dir_Len := L - 1; - Dir (1 .. Dir_Len) := Line (2 .. L); - else - if To_Obj then - File := new String'(Dir (1 .. Dir_Len) - & Get_Base_Name (Line (1 .. L)) - & Link_Obj_Suffix.all); - else - File := new String'(Substitute (Line (1 .. L))); - end if; - - Filelist.Increment_Last; - Filelist.Table (Filelist.Last) := File; - - Dir_Len := 0; - end if; - end if; - end loop; - if fclose (Stream) /= 0 then - Error ("cannot close " & Filename); - end if; - end Add_File_List; - - function Get_Object_Filename (File : Iir_Design_File) return String - is - Dir : Name_Id; - Name : Name_Id; - begin - Dir := Get_Library_Directory (Get_Library (File)); - Name := Get_Design_File_Filename (File); - return Image (Dir) & Get_Base_Name (Image (Name)) - & Get_Object_Suffix.all; - end Get_Object_Filename; - - Last_Stamp : Time_Stamp_Id; - Last_Stamp_File : Iir; - - function Is_File_Outdated (Design_File : Iir_Design_File) return Boolean - is - use Files_Map; - - Name : Name_Id; - - File : Source_File_Entry; - begin - -- Std.Standard is never outdated. - if Design_File = Std_Package.Std_Standard_File then - return False; - end if; - - Name := Get_Design_File_Filename (Design_File); - declare - Obj_Pathname : String := Get_Object_Filename (Design_File) & Nul; - Stamp : Time_Stamp_Id; - begin - Stamp := Get_File_Time_Stamp (Obj_Pathname'Address); - - -- If the object file does not exist, recompile the file. - if Stamp = Null_Time_Stamp then - if Flag_Verbose then - Put_Line ("no object file for " & Image (Name)); - end if; - return True; - end if; - - -- Keep the time stamp of the most recently analyzed unit. - if Last_Stamp = Null_Time_Stamp - or else Is_Gt (Stamp, Last_Stamp) - then - Last_Stamp := Stamp; - Last_Stamp_File := Design_File; - end if; - end; - - -- 2) file has been modified. - File := Load_Source_File (Get_Design_File_Directory (Design_File), - Get_Design_File_Filename (Design_File)); - if not Is_Eq (Get_File_Time_Stamp (File), - Get_File_Time_Stamp (Design_File)) - then - if Flag_Verbose then - Put_Line ("file " & Image (Get_File_Name (File)) - & " has been modified"); - end if; - return True; - end if; - - return False; - end Is_File_Outdated; - - function Is_Unit_Outdated (Unit : Iir_Design_Unit) return Boolean - is - Design_File : Iir_Design_File; - begin - -- Std.Standard is never outdated. - if Unit = Std_Package.Std_Standard_Unit then - return False; - end if; - - Design_File := Get_Design_File (Unit); - - -- 1) not yet analyzed: - if Get_Date (Unit) not in Date_Valid then - if Flag_Verbose then - Disp_Library_Unit (Get_Library_Unit (Unit)); - Put_Line (" was not analyzed"); - end if; - return True; - end if; - - -- 3) the object file does not exist. - -- Already checked. - - -- 4) one of the dependence is newer - declare - Depends : Iir_List; - El : Iir; - Dep : Iir_Design_Unit; - Stamp : Time_Stamp_Id; - Dep_File : Iir_Design_File; - begin - Depends := Get_Dependence_List (Unit); - Stamp := Get_Analysis_Time_Stamp (Design_File); - if Depends /= Null_Iir_List then - for I in Natural loop - El := Get_Nth_Element (Depends, I); - exit when El = Null_Iir; - Dep := Libraries.Find_Design_Unit (El); - if Dep = Null_Iir then - if Flag_Verbose then - Disp_Library_Unit (Unit); - Put (" depends on an unknown unit "); - Disp_Library_Unit (El); - New_Line; - end if; - return True; - end if; - Dep_File := Get_Design_File (Dep); - if Dep /= Std_Package.Std_Standard_Unit - and then Files_Map.Is_Gt (Get_Analysis_Time_Stamp (Dep_File), - Stamp) - then - if Flag_Verbose then - Disp_Library_Unit (Get_Library_Unit (Unit)); - Put (" depends on: "); - Disp_Library_Unit (Get_Library_Unit (Dep)); - Put (" (more recently analyzed)"); - New_Line; - end if; - return True; - end if; - end loop; - end if; - end; - - return False; - end Is_Unit_Outdated; - - procedure Add_Argument (Inst : in out Instance; Arg : String_Access) - is - begin - Increment_Last (Inst); - Inst.Table (Last (Inst)) := Arg; - end Add_Argument; - - -- Convert option "-Wx,OPTIONS" to arguments for tool X. - procedure Add_Arguments (Inst : in out Instance; Opt : String) is - begin - Add_Argument (Inst, new String'(Opt (Opt'First + 4 .. Opt'Last))); - end Add_Arguments; - - procedure Tool_Not_Found (Name : String) is - begin - Error ("installation problem: " & Name & " not found"); - raise Option_Error; - end Tool_Not_Found; - - -- Set the compiler command according to the configuration (and swicthes). - procedure Set_Tools_Name is - begin - -- Set tools name. - if Compiler_Cmd = null then - case Compile_Kind is - when Compile_Debug => - Compiler_Cmd := new String'(Default_Pathes.Compiler_Debug); - when Compile_Gcc => - Compiler_Cmd := new String'(Default_Pathes.Compiler_Gcc); - when Compile_Mcode => - Compiler_Cmd := new String'(Default_Pathes.Compiler_Mcode); - when Compile_Llvm => - Compiler_Cmd := new String'(Default_Pathes.Compiler_Llvm); - end case; - end if; - if Post_Processor_Cmd = null then - Post_Processor_Cmd := new String'(Default_Pathes.Post_Processor); - end if; - end Set_Tools_Name; - - function Locate_Exec_Tool (Toolname : String) return String_Access is - begin - if Is_Absolute_Path (Toolname) then - if Is_Executable_File (Toolname) then - return new String'(Toolname); - end if; - else - -- Try from install prefix - if Exec_Prefix /= null then - declare - Path : constant String := - Exec_Prefix.all & Directory_Separator & Toolname; - begin - if Is_Executable_File (Path) then - return new String'(Path); - end if; - end; - end if; - - -- Try configured prefix - declare - Path : constant String := - Default_Pathes.Install_Prefix & Directory_Separator & Toolname; - begin - if Is_Executable_File (Path) then - return new String'(Path); - end if; - end; - end if; - - -- Search the basename on path. - declare - Pos : constant Natural := Get_Basename_Pos (Toolname); - begin - if Pos = 0 then - return Locate_Exec_On_Path (Toolname); - else - return Locate_Exec_On_Path (Toolname (Pos .. Toolname'Last)); - end if; - end; - end Locate_Exec_Tool; - - procedure Locate_Tools is - begin - Compiler_Path := Locate_Exec_Tool (Compiler_Cmd.all); - if Compiler_Path = null then - Tool_Not_Found (Compiler_Cmd.all); - end if; - if Compile_Kind >= Compile_Debug then - Post_Processor_Path := Locate_Exec_Tool (Post_Processor_Cmd.all); - if Post_Processor_Path = null then - Tool_Not_Found (Post_Processor_Cmd.all); - end if; - end if; - if Compile_Kind >= Compile_Gcc then - Assembler_Path := Locate_Exec_On_Path (Assembler_Cmd); - if Assembler_Path = null and not Flag_Asm then - Tool_Not_Found (Assembler_Cmd); - end if; - end if; - Linker_Path := Locate_Exec_On_Path (Linker_Cmd); - if Linker_Path = null then - Tool_Not_Found (Linker_Cmd); - end if; - end Locate_Tools; - - procedure Setup_Compiler (Load : Boolean) - is - use Libraries; - begin - Set_Tools_Name; - Setup_Libraries (Load); - Locate_Tools; - for I in 2 .. Get_Nbr_Pathes loop - Add_Argument (Compiler_Args, - new String'("-P" & Image (Get_Path (I)))); - end loop; - end Setup_Compiler; - - type Command_Comp is abstract new Command_Lib with null record; - - -- Setup GHDL. - procedure Init (Cmd : in out Command_Comp); - - -- Handle: - -- all ghdl flags. - -- some GCC flags. - procedure Decode_Option (Cmd : in out Command_Comp; - Option : String; - Arg : String; - Res : out Option_Res); - - procedure Disp_Long_Help (Cmd : Command_Comp); - - procedure Init (Cmd : in out Command_Comp) - is - begin - -- Init options. - Flag_Not_Quiet := False; - Flag_Disp_Commands := False; - Flag_Asm := False; - Flag_Expect_Failure := False; - Output_File := null; - - -- Initialize argument tables. - Init (Compiler_Args); - Init (Postproc_Args); - Init (Assembler_Args); - Init (Linker_Args); - Init (Command_Lib (Cmd)); - end Init; - - procedure Decode_Option (Cmd : in out Command_Comp; - Option : String; - Arg : String; - Res : out Option_Res) - is - Str : String_Access; - Opt : constant String (1 .. Option'Length) := Option; - begin - Res := Option_Bad; - if Opt = "-v" and then Flag_Verbose = False then - -- Note: this is also decoded for command_lib, but we set - -- Flag_Disp_Commands too. - Flag_Verbose := True; - --Flags.Verbose := True; - Flag_Disp_Commands := True; - Res := Option_Ok; - elsif Opt'Length > 8 and then Opt (1 .. 8) = "--GHDL1=" then - Compiler_Cmd := new String'(Opt (9 .. Opt'Last)); - Res := Option_Ok; - elsif Opt = "-S" then - Flag_Asm := True; - Res := Option_Ok; - elsif Opt = "--post" then - Compile_Kind := Compile_Debug; - Res := Option_Ok; - elsif Opt = "--mcode" then - Compile_Kind := Compile_Mcode; - Res := Option_Ok; - elsif Opt = "--llvm" then - Compile_Kind := Compile_Llvm; - Res := Option_Ok; - elsif Opt = "-o" then - if Arg'Length = 0 then - Res := Option_Arg_Req; - else - Output_File := new String'(Arg); - Res := Option_Arg; - end if; - elsif Opt = "-m32" then - Add_Argument (Compiler_Args, new String'("-m32")); - Add_Argument (Assembler_Args, new String'("--32")); - Add_Argument (Linker_Args, new String'("-m32")); - Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); - elsif Opt'Length > 4 - and then Opt (2) = 'W' and then Opt (4) = ',' - then - if Opt (3) = 'c' then - Add_Arguments (Compiler_Args, Opt); - elsif Opt (3) = 'a' then - Add_Arguments (Assembler_Args, Opt); - elsif Opt (3) = 'p' then - Add_Arguments (Postproc_Args, Opt); - elsif Opt (3) = 'l' then - Add_Arguments (Linker_Args, Opt); - else - Error ("unknown tool name in '-W" & Opt (3) & ",' option"); - raise Option_Error; - end if; - Res := Option_Ok; - elsif Opt'Length >= 2 and then Opt (2) = 'g' then - -- Debugging option. - Str := new String'(Opt); - Add_Argument (Compiler_Args, Str); - Add_Argument (Linker_Args, Str); - Res := Option_Ok; - elsif Opt = "-Q" then - Flag_Not_Quiet := True; - Res := Option_Ok; - elsif Opt = "--expect-failure" then - Add_Argument (Compiler_Args, new String'(Opt)); - Flag_Expect_Failure := True; - Res := Option_Ok; - elsif Opt = "-C" then - -- Translate -C into --mb-comments, as gcc already has a definition - -- for -C. Done before Flags.Parse_Option. - Add_Argument (Compiler_Args, new String'("--mb-comments")); - Res := Option_Ok; - elsif Options.Parse_Option (Opt) then - Add_Argument (Compiler_Args, new String'(Opt)); - Res := Option_Ok; - elsif Opt'Length >= 2 - and then (Opt (2) = 'O' or Opt (2) = 'f') - then - -- Optimization option. - -- This is put after Flags.Parse_Option, since it may catch -fxxx - -- options. - Add_Argument (Compiler_Args, new String'(Opt)); - Res := Option_Ok; - else - Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); - end if; - end Decode_Option; - - procedure Disp_Long_Help (Cmd : Command_Comp) is - begin - Disp_Long_Help (Command_Lib (Cmd)); - Put_Line (" -v Be verbose"); - Put_Line (" --GHDL1=PATH Set the path of the ghdl1 compiler"); - Put_Line (" -S Do not assemble"); - Put_Line (" -o FILE Set the name of the output file"); - -- Put_Line (" -m32 Generate 32bit code on 64bit machines"); - Put_Line (" -WX,OPTION Pass OPTION to X, where X is one of"); - Put_Line (" c: compiler, a: assembler, l: linker"); - Put_Line (" -g[XX] Pass debugging option to the compiler"); - Put_Line (" -O[XX]/-f[XX] Pass optimization option to the compiler"); - Put_Line (" -Q Do not add -quiet option to compiler"); - Put_Line (" --expect-failure Expect analysis/elaboration failure"); - end Disp_Long_Help; - - -- Command dispconfig. - type Command_Dispconfig is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Dispconfig; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Dispconfig) return String; - procedure Perform_Action (Cmd : in out Command_Dispconfig; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Dispconfig; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--dispconfig" or else Name = "--disp-config"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Dispconfig) return String - is - pragma Unreferenced (Cmd); - begin - return "--disp-config Disp tools path"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Dispconfig; - Args : Argument_List) - is - use Libraries; - pragma Unreferenced (Cmd); - begin - if Args'Length /= 0 then - Error ("--dispconfig does not accept any argument"); - raise Option_Error; - end if; - - Set_Tools_Name; - Put_Line ("Pathes at configuration:"); - Put ("compiler command: "); - Put_Line (Compiler_Cmd.all); - if Compile_Kind >= Compile_Debug then - Put ("post-processor command: "); - Put_Line (Post_Processor_Cmd.all); - end if; - if Compile_Kind >= Compile_Gcc then - Put ("assembler command: "); - Put_Line (Assembler_Cmd); - end if; - Put ("linker command: "); - Put_Line (Linker_Cmd); - Put_Line ("default lib prefix: " & Default_Pathes.Lib_Prefix); - - New_Line; - - Put ("command line prefix (--PREFIX): "); - if Switch_Prefix_Path = null then - Put_Line ("(not set)"); - else - Put_Line (Switch_Prefix_Path.all); - end if; - - Put ("environment prefix (GHDL_PREFIX): "); - if Prefix_Env = null then - Put_Line ("(not set)"); - else - Put_Line (Prefix_Env.all); - end if; - - Setup_Libraries (False); - - Put ("exec prefix (from program name): "); - if Exec_Prefix = null then - Put_Line ("(not found)"); - else - Put_Line (Exec_Prefix.all); - end if; - - New_Line; - - Put_Line ("library prefix: " & Lib_Prefix_Path.all); - Put ("library directory: "); - Put_Line (Get_Machine_Path_Prefix); - Locate_Tools; - Put ("compiler path: "); - Put_Line (Compiler_Path.all); - if Compile_Kind >= Compile_Debug then - Put ("post-processor path: "); - Put_Line (Post_Processor_Path.all); - end if; - if Compile_Kind >= Compile_Gcc then - Put ("assembler path: "); - Put_Line (Assembler_Path.all); - end if; - Put ("linker path: "); - Put_Line (Linker_Path.all); - - New_Line; - - Put_Line ("default library pathes:"); - for I in 2 .. Get_Nbr_Pathes loop - Put (' '); - Put_Line (Image (Get_Path (I))); - end loop; - end Perform_Action; - - -- Command Analyze. - type Command_Analyze is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Analyze; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Analyze) return String; - procedure Perform_Action (Cmd : in out Command_Analyze; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Analyze; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-a"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Analyze) return String - is - pragma Unreferenced (Cmd); - begin - return "-a [OPTS] FILEs Analyze FILEs"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Analyze; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - Nil_Opt : Argument_List (2 .. 1); - begin - if Args'Length = 0 then - Error ("no file to analyze"); - raise Option_Error; - end if; - Setup_Compiler (False); - - for I in Args'Range loop - Do_Compile (Nil_Opt, Args (I).all); - end loop; - end Perform_Action; - - -- Elaboration. - - Base_Name : String_Access; - Elab_Name : String_Access; - Filelist_Name : String_Access; - Unit_Name : String_Access; - - procedure Set_Elab_Units (Cmd_Name : String; - Args : Argument_List; - Run_Arg : out Natural) - is - begin - Extract_Elab_Unit (Cmd_Name, Args, Run_Arg); - if Sec_Name = null then - Base_Name := Prim_Name; - Unit_Name := Prim_Name; - else - Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all); - Unit_Name := new String'(Prim_Name.all & '(' & Sec_Name.all & ')'); - end if; - - Elab_Name := new String'(Elab_Prefix & Base_Name.all); - Filelist_Name := null; - - if Output_File = null then - Output_File := new String'(Base_Name.all); - end if; - end Set_Elab_Units; - - procedure Set_Elab_Units (Cmd_Name : String; Args : Argument_List) - is - Next_Arg : Natural; - begin - Set_Elab_Units (Cmd_Name, Args, Next_Arg); - if Next_Arg <= Args'Last then - Error ("too many unit names for command '" & Cmd_Name & "'"); - raise Option_Error; - end if; - end Set_Elab_Units; - - procedure Bind - is - Comp_List : Argument_List (1 .. 4); - begin - Filelist_Name := new String'(Elab_Name.all & List_Suffix); - - Comp_List (1) := new String'("--elab"); - Comp_List (2) := Unit_Name; - Comp_List (3) := new String'("-l"); - Comp_List (4) := Filelist_Name; - Do_Compile (Comp_List, Elab_Name.all); - Free (Comp_List (3)); - Free (Comp_List (1)); - end Bind; - - procedure Bind_Anaelab (Files : Argument_List) - is - Comp_List : Argument_List (1 .. Files'Length + 2); - Index : Natural; - begin - Comp_List (1) := new String'("--anaelab"); - Comp_List (2) := Unit_Name; - Index := 3; - for I in Files'Range loop - Comp_List (Index) := new String'("--ghdl-source=" & Files (I).all); - Index := Index + 1; - end loop; - Do_Compile (Comp_List, Elab_Name.all); - Free (Comp_List (1)); - for I in 3 .. Comp_List'Last loop - Free (Comp_List (I)); - end loop; - end Bind_Anaelab; - - procedure Link (Add_Std : Boolean; - Disp_Only : Boolean) - is - Last_File : Natural; - begin - Link_Obj_Suffix := Get_Object_Suffix; - - -- read files list - if Filelist_Name /= null then - Add_File_List (Filelist_Name.all, True); - end if; - Last_File := Filelist.Last; - Add_File_List (Get_Machine_Path_Prefix & "grt" & List_Suffix, False); - - -- call the linker - declare - P : Natural; - Nbr_Args : constant Natural := Last (Linker_Args) + Filelist.Last + 4; - Args : Argument_List (1 .. Nbr_Args); - Obj_File : String_Access; - Std_File : String_Access; - begin - Obj_File := Append_Suffix (Elab_Name.all, Link_Obj_Suffix.all); - P := 0; - Args (P + 1) := Dash_o; - Args (P + 2) := Output_File; - Args (P + 3) := Obj_File; - P := P + 3; - if Add_Std then - Std_File := new - String'(Get_Machine_Path_Prefix - & Get_Version_Path & Directory_Separator - & "std" & Directory_Separator - & "std_standard" & Link_Obj_Suffix.all); - P := P + 1; - Args (P) := Std_File; - else - Std_File := null; - end if; - - -- Object files of the design. - for I in Filelist.First .. Last_File loop - P := P + 1; - Args (P) := Filelist.Table (I); - end loop; - -- User added options. - for I in First .. Last (Linker_Args) loop - P := P + 1; - Args (P) := Linker_Args.Table (I); - end loop; - -- GRT files (should be the last one, since it contains an - -- optional main). - for I in Last_File + 1 .. Filelist.Last loop - P := P + 1; - Args (P) := Filelist.Table (I); - end loop; - - if Disp_Only then - for I in 3 .. P loop - Put_Line (Args (I).all); - end loop; - else - My_Spawn (Linker_Path.all, Args (1 .. P)); - end if; - - Free (Obj_File); - Free (Std_File); - end; - - for I in Filelist.First .. Filelist.Last loop - Free (Filelist.Table (I)); - end loop; - end Link; - - -- Command Elab. - type Command_Elab is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Elab; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Elab) return String; - procedure Perform_Action (Cmd : in out Command_Elab; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Elab; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-e"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Elab) return String - is - pragma Unreferenced (Cmd); - begin - return "-e [OPTS] UNIT [ARCH] Elaborate UNIT"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Elab; Args : Argument_List) - is - pragma Unreferenced (Cmd); - Success : Boolean; - pragma Unreferenced (Success); - begin - Set_Elab_Units ("-e", Args); - Setup_Compiler (False); - - Bind; - if not Flag_Expect_Failure then - Link (Add_Std => True, Disp_Only => False); - end if; - Delete_File (Filelist_Name.all, Success); - end Perform_Action; - - -- Command Run. - type Command_Run is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Run; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Run) return String; - procedure Perform_Action (Cmd : in out Command_Run; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Run; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-r"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Run) return String - is - pragma Unreferenced (Cmd); - begin - return "-r UNIT [ARCH] [OPTS] Run UNIT"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Run; Args : Argument_List) - is - pragma Unreferenced (Cmd); - Opt_Arg : Natural; - begin - Extract_Elab_Unit ("-r", Args, Opt_Arg); - if Sec_Name = null then - Base_Name := Prim_Name; - else - Base_Name := new String'(Prim_Name.all & '-' & Sec_Name.all); - end if; - if not Is_Regular_File (Base_Name.all & Nul) then - Error ("file '" & Base_Name.all & "' does not exists"); - Error ("Please elaborate your design."); - raise Exec_Error; - end if; - My_Spawn ('.' & Directory_Separator & Base_Name.all, - Args (Opt_Arg .. Args'Last)); - end Perform_Action; - - -- Command Elab_Run. - type Command_Elab_Run is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Elab_Run; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Elab_Run) return String; - procedure Perform_Action (Cmd : in out Command_Elab_Run; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Elab_Run; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--elab-run"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Elab_Run) return String - is - pragma Unreferenced (Cmd); - begin - return "--elab-run [OPTS] UNIT [ARCH] [OPTS] Elaborate and run UNIT"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Elab_Run; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - Success : Boolean; - Run_Arg : Natural; - begin - Set_Elab_Units ("-elab-run", Args, Run_Arg); - Setup_Compiler (False); - - Bind; - if Flag_Expect_Failure then - Delete_File (Filelist_Name.all, Success); - else - Link (Add_Std => True, Disp_Only => False); - Delete_File (Filelist_Name.all, Success); - My_Spawn ('.' & Directory_Separator & Output_File.all, - Args (Run_Arg .. Args'Last)); - end if; - end Perform_Action; - - -- Command Bind. - type Command_Bind is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Bind; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Bind) return String; - procedure Perform_Action (Cmd : in out Command_Bind; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Bind; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--bind"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Bind) return String - is - pragma Unreferenced (Cmd); - begin - return "--bind [OPTS] UNIT [ARCH] Bind UNIT"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Bind; Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - Set_Elab_Units ("--bind", Args); - Setup_Compiler (False); - - Bind; - end Perform_Action; - - -- Command Link. - type Command_Link is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Link; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Link) return String; - procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List); - - function Decode_Command (Cmd : Command_Link; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--link"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Link) return String - is - pragma Unreferenced (Cmd); - begin - return "--link [OPTS] UNIT [ARCH] Link UNIT"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Link; Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - Set_Elab_Units ("--link", Args); - Setup_Compiler (False); - - Filelist_Name := new String'(Elab_Name.all & List_Suffix); - Link (Add_Std => True, Disp_Only => False); - end Perform_Action; - - - -- Command List_Link. - type Command_List_Link is new Command_Comp with null record; - function Decode_Command (Cmd : Command_List_Link; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_List_Link) return String; - procedure Perform_Action (Cmd : in out Command_List_Link; - Args : Argument_List); - - function Decode_Command (Cmd : Command_List_Link; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--list-link"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_List_Link) return String - is - pragma Unreferenced (Cmd); - begin - return "--list-link [OPTS] UNIT [ARCH] List objects file to link UNIT"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_List_Link; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - Set_Elab_Units ("--list-link", Args); - Setup_Compiler (False); - - Filelist_Name := new String'(Elab_Name.all & List_Suffix); - Link (Add_Std => True, Disp_Only => True); - end Perform_Action; - - - -- Command analyze and elaborate - type Command_Anaelab is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Anaelab; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Anaelab) return String; - procedure Decode_Option (Cmd : in out Command_Anaelab; - Option : String; - Arg : String; - Res : out Option_Res); - - procedure Perform_Action (Cmd : in out Command_Anaelab; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Anaelab; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-c"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Anaelab) return String - is - pragma Unreferenced (Cmd); - begin - return "-c [OPTS] FILEs -e UNIT [ARCH] " - & "Generate whole code to elab UNIT from FILEs"; - end Get_Short_Help; - - procedure Decode_Option (Cmd : in out Command_Anaelab; - Option : String; - Arg : String; - Res : out Option_Res) - is - begin - if Option = "-e" then - Res := Option_End; - return; - else - Decode_Option (Command_Comp (Cmd), Option, Arg, Res); - end if; - end Decode_Option; - - procedure Perform_Action (Cmd : in out Command_Anaelab; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - Elab_Index : Integer; - begin - Elab_Index := -1; - for I in Args'Range loop - if Args (I).all = "-e" then - Elab_Index := I; - exit; - end if; - end loop; - if Elab_Index < 0 then - Analyze_Files (Args, True); - else - Flags.Flag_Whole_Analyze := True; - Set_Elab_Units ("-c", Args (Elab_Index + 1 .. Args'Last)); - Setup_Compiler (False); - - Bind_Anaelab (Args (Args'First .. Elab_Index - 1)); - Link (Add_Std => False, Disp_Only => False); - end if; - end Perform_Action; - - -- Command Make. - type Command_Make is new Command_Comp with record - -- Disp dependences during make. - Flag_Depend_Unit : Boolean; - - -- Force recompilation of units in work library. - Flag_Force : Boolean; - end record; - - function Decode_Command (Cmd : Command_Make; Name : String) - return Boolean; - procedure Init (Cmd : in out Command_Make); - procedure Decode_Option (Cmd : in out Command_Make; - Option : String; - Arg : String; - Res : out Option_Res); - - function Get_Short_Help (Cmd : Command_Make) return String; - procedure Disp_Long_Help (Cmd : Command_Make); - - procedure Perform_Action (Cmd : in out Command_Make; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Make; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-m"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Make) return String - is - pragma Unreferenced (Cmd); - begin - return "-m [OPTS] UNIT [ARCH] Make UNIT"; - end Get_Short_Help; - - procedure Disp_Long_Help (Cmd : Command_Make) - is - begin - Disp_Long_Help (Command_Comp (Cmd)); - Put_Line (" -f Force recompilation of work units"); - Put_Line (" -Mu Disp unit dependences (human format)"); - end Disp_Long_Help; - - procedure Init (Cmd : in out Command_Make) is - begin - Init (Command_Comp (Cmd)); - Cmd.Flag_Depend_Unit := False; - Cmd.Flag_Force := False; - end Init; - - procedure Decode_Option (Cmd : in out Command_Make; - Option : String; - Arg : String; - Res : out Option_Res) is - begin - if Option = "-Mu" then - Cmd.Flag_Depend_Unit := True; - Res := Option_Ok; - elsif Option = "-f" then - Cmd.Flag_Force := True; - Res := Option_Ok; - else - Decode_Option (Command_Comp (Cmd), Option, Arg, Res); - end if; - end Decode_Option; - - procedure Perform_Action (Cmd : in out Command_Make; Args : Argument_List) - is - use Configuration; - - File : Iir_Design_File; - Unit : Iir; - Lib_Unit : Iir; - Lib : Iir_Library_Declaration; - In_Work : Boolean; - - Files_List : Iir_List; - - -- Set when a design file has been compiled. - Has_Compiled : Boolean; - - Need_Analyze : Boolean; - - Need_Elaboration : Boolean; - - Stamp : Time_Stamp_Id; - File_Id : Name_Id; - - Nil_Args : Argument_List (2 .. 1); - Success : Boolean; - begin - Set_Elab_Units ("-m", Args); - Setup_Compiler (True); - - -- Create list of files. - Files_List := Build_Dependence (Prim_Name, Sec_Name); - - if Cmd.Flag_Depend_Unit then - Put_Line ("Units analysis order:"); - for I in Design_Units.First .. Design_Units.Last loop - Unit := Design_Units.Table (I); - Put (" "); - Disp_Library_Unit (Get_Library_Unit (Unit)); - New_Line; --- Put (" file: "); --- File := Get_Design_File (Unit); --- Image (Get_Design_File_Filename (File)); --- Put_Line (Name_Buffer (1 .. Name_Length)); - end loop; - end if; - if Cmd.Flag_Depend_Unit then - Put_Line ("File analysis order:"); - for I in Natural loop - File := Get_Nth_Element (Files_List, I); - exit when File = Null_Iir; - Image (Get_Design_File_Filename (File)); - Put (" "); - Put (Name_Buffer (1 .. Name_Length)); - if Flag_Verbose then - Put_Line (":"); - declare - Dep_List : Iir_List; - Dep_File : Iir; - begin - Dep_List := Get_File_Dependence_List (File); - if Dep_List /= Null_Iir_List then - for J in Natural loop - Dep_File := Get_Nth_Element (Dep_List, J); - exit when Dep_File = Null_Iir; - Image (Get_Design_File_Filename (Dep_File)); - Put (" "); - Put_Line (Name_Buffer (1 .. Name_Length)); - end loop; - end if; - end; - else - New_Line; - end if; - end loop; - end if; - - Has_Compiled := False; - Last_Stamp := Null_Time_Stamp; - - for I in Natural loop - File := Get_Nth_Element (Files_List, I); - exit when File = Null_Iir; - - Need_Analyze := False; - if Is_File_Outdated (File) then - Need_Analyze := True; - else - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - Lib_Unit := Get_Library_Unit (Unit); - if not (Get_Kind (Lib_Unit) = Iir_Kind_Configuration_Declaration - and then Get_Identifier (Lib_Unit) = Null_Identifier) - then - if Is_Unit_Outdated (Unit) then - Need_Analyze := True; - exit; - end if; - end if; - Unit := Get_Chain (Unit); - end loop; - end if; - - Lib := Get_Library (File); - In_Work := Lib = Libraries.Work_Library; - - if Need_Analyze or else (Cmd.Flag_Force and In_Work) then - File_Id := Get_Design_File_Filename (File); - if not Flag_Verbose then - Put ("analyze "); - Put (Image (File_Id)); - --Disp_Library_Unit (Get_Library_Unit (Unit)); - New_Line; - end if; - - if In_Work then - Do_Compile (Nil_Args, Image (File_Id)); - else - declare - use Libraries; - Lib_Args : Argument_List (1 .. 2); - Prev_Workdir : Name_Id; - begin - Prev_Workdir := Work_Directory; - - -- Must be set, since used to build the object filename. - Work_Directory := Get_Library_Directory (Lib); - - -- Always overwrite --work and --workdir. - Lib_Args (1) := new String' - ("--work=" & Image (Get_Identifier (Lib))); - if Work_Directory = Libraries.Local_Directory then - Lib_Args (2) := new String'("--workdir=."); - else - Lib_Args (2) := new String' - ("--workdir=" & Image (Work_Directory)); - end if; - Do_Compile (Lib_Args, Image (File_Id)); - - Work_Directory := Prev_Workdir; - - Free (Lib_Args (1)); - Free (Lib_Args (2)); - end; - end if; - - Has_Compiled := True; - -- Set the analysis time stamp since the file has just been - -- analyzed. - Set_Analysis_Time_Stamp (File, Files_Map.Get_Os_Time_Stamp); - end if; - end loop; - - Need_Elaboration := False; - -- Elaboration. - -- if libgrt is more recent than the executable (FIXME). - if Has_Compiled then - if Flag_Verbose then - Put_Line ("link due to a file compilation"); - end if; - Need_Elaboration := True; - else - declare - Exec_File : String := Output_File.all & Nul; - begin - Stamp := Files_Map.Get_File_Time_Stamp (Exec_File'Address); - end; - - if Stamp = Null_Time_Stamp then - if Flag_Verbose then - Put_Line ("link due to no binary file"); - end if; - Need_Elaboration := True; - else - if Files_Map.Is_Gt (Last_Stamp, Stamp) then - -- if a file is more recent than the executable. - if Flag_Verbose then - Put ("link due to outdated binary file: "); - Put (Image (Get_Design_File_Filename (Last_Stamp_File))); - Put (" ("); - Put (Files_Map.Get_Time_Stamp_String (Last_Stamp)); - Put (" > "); - Put (Files_Map.Get_Time_Stamp_String (Stamp)); - Put (")"); - New_Line; - end if; - Need_Elaboration := True; - end if; - end if; - end if; - if Need_Elaboration then - if not Flag_Verbose then - Put ("elaborate "); - Put (Prim_Name.all); - --Disp_Library_Unit (Get_Library_Unit (Unit)); - New_Line; - end if; - Bind; - Link (Add_Std => True, Disp_Only => False); - Delete_File (Filelist_Name.all, Success); - end if; - exception - when Errorout.Compilation_Error => - if Flag_Expect_Failure then - return; - else - raise; - end if; - end Perform_Action; - - -- Command Gen_Makefile. - type Command_Gen_Makefile is new Command_Comp with null record; - function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Gen_Makefile) return String; - procedure Perform_Action (Cmd : in out Command_Gen_Makefile; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Gen_Makefile; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--gen-makefile"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Gen_Makefile) return String - is - pragma Unreferenced (Cmd); - begin - return "--gen-makefile [OPTS] UNIT [ARCH] Generate a Makefile for UNIT"; - end Get_Short_Help; - - function Is_Makeable_File (File : Iir_Design_File) return Boolean is - begin - if File = Std_Package.Std_Standard_File then - return False; - end if; - return True; - end Is_Makeable_File; - - procedure Perform_Action (Cmd : in out Command_Gen_Makefile; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - - HT : constant Character := Ada.Characters.Latin_1.HT; - Files_List : Iir_List; - File : Iir_Design_File; - - Lib : Iir_Library_Declaration; - Dir_Id : Name_Id; - - Dep_List : Iir_List; - Dep_File : Iir; - begin - Set_Elab_Units ("--gen-makefile", Args); - Setup_Libraries (True); - Files_List := Build_Dependence (Prim_Name, Sec_Name); - - Put_Line ("# Makefile automatically generated by ghdl"); - Put ("# Version: "); - Put (Version.Ghdl_Release); - Put (" - "); - if Version_String /= null then - Put (Version_String.all); - end if; - New_Line; - Put_Line ("# Command used to generate this makefile:"); - Put ("# "); - Put (Command_Name); - for I in 1 .. Argument_Count loop - Put (' '); - Put (Argument (I)); - end loop; - New_Line; - - New_Line; - - Put ("GHDL="); - Put_Line (Command_Name); - - -- Extract options for command line. - Put ("GHDLFLAGS="); - for I in 2 .. Argument_Count loop - declare - Arg : constant String := Argument (I); - begin - if Arg (1) = '-' then - if (Arg'Length > 10 and then Arg (1 .. 10) = "--workdir=") - or else (Arg'Length > 7 and then Arg (1 .. 7) = "--ieee=") - or else (Arg'Length > 6 and then Arg (1 .. 6) = "--std=") - or else (Arg'Length > 7 and then Arg (1 .. 7) = "--work=") - or else (Arg'Length > 2 and then Arg (1 .. 2) = "-P") - then - Put (" "); - Put (Arg); - end if; - end if; - end; - end loop; - New_Line; - - New_Line; - - Put_Line ("# Default target"); - Put ("all: "); - Put_Line (Base_Name.all); - New_Line; - - Put_Line ("# Elaboration target"); - Put (Base_Name.all); - Put (":"); - for I in Natural loop - File := Get_Nth_Element (Files_List, I); - exit when File = Null_Iir; - if Is_Makeable_File (File) then - Put (" "); - Put (Get_Object_Filename (File)); - end if; - end loop; - New_Line; - Put_Line (HT & "$(GHDL) -e $(GHDLFLAGS) $@"); - New_Line; - - Put_Line ("# Run target"); - Put_Line ("run: " & Base_Name.all); - Put_Line (HT & "$(GHDL) -r " & Base_Name.all & " $(GHDLRUNFLAGS)"); - New_Line; - - Put_Line ("# Targets to analyze files"); - for I in Natural loop - File := Get_Nth_Element (Files_List, I); - exit when File = Null_Iir; - Dir_Id := Get_Design_File_Directory (File); - if not Is_Makeable_File (File) then - -- Builtin file. - null; - else - Put (Get_Object_Filename (File)); - Put (": "); - if Dir_Id /= Files_Map.Get_Home_Directory then - Put (Image (Dir_Id)); - Put (Image (Get_Design_File_Filename (File))); - New_Line; - - Put_Line - (HT & "@echo ""This file was not locally built ($<)"""); - Put_Line (HT & "exit 1"); - else - Put (Image (Get_Design_File_Filename (File))); - New_Line; - - Put (HT & "$(GHDL) -a $(GHDLFLAGS)"); - Lib := Get_Library (File); - if Lib /= Libraries.Work_Library then - -- Overwrite some options. - Put (" --work="); - Put (Image (Get_Identifier (Lib))); - Dir_Id := Get_Library_Directory (Lib); - Put (" --workdir="); - if Dir_Id = Libraries.Local_Directory then - Put ("."); - else - Put (Image (Dir_Id)); - end if; - end if; - Put_Line (" $<"); - end if; - end if; - end loop; - New_Line; - - Put_Line ("# Files dependences"); - for I in Natural loop - File := Get_Nth_Element (Files_List, I); - exit when File = Null_Iir; - if Is_Makeable_File (File) then - Put (Get_Object_Filename (File)); - Put (": "); - Dep_List := Get_File_Dependence_List (File); - if Dep_List /= Null_Iir_List then - for J in Natural loop - Dep_File := Get_Nth_Element (Dep_List, J); - exit when Dep_File = Null_Iir; - if Dep_File /= File and then Is_Makeable_File (Dep_File) - then - Put (" "); - Put (Get_Object_Filename (Dep_File)); - end if; - end loop; - end if; - New_Line; - end if; - end loop; - end Perform_Action; - - procedure Register_Commands is - begin - Register_Command (new Command_Analyze); - Register_Command (new Command_Elab); - Register_Command (new Command_Run); - Register_Command (new Command_Elab_Run); - Register_Command (new Command_Bind); - Register_Command (new Command_Link); - Register_Command (new Command_List_Link); - Register_Command (new Command_Anaelab); - Register_Command (new Command_Make); - Register_Command (new Command_Gen_Makefile); - Register_Command (new Command_Dispconfig); - end Register_Commands; -end Ghdldrv; diff --git a/src/translate/ghdldrv/ghdldrv.ads b/src/translate/ghdldrv/ghdldrv.ads deleted file mode 100644 index 3e37b38f1..000000000 --- a/src/translate/ghdldrv/ghdldrv.ads +++ /dev/null @@ -1,25 +0,0 @@ --- GHDL driver - commands invoking gcc. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package Ghdldrv is - -- Compiler to use. - type Compile_Kind_Type is - (Compile_Mcode, Compile_Llvm, Compile_Gcc, Compile_Debug); - Compile_Kind : Compile_Kind_Type := Compile_Gcc; - - procedure Register_Commands; -end Ghdldrv; diff --git a/src/translate/ghdldrv/ghdllocal.adb b/src/translate/ghdldrv/ghdllocal.adb deleted file mode 100644 index a1d94bd77..000000000 --- a/src/translate/ghdldrv/ghdllocal.adb +++ /dev/null @@ -1,1415 +0,0 @@ --- GHDL driver - local commands. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Text_IO; -with Ada.Command_Line; use Ada.Command_Line; -with GNAT.Directory_Operations; -with Types; use Types; -with Libraries; -with Std_Package; -with Flags; -with Name_Table; -with Std_Names; -with Back_End; -with Disp_Vhdl; -with Default_Pathes; -with Scanner; -with Sem; -with Canon; -with Errorout; -with Configuration; -with Files_Map; -with Post_Sems; -with Disp_Tree; -with Options; -with Iirs_Utils; use Iirs_Utils; - -package body Ghdllocal is - -- Version of the IEEE library to use. This just change pathes. - type Ieee_Lib_Kind is (Lib_Standard, Lib_None, Lib_Synopsys, Lib_Mentor); - Flag_Ieee : Ieee_Lib_Kind; - - Flag_Create_Default_Config : constant Boolean := True; - - -- If TRUE, generate 32bits code on 64bits machines. - Flag_32bit : Boolean := False; - - procedure Finish_Compilation - (Unit : Iir_Design_Unit; Main : Boolean := False) - is - use Errorout; - use Ada.Text_IO; - Config : Iir_Design_Unit; - Lib : Iir; - begin - if (Main or Flags.Dump_All) and then Flags.Dump_Parse then - Disp_Tree.Disp_Tree (Unit); - end if; - - if Flags.Verbose then - Put_Line ("semantize " & Disp_Node (Get_Library_Unit (Unit))); - end if; - - Sem.Semantic (Unit); - - if (Main or Flags.Dump_All) and then Flags.Dump_Sem then - Disp_Tree.Disp_Tree (Unit); - end if; - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if (Main or Flags.List_All) and then Flags.List_Sem then - Disp_Vhdl.Disp_Vhdl (Unit); - end if; - - Post_Sems.Post_Sem_Checks (Unit); - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if Flags.Flag_Elaborate then - if Flags.Verbose then - Put_Line ("canonicalize " & Disp_Node (Get_Library_Unit (Unit))); - end if; - - Canon.Canonicalize (Unit); - - if Flag_Create_Default_Config then - Lib := Get_Library_Unit (Unit); - if Get_Kind (Lib) = Iir_Kind_Architecture_Body then - Config := Canon.Create_Default_Configuration_Declaration (Lib); - Set_Default_Configuration_Declaration (Lib, Config); - end if; - end if; - end if; - end Finish_Compilation; - - procedure Init (Cmd : in out Command_Lib) - is - pragma Unreferenced (Cmd); - begin - Options.Initialize; - Flag_Ieee := Lib_Standard; - Back_End.Finish_Compilation := Finish_Compilation'Access; - Flag_Verbose := False; - end Init; - - procedure Decode_Option (Cmd : in out Command_Lib; - Option : String; - Arg : String; - Res : out Option_Res) - is - pragma Unreferenced (Cmd); - pragma Unreferenced (Arg); - Opt : constant String (1 .. Option'Length) := Option; - begin - Res := Option_Bad; - if Opt = "-v" and then Flag_Verbose = False then - Flag_Verbose := True; - Res := Option_Ok; - elsif Opt'Length > 9 and then Opt (1 .. 9) = "--PREFIX=" then - Switch_Prefix_Path := new String'(Opt (10 .. Opt'Last)); - Res := Option_Ok; - elsif Opt = "--ieee=synopsys" then - Flag_Ieee := Lib_Synopsys; - Res := Option_Ok; - elsif Opt = "--ieee=mentor" then - Flag_Ieee := Lib_Mentor; - Res := Option_Ok; - elsif Opt = "--ieee=none" then - Flag_Ieee := Lib_None; - Res := Option_Ok; - elsif Opt = "--ieee=standard" then - Flag_Ieee := Lib_Standard; - Res := Option_Ok; - elsif Opt = "-m32" then - Flag_32bit := True; - Res := Option_Ok; - elsif Opt'Length >= 2 - and then (Opt (2) = 'g' or Opt (2) = 'O') - then - -- Silently accept -g and -O. - Res := Option_Ok; - else - if Options.Parse_Option (Opt) then - Res := Option_Ok; - end if; - end if; - end Decode_Option; - - procedure Disp_Long_Help (Cmd : Command_Lib) - is - pragma Unreferenced (Cmd); - use Ada.Text_IO; - procedure P (Str : String) renames Put_Line; - begin - P ("Main options (try --options-help for details):"); - P (" --std=XX Use XX as VHDL standard (87,93c,93,00 or 02)"); - P (" --work=NAME Set the name of the WORK library"); - P (" -PDIR Add DIR in the library search path"); - P (" --workdir=DIR Specify the directory of the WORK library"); - P (" --PREFIX=DIR Specify installation prefix"); - P (" --ieee=NAME Use NAME as ieee library, where name is:"); - P (" standard: standard version (default)"); - P (" synopsys, mentor: vendor version (not advised)"); - P (" none: do not use a predefined ieee library"); - end Disp_Long_Help; - - function Is_Directory_Separator (C : Character) return Boolean is - begin - return C = '/' or else C = Directory_Separator; - end Is_Directory_Separator; - - function Get_Basename_Pos (Pathname : String) return Natural is - begin - for I in reverse Pathname'Range loop - if Is_Directory_Separator (Pathname (I)) then - return I; - end if; - end loop; - return 0; - end Get_Basename_Pos; - - procedure Set_Prefix_From_Program_Path (Prog_Path : String) - is - Dir_Pos : Natural; - begin - Dir_Pos := Get_Basename_Pos (Prog_Path); - if Dir_Pos = 0 then - -- No directory in Prog_Path. This is not expected. - return; - end if; - - declare - Pathname : String := - Normalize_Pathname (Prog_Path (Dir_Pos + 1 .. Prog_Path'Last), - Prog_Path (Prog_Path'First .. Dir_Pos - 1)); - Pos : Natural; - begin - -- Stop now in case of error. - if Pathname'Length = 0 then - return; - end if; - - -- Skip executable name - Dir_Pos := Get_Basename_Pos (Pathname); - if Dir_Pos = 0 then - return; - end if; - - -- Simplify path: - -- /./ => / - -- // => / - Pos := Dir_Pos - 1; - while Pos >= Pathname'First loop - if Is_Directory_Separator (Pathname (Pos)) then - if Is_Directory_Separator (Pathname (Pos + 1)) then - -- // => / - Pathname (Pos .. Dir_Pos - 1) := - Pathname (Pos + 1 .. Dir_Pos); - Dir_Pos := Dir_Pos - 1; - elsif Pos + 2 <= Dir_Pos - and then Pathname (Pos + 1) = '.' - and then Is_Directory_Separator (Pathname (Pos + 2)) - then - -- /./ => / - Pathname (Pos .. Dir_Pos - 2) := - Pathname (Pos + 2 .. Dir_Pos); - Dir_Pos := Dir_Pos - 2; - end if; - end if; - Pos := Pos - 1; - end loop; - - -- Simplify path: - -- /xxx/../ => / - -- This is done after the previous simplication to avoid to deal - -- with cases like /xxx//../ or /xxx/./../ - Pos := Dir_Pos - 3; - while Pos >= Pathname'First loop - if Is_Directory_Separator (Pathname (Pos)) - and then Pathname (Pos + 1) = '.' - and then Pathname (Pos + 2) = '.' - and then Is_Directory_Separator (Pathname (Pos + 3)) - then - declare - Pos2 : constant Natural := - Get_Basename_Pos (Pathname (Pathname'First .. Pos - 1)); - -- /xxxxxxxxxx/../ - -- ^ ^ - -- Pos2 Pos - Len : Natural; - begin - if Pos2 = 0 then - -- Shouldn't happen. - return; - end if; - Len := Pos + 3 - Pos2; - Pathname (Pos2 + 1 .. Dir_Pos - Len) := - Pathname (Pos + 4 .. Dir_Pos); - Dir_Pos := Dir_Pos - Len; - if Pos2 < Pathname'First + 3 then - exit; - end if; - Pos := Pos2 - 3; - end; - else - Pos := Pos - 1; - end if; - end loop; - - -- Remove last '/' - Dir_Pos := Dir_Pos - 1; - - -- Skip directory. - Dir_Pos := Get_Basename_Pos (Pathname (Pathname'First .. Dir_Pos)); - if Dir_Pos = 0 then - return; - end if; - - Exec_Prefix := new String'(Pathname (Pathname'First .. Dir_Pos - 1)); - end; - end Set_Prefix_From_Program_Path; - - -- Extract Exec_Prefix from executable name. - procedure Set_Exec_Prefix - is - use GNAT.Directory_Operations; - Prog_Path : constant String := Ada.Command_Line.Command_Name; - Exec_Path : String_Access; - begin - -- If the command name is an absolute path, deduce prefix from it. - if Is_Absolute_Path (Prog_Path) then - Set_Prefix_From_Program_Path (Prog_Path); - return; - end if; - - -- If the command name is a relative path, deduce prefix from it - -- and current path. - if Get_Basename_Pos (Prog_Path) /= 0 then - if Is_Executable_File (Prog_Path) then - Set_Prefix_From_Program_Path - (Get_Current_Dir & Directory_Separator & Prog_Path); - end if; - return; - end if; - - -- Look for program name on the path. - Exec_Path := Locate_Exec_On_Path (Prog_Path); - if Exec_Path /= null then - Set_Prefix_From_Program_Path (Exec_Path.all); - Free (Exec_Path); - end if; - end Set_Exec_Prefix; - - function Get_Version_Path return String - is - use Flags; - begin - case Vhdl_Std is - when Vhdl_87 => - return "v87"; - when Vhdl_93c - | Vhdl_93 - | Vhdl_00 - | Vhdl_02 => - return "v93"; - when Vhdl_08 => - return "v08"; - end case; - end Get_Version_Path; - - function Get_Machine_Path_Prefix return String is - begin - if Flag_32bit then - return Lib_Prefix_Path.all & "32"; - else - return Lib_Prefix_Path.all; - end if; - end Get_Machine_Path_Prefix; - - procedure Add_Library_Path (Name : String) - is - begin - Libraries.Add_Library_Path - (Get_Machine_Path_Prefix & Directory_Separator - & Get_Version_Path & Directory_Separator - & Name & Directory_Separator); - end Add_Library_Path; - - procedure Setup_Libraries (Load : Boolean) - is - begin - -- Get environment variable. - Prefix_Env := GNAT.OS_Lib.Getenv ("GHDL_PREFIX"); - if Prefix_Env = null or else Prefix_Env.all = "" then - Prefix_Env := null; - end if; - - -- Compute Exec_Prefix. - Set_Exec_Prefix; - - -- Set prefix path. - -- If not set by command line, try environment variable. - if Switch_Prefix_Path /= null then - Lib_Prefix_Path := Switch_Prefix_Path; - else - Lib_Prefix_Path := Prefix_Env; - end if; - -- Else try default path. - if Lib_Prefix_Path = null then - if Is_Absolute_Path (Default_Pathes.Lib_Prefix) then - Lib_Prefix_Path := new String'(Default_Pathes.Lib_Prefix); - else - if Exec_Prefix /= null then - Lib_Prefix_Path := new - String'(Exec_Prefix.all & Directory_Separator - & Default_Pathes.Lib_Prefix); - end if; - if Lib_Prefix_Path = null - or else not Is_Directory (Lib_Prefix_Path.all) - then - Free (Lib_Prefix_Path); - Lib_Prefix_Path := new - String'(Default_Pathes.Install_Prefix - & Directory_Separator - & Default_Pathes.Lib_Prefix); - end if; - end if; - else - -- Assume the user has set the correct path, so do not insert 32. - Flag_32bit := False; - end if; - - -- Add pathes for predefined libraries. - if not Flags.Bootstrap then - Add_Library_Path ("std"); - case Flag_Ieee is - when Lib_Standard => - Add_Library_Path ("ieee"); - when Lib_Synopsys => - Add_Library_Path ("synopsys"); - when Lib_Mentor => - Add_Library_Path ("mentor"); - when Lib_None => - null; - end case; - end if; - if Load then - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - end if; - end Setup_Libraries; - - procedure Disp_Library_Unit (Unit : Iir) - is - use Ada.Text_IO; - use Name_Table; - Id : Name_Id; - begin - Id := Get_Identifier (Unit); - case Get_Kind (Unit) is - when Iir_Kind_Entity_Declaration => - Put ("entity "); - when Iir_Kind_Architecture_Body => - Put ("architecture "); - when Iir_Kind_Configuration_Declaration => - Put ("configuration "); - when Iir_Kind_Package_Declaration => - Put ("package "); - when Iir_Kind_Package_Instantiation_Declaration => - Put ("package instance "); - when Iir_Kind_Package_Body => - Put ("package body "); - when others => - Put ("???"); - return; - end case; - Image (Id); - Put (Name_Buffer (1 .. Name_Length)); - case Get_Kind (Unit) is - when Iir_Kind_Architecture_Body => - Put (" of "); - Image (Get_Entity_Identifier_Of_Architecture (Unit)); - Put (Name_Buffer (1 .. Name_Length)); - when Iir_Kind_Configuration_Declaration => - if Id = Null_Identifier then - Put (" of entity "); - Image (Get_Entity_Identifier_Of_Architecture (Unit)); - Put (Name_Buffer (1 .. Name_Length)); - end if; - when others => - null; - end case; - end Disp_Library_Unit; - - procedure Disp_Library (Name : Name_Id) - is - use Ada.Text_IO; - use Libraries; - Lib : Iir_Library_Declaration; - File : Iir_Design_File; - Unit : Iir; - begin - if Name = Std_Names.Name_Work then - Lib := Work_Library; - elsif Name = Std_Names.Name_Std then - Lib := Std_Library; - else - Lib := Get_Library (Name, Command_Line_Location); - end if; - - -- Disp contents of files. - File := Get_Design_File_Chain (Lib); - while File /= Null_Iir loop - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - Disp_Library_Unit (Get_Library_Unit (Unit)); - New_Line; - Unit := Get_Chain (Unit); - end loop; - File := Get_Chain (File); - end loop; - end Disp_Library; - - -- Return FILENAME without the extension. - function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True) - return String - is - First : Natural; - Last : Natural; - begin - First := Filename'First; - Last := Filename'Last; - for I in Filename'Range loop - if Filename (I) = '.' then - Last := I - 1; - elsif Remove_Dir and then Filename (I) = Directory_Separator then - First := I + 1; - Last := Filename'Last; - end if; - end loop; - return Filename (First .. Last); - end Get_Base_Name; - - function Append_Suffix (File : String; Suffix : String) return String_Access - is - use Name_Table; - Basename : constant String := Get_Base_Name (File); - begin - Image (Libraries.Work_Directory); - Name_Buffer (Name_Length + 1 .. Name_Length + Basename'Length) := - Basename; - Name_Length := Name_Length + Basename'Length; - Name_Buffer (Name_Length + 1 .. Name_Length + Suffix'Length) := Suffix; - Name_Length := Name_Length + Suffix'Length; - return new String'(Name_Buffer (1 .. Name_Length)); - end Append_Suffix; - - - -- Command Dir. - type Command_Dir is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean; - function Get_Short_Help (Cmd : Command_Dir) return String; - procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List); - - function Decode_Command (Cmd : Command_Dir; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-d" or else Name = "--dir"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Dir) return String - is - pragma Unreferenced (Cmd); - begin - return "-d or --dir Disp contents of the work library"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Dir; Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - if Args'Length /= 0 then - Error ("command '-d' does not accept any argument"); - raise Option_Error; - end if; - - Flags.Bootstrap := True; - -- Load word library. - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - - Disp_Library (Std_Names.Name_Work); - --- else --- for L in Libs'Range loop --- Id := Get_Identifier (Libs (L).all); --- Disp_Library (Id); --- end loop; --- end if; - end Perform_Action; - - -- Command Find. - type Command_Find is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Find; Name : String) return Boolean; - function Get_Short_Help (Cmd : Command_Find) return String; - procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List); - - function Decode_Command (Cmd : Command_Find; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-f"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Find) return String - is - pragma Unreferenced (Cmd); - begin - return "-f FILEs Disp units in FILES"; - end Get_Short_Help; - - -- Return TRUE is UNIT can be at the apex of a design hierarchy. - function Is_Top_Entity (Unit : Iir) return Boolean - is - begin - if Get_Kind (Unit) /= Iir_Kind_Entity_Declaration then - return False; - end if; - if Get_Port_Chain (Unit) /= Null_Iir then - return False; - end if; - if Get_Generic_Chain (Unit) /= Null_Iir then - return False; - end if; - return True; - end Is_Top_Entity; - - -- Disp contents design files FILES. - procedure Perform_Action (Cmd : in out Command_Find; Args : Argument_List) - is - pragma Unreferenced (Cmd); - - use Ada.Text_IO; - use Name_Table; - Id : Name_Id; - Design_File : Iir_Design_File; - Unit : Iir; - Lib : Iir; - Flag_Add : constant Boolean := False; - begin - Flags.Bootstrap := True; - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - - for I in Args'Range loop - Id := Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - if Design_File /= Null_Iir then - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - Lib := Get_Library_Unit (Unit); - Disp_Library_Unit (Lib); - if Is_Top_Entity (Lib) then - Put (" **"); - end if; - New_Line; - if Flag_Add then - Libraries.Add_Design_Unit_Into_Library (Unit); - end if; - Unit := Get_Chain (Unit); - end loop; - end if; - end loop; - if Flag_Add then - Libraries.Save_Work_Library; - end if; - end Perform_Action; - - -- Command Import. - type Command_Import is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Import; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Import) return String; - procedure Perform_Action (Cmd : in out Command_Import; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Import; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-i"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Import) return String - is - pragma Unreferenced (Cmd); - begin - return "-i [OPTS] FILEs Import units of FILEs"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Import; Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Ada.Text_IO; - Id : Name_Id; - Design_File : Iir_Design_File; - Unit : Iir; - Next_Unit : Iir; - Lib : Iir; - begin - Setup_Libraries (True); - - -- Parse all files. - for I in Args'Range loop - Id := Name_Table.Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - if Design_File /= Null_Iir then - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - if Flag_Verbose then - Lib := Get_Library_Unit (Unit); - Disp_Library_Unit (Lib); - if Is_Top_Entity (Lib) then - Put (" **"); - end if; - New_Line; - end if; - Next_Unit := Get_Chain (Unit); - Set_Chain (Unit, Null_Iir); - Libraries.Add_Design_Unit_Into_Library (Unit); - Unit := Next_Unit; - end loop; - end if; - end loop; - - -- Analyze all files. - if False then - Design_File := Get_Design_File_Chain (Libraries.Work_Library); - while Design_File /= Null_Iir loop - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - case Get_Date (Unit) is - when Date_Valid - | Date_Analyzed => - null; - when Date_Parsed => - Back_End.Finish_Compilation (Unit, False); - when others => - raise Internal_Error; - end case; - Unit := Get_Chain (Unit); - end loop; - Design_File := Get_Chain (Design_File); - end loop; - end if; - - Libraries.Save_Work_Library; - exception - when Errorout.Compilation_Error => - Error ("importation has failed due to compilation error"); - raise; - end Perform_Action; - - -- Command Check_Syntax. - type Command_Check_Syntax is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Check_Syntax; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Check_Syntax) return String; - procedure Perform_Action (Cmd : in out Command_Check_Syntax; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Check_Syntax; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-s"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Check_Syntax) return String - is - pragma Unreferenced (Cmd); - begin - return "-s [OPTS] FILEs Check syntax of FILEs"; - end Get_Short_Help; - - procedure Analyze_One_File (File_Name : String) - is - use Ada.Text_IO; - Id : Name_Id; - Design_File : Iir_Design_File; - Unit : Iir; - Next_Unit : Iir; - begin - Id := Name_Table.Get_Identifier (File_Name); - if Flag_Verbose then - Put (File_Name); - Put_Line (":"); - end if; - Design_File := Libraries.Load_File (Id); - if Design_File = Null_Iir then - raise Errorout.Compilation_Error; - end if; - - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - if Flag_Verbose then - Put (' '); - Disp_Library_Unit (Get_Library_Unit (Unit)); - New_Line; - end if; - -- Sem, canon, annotate a design unit. - Back_End.Finish_Compilation (Unit, True); - - Next_Unit := Get_Chain (Unit); - if Errorout.Nbr_Errors = 0 then - Set_Chain (Unit, Null_Iir); - Libraries.Add_Design_Unit_Into_Library (Unit); - end if; - - Unit := Next_Unit; - end loop; - - if Errorout.Nbr_Errors > 0 then - raise Errorout.Compilation_Error; - end if; - end Analyze_One_File; - - procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) is - begin - Setup_Libraries (True); - - -- Parse all files. - for I in Files'Range loop - Analyze_One_File (Files (I).all); - end loop; - - if Save_Library then - Libraries.Save_Work_Library; - end if; - end Analyze_Files; - - procedure Perform_Action (Cmd : in out Command_Check_Syntax; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - Analyze_Files (Args, False); - end Perform_Action; - - -- Command --clean: remove object files. - type Command_Clean is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean; - function Get_Short_Help (Cmd : Command_Clean) return String; - procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List); - - function Decode_Command (Cmd : Command_Clean; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--clean"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Clean) return String - is - pragma Unreferenced (Cmd); - begin - return "--clean Remove generated files"; - end Get_Short_Help; - - procedure Delete (Str : String) - is - use Ada.Text_IO; - Status : Boolean; - begin - Delete_File (Str'Address, Status); - if Flag_Verbose and Status then - Put_Line ("delete " & Str (Str'First .. Str'Last - 1)); - end if; - end Delete; - - procedure Perform_Action (Cmd : in out Command_Clean; Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Name_Table; - - procedure Delete_Asm_Obj (Str : String) is - begin - Delete (Str & Get_Object_Suffix.all & Nul); - Delete (Str & Asm_Suffix & Nul); - end Delete_Asm_Obj; - - procedure Delete_Top_Unit (Str : String) is - begin - -- Delete elaboration file - Delete_Asm_Obj (Image (Libraries.Work_Directory) & Elab_Prefix & Str); - - -- Delete file list. - Delete (Image (Libraries.Work_Directory) & Str & List_Suffix & Nul); - - -- Delete executable. - Delete (Str & Nul); - end Delete_Top_Unit; - - File : Iir_Design_File; - Design_Unit : Iir_Design_Unit; - Lib_Unit : Iir; - Str : String_Access; - begin - if Args'Length /= 0 then - Error ("command '--clean' does not accept any argument"); - raise Option_Error; - end if; - - Flags.Bootstrap := True; - -- Load libraries. - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - - File := Get_Design_File_Chain (Libraries.Work_Library); - while File /= Null_Iir loop - -- Delete compiled file. - Str := Append_Suffix (Image (Get_Design_File_Filename (File)), ""); - Delete_Asm_Obj (Str.all); - Free (Str); - - Design_Unit := Get_First_Design_Unit (File); - while Design_Unit /= Null_Iir loop - Lib_Unit := Get_Library_Unit (Design_Unit); - case Get_Kind (Lib_Unit) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Configuration_Declaration => - Delete_Top_Unit (Image (Get_Identifier (Lib_Unit))); - when Iir_Kind_Architecture_Body => - Delete_Top_Unit - (Image (Get_Entity_Identifier_Of_Architecture (Lib_Unit)) - & '-' - & Image (Get_Identifier (Lib_Unit))); - when others => - null; - end case; - Design_Unit := Get_Chain (Design_Unit); - end loop; - File := Get_Chain (File); - end loop; - end Perform_Action; - - -- Command --remove: remove object file and library file. - type Command_Remove is new Command_Clean with null record; - function Decode_Command (Cmd : Command_Remove; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Remove) return String; - procedure Perform_Action (Cmd : in out Command_Remove; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Remove; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--remove"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Remove) return String - is - pragma Unreferenced (Cmd); - begin - return "--remove Remove generated files and library file"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Remove; Args : Argument_List) - is - use Name_Table; - begin - if Args'Length /= 0 then - Error ("command '--remove' does not accept any argument"); - raise Option_Error; - end if; - Perform_Action (Command_Clean (Cmd), Args); - Delete (Image (Libraries.Work_Directory) - & Back_End.Library_To_File_Name (Libraries.Work_Library) - & Nul); - end Perform_Action; - - -- Command --copy: copy work library to current directory. - type Command_Copy is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean; - function Get_Short_Help (Cmd : Command_Copy) return String; - procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List); - - function Decode_Command (Cmd : Command_Copy; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--copy"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Copy) return String - is - pragma Unreferenced (Cmd); - begin - return "--copy Copy work library to current directory"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Copy; Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Name_Table; - use Libraries; - - File : Iir_Design_File; - Dir : Name_Id; - begin - if Args'Length /= 0 then - Error ("command '--copy' does not accept any argument"); - raise Option_Error; - end if; - - Setup_Libraries (False); - Libraries.Load_Std_Library; - Dir := Work_Directory; - Work_Directory := Null_Identifier; - Libraries.Load_Work_Library; - Work_Directory := Dir; - - Dir := Get_Library_Directory (Libraries.Work_Library); - if Dir = Name_Nil or else Dir = Files_Map.Get_Home_Directory then - Error ("cannot copy library on itself (use --remove first)"); - raise Option_Error; - end if; - - File := Get_Design_File_Chain (Libraries.Work_Library); - while File /= Null_Iir loop - -- Copy object files (if any). - declare - Basename : constant String := - Get_Base_Name (Image (Get_Design_File_Filename (File))); - Src : String_Access; - Dst : String_Access; - Success : Boolean; - pragma Unreferenced (Success); - begin - Src := new String'(Image (Dir) & Basename & Get_Object_Suffix.all); - Dst := new String'(Basename & Get_Object_Suffix.all); - Copy_File (Src.all, Dst.all, Success, Overwrite, Full); - -- Be silent in case of error. - Free (Src); - Free (Dst); - end; - if Get_Design_File_Directory (File) = Name_Nil then - Set_Design_File_Directory (File, Dir); - end if; - - File := Get_Chain (File); - end loop; - Libraries.Work_Directory := Name_Nil; - Libraries.Save_Work_Library; - end Perform_Action; - - -- Command --disp-standard. - type Command_Disp_Standard is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Disp_Standard; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Disp_Standard) return String; - procedure Perform_Action (Cmd : in out Command_Disp_Standard; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Disp_Standard; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--disp-standard"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Disp_Standard) return String - is - pragma Unreferenced (Cmd); - begin - return "--disp-standard Disp std.standard in pseudo-vhdl"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Disp_Standard; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - if Args'Length /= 0 then - Error ("command '--disp-standard' does not accept any argument"); - raise Option_Error; - end if; - Flags.Bootstrap := True; - Libraries.Load_Std_Library; - Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit); - end Perform_Action; - - procedure Load_All_Libraries_And_Files - is - use Files_Map; - use Libraries; - use Errorout; - - procedure Extract_Library_Clauses (Unit : Iir_Design_Unit) - is - Lib1 : Iir_Library_Declaration; - pragma Unreferenced (Lib1); - Ctxt_Item : Iir; - begin - -- Extract library clauses. - Ctxt_Item := Get_Context_Items (Unit); - while Ctxt_Item /= Null_Iir loop - if Get_Kind (Ctxt_Item) = Iir_Kind_Library_Clause then - Lib1 := Get_Library (Get_Identifier (Ctxt_Item), - Get_Location (Ctxt_Item)); - end if; - Ctxt_Item := Get_Chain (Ctxt_Item); - end loop; - end Extract_Library_Clauses; - - Lib : Iir_Library_Declaration; - Fe : Source_File_Entry; - File, Next_File : Iir_Design_File; - Unit, Next_Unit : Iir_Design_Unit; - Design_File : Iir_Design_File; - - Old_Work : Iir_Library_Declaration; - begin - Lib := Std_Library; - Lib := Get_Chain (Lib); - Old_Work := Work_Library; - while Lib /= Null_Iir loop - -- Design units are always put in the work library. - Work_Library := Lib; - - File := Get_Design_File_Chain (Lib); - while File /= Null_Iir loop - Next_File := Get_Chain (File); - Fe := Load_Source_File (Get_Design_File_Directory (File), - Get_Design_File_Filename (File)); - if Fe = No_Source_File_Entry then - -- FIXME: should remove all the design file from the library. - null; - elsif Is_Eq (Get_File_Time_Stamp (Fe), - Get_File_Time_Stamp (File)) - then - -- File has not been modified. - -- Extract libraries. - -- Note: we can't parse it only, since we need to keep the - -- date. - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - Load_Parse_Design_Unit (Unit, Null_Iir); - Extract_Library_Clauses (Unit); - Unit := Get_Chain (Unit); - end loop; - else - -- File has been modified. - -- Parse it. - Design_File := Load_File (Fe); - - -- Exit now in case of parse error. - if Design_File = Null_Iir - or else Nbr_Errors > 0 - then - raise Compilation_Error; - end if; - - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - Extract_Library_Clauses (Unit); - - Next_Unit := Get_Chain (Unit); - Set_Chain (Unit, Null_Iir); - Add_Design_Unit_Into_Library (Unit); - Unit := Next_Unit; - end loop; - end if; - File := Next_File; - end loop; - Lib := Get_Chain (Lib); - end loop; - Work_Library := Old_Work; - end Load_All_Libraries_And_Files; - - procedure Check_No_Elab_Flag (Lib : Iir_Library_Declaration) - is - File : Iir_Design_File; - Unit : Iir_Design_Unit; - begin - File := Get_Design_File_Chain (Lib); - while File /= Null_Iir loop - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - if Get_Elab_Flag (Unit) then - raise Internal_Error; - end if; - Unit := Get_Chain (Unit); - end loop; - File := Get_Chain (File); - end loop; - end Check_No_Elab_Flag; - - function Build_Dependence (Prim : String_Access; Sec : String_Access) - return Iir_List - is - procedure Build_Dependence_List (File : Iir_Design_File; List : Iir_List) - is - El : Iir_Design_File; - Depend_List : Iir_List; - begin - if Get_Elab_Flag (File) then - return; - end if; - - Set_Elab_Flag (File, True); - Depend_List := Get_File_Dependence_List (File); - if Depend_List /= Null_Iir_List then - for I in Natural loop - El := Get_Nth_Element (Depend_List, I); - exit when El = Null_Iir; - Build_Dependence_List (El, List); - end loop; - end if; - Append_Element (List, File); - end Build_Dependence_List; - - use Configuration; - use Name_Table; - - Top : Iir; - Primary_Id : Name_Id; - Secondary_Id : Name_Id; - - File : Iir_Design_File; - Unit : Iir; - - Files_List : Iir_List; - begin - Check_No_Elab_Flag (Libraries.Work_Library); - - Primary_Id := Get_Identifier (Prim.all); - if Sec /= null then - Secondary_Id := Get_Identifier (Sec.all); - else - Secondary_Id := Null_Identifier; - end if; - - if True then - Load_All_Libraries_And_Files; - else - -- Re-parse modified files in order configure could find all design - -- units. - declare - use Files_Map; - Fe : Source_File_Entry; - Next_File : Iir_Design_File; - Design_File : Iir_Design_File; - begin - File := Get_Design_File_Chain (Libraries.Work_Library); - while File /= Null_Iir loop - Next_File := Get_Chain (File); - Fe := Load_Source_File (Get_Design_File_Directory (File), - Get_Design_File_Filename (File)); - if Fe = No_Source_File_Entry then - -- FIXME: should remove all the design file from - -- the library. - null; - else - if not Is_Eq (Get_File_Time_Stamp (Fe), - Get_File_Time_Stamp (File)) - then - -- FILE has been modified. - Design_File := Libraries.Load_File (Fe); - if Design_File /= Null_Iir then - Libraries.Add_Design_File_Into_Library (Design_File); - end if; - end if; - end if; - File := Next_File; - end loop; - end; - end if; - - Flags.Flag_Elaborate := True; - Flags.Flag_Elaborate_With_Outdated := True; - Flag_Load_All_Design_Units := True; - Flag_Build_File_Dependence := True; - - Top := Configure (Primary_Id, Secondary_Id); - if Top = Null_Iir then - --Error ("cannot find primary unit " & Prim.all); - raise Option_Error; - end if; - - -- Add unused design units. - declare - N : Natural; - begin - N := Design_Units.First; - while N <= Design_Units.Last loop - Unit := Design_Units.Table (N); - N := N + 1; - File := Get_Design_File (Unit); - if not Get_Elab_Flag (File) then - Set_Elab_Flag (File, True); - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - if not Get_Elab_Flag (Unit) then - Add_Design_Unit (Unit, Null_Iir); - end if; - Unit := Get_Chain (Unit); - end loop; - end if; - end loop; - end; - - -- Clear elab flag on design files. - for I in reverse Design_Units.First .. Design_Units.Last loop - Unit := Design_Units.Table (I); - File := Get_Design_File (Unit); - Set_Elab_Flag (File, False); - end loop; - - -- Create a list of files, from the last to the first. - Files_List := Create_Iir_List; - for I in Design_Units.First .. Design_Units.Last loop - Unit := Design_Units.Table (I); - File := Get_Design_File (Unit); - Build_Dependence_List (File, Files_List); - end loop; - - return Files_List; - end Build_Dependence; - - -- Convert NAME to lower cases, unless it is an extended identifier. - function Convert_Name (Name : String_Access) return String_Access - is - use Name_Table; - - function Is_Bad_Unit_Name return Boolean is - begin - if Name_Length = 0 then - return True; - end if; - -- Don't try to handle extended identifier. - if Name_Buffer (1) = '\' then - return False; - end if; - -- Look for suspicious characters. - -- Do not try to be exhaustive as the correct check will be done - -- by convert_identifier. - for I in 1 .. Name_Length loop - case Name_Buffer (I) is - when '.' | '/' | '\' => - return True; - when others => - null; - end case; - end loop; - return False; - end Is_Bad_Unit_Name; - - function Is_A_File_Name return Boolean is - begin - -- Check .vhd - if Name_Length > 4 - and then Name_Buffer (Name_Length - 3 .. Name_Length) = ".vhd" - then - return True; - end if; - -- Check .vhdl - if Name_Length > 5 - and then Name_Buffer (Name_Length - 4 .. Name_Length) = ".vhdl" - then - return True; - end if; - -- Check ../ - if Name_Length > 3 - and then Name_Buffer (1 .. 3) = "../" - then - return True; - end if; - -- Check ..\ - if Name_Length > 3 - and then Name_Buffer (1 .. 3) = "..\" - then - return True; - end if; - -- Should try to find the file ? - return False; - end Is_A_File_Name; - begin - Name_Length := Name'Length; - Name_Buffer (1 .. Name_Length) := Name.all; - - -- Try to identifier bad names (such as file names), so that - -- friendly message can be displayed. - if Is_Bad_Unit_Name then - Errorout.Error_Msg_Option_NR ("bad unit name '" & Name.all & "'"); - if Is_A_File_Name then - Errorout.Error_Msg_Option_NR - ("(a unit name is required instead of a filename)"); - end if; - raise Option_Error; - end if; - Scanner.Convert_Identifier; - return new String'(Name_Buffer (1 .. Name_Length)); - end Convert_Name; - - procedure Extract_Elab_Unit - (Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural) - is - begin - if Args'Length = 0 then - Error ("command '" & Cmd_Name & "' required an unit name"); - raise Option_Error; - end if; - - Prim_Name := Convert_Name (Args (Args'First)); - Next_Arg := Args'First + 1; - Sec_Name := null; - - if Args'Length >= 2 then - declare - Sec : constant String_Access := Args (Next_Arg); - begin - if Sec (Sec'First) /= '-' then - Sec_Name := Convert_Name (Sec); - Next_Arg := Args'First + 2; - end if; - end; - end if; - end Extract_Elab_Unit; - - procedure Register_Commands is - begin - Register_Command (new Command_Import); - Register_Command (new Command_Check_Syntax); - Register_Command (new Command_Dir); - Register_Command (new Command_Find); - Register_Command (new Command_Clean); - Register_Command (new Command_Remove); - Register_Command (new Command_Copy); - Register_Command (new Command_Disp_Standard); - end Register_Commands; -end Ghdllocal; diff --git a/src/translate/ghdldrv/ghdllocal.ads b/src/translate/ghdldrv/ghdllocal.ads deleted file mode 100644 index 2c7018adc..000000000 --- a/src/translate/ghdldrv/ghdllocal.ads +++ /dev/null @@ -1,116 +0,0 @@ --- GHDL driver - local commands. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Ghdlmain; use Ghdlmain; -with Iirs; use Iirs; - -package Ghdllocal is - type Command_Lib is abstract new Command_Type with null record; - - -- Setup GHDL. - procedure Init (Cmd : in out Command_Lib); - - -- Handle: - -- --std=xx, --work=xx, -Pxxx, --workdir=x, --ieee=x, -Px, and -v - procedure Decode_Option (Cmd : in out Command_Lib; - Option : String; - Arg : String; - Res : out Option_Res); - - -- Disp detailled help. - procedure Disp_Long_Help (Cmd : Command_Lib); - - -- Value of --PREFIX - Switch_Prefix_Path : String_Access := null; - - -- getenv ("GHDL_PREFIX"). Set by Setup_Libraries. - Prefix_Env : String_Access := null; - - -- Installation prefix (deduced from executable path). - Exec_Prefix : String_Access; - - -- Path prefix for libraries. - Lib_Prefix_Path : String_Access := null; - - -- Set with -v option. - Flag_Verbose : Boolean := False; - - -- Suffix for asm files. - Asm_Suffix : constant String := ".s"; - - -- Suffix for llvm byte-code files. - Llvm_Suffix : constant String := ".bc"; - - -- Suffix for post files. - Post_Suffix : constant String := ".on"; - - -- Suffix for list files. - List_Suffix : constant String := ".lst"; - - -- Prefix for elab files. - Elab_Prefix : constant String := "e~"; - - Nul : constant Character := Character'Val (0); - - -- Return FILENAME without the extension. - function Get_Base_Name (Filename : String; Remove_Dir : Boolean := True) - return String; - - -- Get the position of the last directory separator or 0 if none. - function Get_Basename_Pos (Pathname : String) return Natural; - - function Append_Suffix (File : String; Suffix : String) - return String_Access; - - -- Return TRUE is UNIT can be at the apex of a design hierarchy. - function Is_Top_Entity (Unit : Iir) return Boolean; - - -- Display the name of library unit UNIT. - procedure Disp_Library_Unit (Unit : Iir); - - -- Translate vhdl version into a path element. - -- Used to search Std and IEEE libraries. - function Get_Version_Path return String; - - -- Get Prefix_Path, but with 32 added if -m32 is requested - function Get_Machine_Path_Prefix return String; - - -- Setup standard libaries path. If LOAD is true, then load them now. - procedure Setup_Libraries (Load : Boolean); - - -- Setup library, analyze FILES, and if SAVE_LIBRARY is set save the - -- work library only - procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean); - - -- Load and parse all libraries and files, starting from the work library. - -- The work library must already be loaded. - -- Raise errorout.compilation_error in case of error (parse error). - procedure Load_All_Libraries_And_Files; - - function Build_Dependence (Prim : String_Access; Sec : String_Access) - return Iir_List; - - Prim_Name : String_Access; - Sec_Name : String_Access; - - -- Set PRIM_NAME and SEC_NAME. - procedure Extract_Elab_Unit - (Cmd_Name : String; Args : Argument_List; Next_Arg : out Natural); - - procedure Register_Commands; -end Ghdllocal; diff --git a/src/translate/ghdldrv/ghdlmain.adb b/src/translate/ghdldrv/ghdlmain.adb deleted file mode 100644 index 45d9615f9..000000000 --- a/src/translate/ghdldrv/ghdlmain.adb +++ /dev/null @@ -1,359 +0,0 @@ --- GHDL driver - main part. --- Copyright (C) 2002 - 2010 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Text_IO; -with Ada.Command_Line; -with Version; -with Bug; -with Options; - -package body Ghdlmain is - procedure Init (Cmd : in out Command_Type) - is - pragma Unreferenced (Cmd); - begin - null; - end Init; - - procedure Decode_Option (Cmd : in out Command_Type; - Option : String; - Arg : String; - Res : out Option_Res) - is - pragma Unreferenced (Cmd); - pragma Unreferenced (Option); - pragma Unreferenced (Arg); - begin - Res := Option_Bad; - end Decode_Option; - - procedure Disp_Long_Help (Cmd : Command_Type) - is - pragma Unreferenced (Cmd); - use Ada.Text_IO; - begin - Put_Line ("This command does not accept options."); - end Disp_Long_Help; - - First_Cmd : Command_Acc := null; - Last_Cmd : Command_Acc := null; - - procedure Register_Command (Cmd : Command_Acc) is - begin - if First_Cmd = null then - First_Cmd := Cmd; - else - Last_Cmd.Next := Cmd; - end if; - Last_Cmd := Cmd; - end Register_Command; - - -- Find the command. - function Find_Command (Action : String) return Command_Acc - is - Cmd : Command_Acc; - begin - Cmd := First_Cmd; - while Cmd /= null loop - if Decode_Command (Cmd.all, Action) then - return Cmd; - end if; - Cmd := Cmd.Next; - end loop; - return null; - end Find_Command; - - -- Command help. - type Command_Help is new Command_Type with null record; - function Decode_Command (Cmd : Command_Help; Name : String) return Boolean; - procedure Decode_Option (Cmd : in out Command_Help; - Option : String; - Arg : String; - Res : out Option_Res); - - function Get_Short_Help (Cmd : Command_Help) return String; - procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List); - - function Decode_Command (Cmd : Command_Help; Name : String) return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-h" or else Name = "--help"; - end Decode_Command; - - procedure Decode_Option (Cmd : in out Command_Help; - Option : String; - Arg : String; - Res : out Option_Res) - is - pragma Unreferenced (Cmd); - pragma Unreferenced (Option); - pragma Unreferenced (Arg); - begin - Res := Option_End; - end Decode_Option; - - function Get_Short_Help (Cmd : Command_Help) return String - is - pragma Unreferenced (Cmd); - begin - return "-h or --help [CMD] Disp this help or [help on CMD]"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List) - is - pragma Unreferenced (Cmd); - - use Ada.Text_IO; - use Ada.Command_Line; - C : Command_Acc; - begin - if Args'Length = 0 then - Put_Line ("usage: " & Command_Name & " COMMAND [OPTIONS] ..."); - Put_Line ("COMMAND is one of:"); - C := First_Cmd; - while C /= null loop - Put_Line (Get_Short_Help (C.all)); - C := C.Next; - end loop; - New_Line; - Put_Line ("To display the options of a GHDL program,"); - Put_Line (" run your program with the --help option."); - Put_Line ("Also see --options-help for analyzer options."); - New_Line; - Put_Line ("Please, refer to the GHDL manual for more information."); - Put_Line ("Report bugs on http://gna.org/projects/ghdl"); - elsif Args'Length = 1 then - C := Find_Command (Args (1).all); - if C = null then - Error ("Command '" & Args (1).all & "' is unknown."); - raise Option_Error; - end if; - Put_Line (Get_Short_Help (C.all)); - Disp_Long_Help (C.all); - else - Error ("Command '--help' accepts at most one argument."); - raise Option_Error; - end if; - end Perform_Action; - - -- Command options help. - type Command_Option_Help is new Command_Type with null record; - function Decode_Command (Cmd : Command_Option_Help; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Option_Help) return String; - procedure Perform_Action (Cmd : in out Command_Option_Help; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Option_Help; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--options-help"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Option_Help) return String - is - pragma Unreferenced (Cmd); - begin - return "--options-help Disp help for analyzer options"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Option_Help; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - begin - if Args'Length /= 0 then - Error - ("warning: command '--option-help' does not accept any argument"); - end if; - Options.Disp_Options_Help; - end Perform_Action; - - -- Command Version - type Command_Version is new Command_Type with null record; - function Decode_Command (Cmd : Command_Version; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Version) return String; - procedure Perform_Action (Cmd : in out Command_Version; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Version; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "-v" or Name = "--version"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Version) return String - is - pragma Unreferenced (Cmd); - begin - return "-v or --version Disp ghdl version"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Version; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Ada.Text_IO; - begin - Put_Line (Version.Ghdl_Release); - Put_Line (" Compiled with " & Bug.Get_Gnat_Version); - if Version_String /= null then - Put (" "); - Put (Version_String.all); - end if; - New_Line; - Put_Line ("Written by Tristan Gingold."); - New_Line; - -- Display copyright. Assume 80 cols terminal. - Put_Line ("Copyright (C) 2003 - 2014 Tristan Gingold."); - Put_Line ("GHDL is free software, covered by the " - & "GNU General Public License. There is NO"); - Put_Line ("warranty; not even for MERCHANTABILITY or" - & " FITNESS FOR A PARTICULAR PURPOSE."); - if Args'Length /= 0 then - Error ("warning: command '--version' does not accept any argument"); - end if; - end Perform_Action; - - -- Disp MSG on the standard output with the command name. - procedure Error (Msg : String) - is - use Ada.Command_Line; - use Ada.Text_IO; - begin - Put (Standard_Error, Command_Name); - Put (Standard_Error, ": "); - Put_Line (Standard_Error, Msg); - --Has_Error := True; - end Error; - - procedure Main - is - use Ada.Command_Line; - Cmd : Command_Acc; - Arg_Index : Natural; - First_Arg : Natural; - - begin - if Argument_Count = 0 then - Error ("missing command, try " & Command_Name & " --help"); - raise Option_Error; - end if; - - Cmd := Find_Command (Argument (1)); - if Cmd = null then - Error ("unknown command '" & Argument (1) & "', try --help"); - raise Option_Error; - end if; - - Init (Cmd.all); - - -- decode options. - - First_Arg := 0; - Arg_Index := 2; - while Arg_Index <= Argument_Count loop - declare - Arg : constant String := Argument (Arg_Index); - Res : Option_Res; - begin - if Arg (1) = '-' then - -- Argument is an option. - - if First_Arg > 0 then - Error ("options after file"); - raise Option_Error; - end if; - - Decode_Option (Cmd.all, Arg, "", Res); - case Res is - when Option_Bad => - Error ("unknown option '" & Arg & "' for command '" - & Argument (1) & "'"); - raise Option_Error; - when Option_Ok => - Arg_Index := Arg_Index + 1; - when Option_Arg_Req => - if Arg_Index + 1 > Argument_Count then - Error ("option '" & Arg & "' requires an argument"); - raise Option_Error; - end if; - Decode_Option - (Cmd.all, Arg, Argument (Arg_Index + 1), Res); - if Res /= Option_Arg then - raise Program_Error; - end if; - Arg_Index := Arg_Index + 2; - when Option_Arg => - raise Program_Error; - when Option_End => - First_Arg := Arg_Index; - exit; - end case; - else - First_Arg := Arg_Index; - exit; - end if; - end; - end loop; - - if First_Arg = 0 then - First_Arg := Argument_Count + 1; - end if; - - declare - Args : Argument_List (1 .. Argument_Count - First_Arg + 1); - begin - for I in Args'Range loop - Args (I) := new String'(Argument (First_Arg + I - 1)); - end loop; - Perform_Action (Cmd.all, Args); - for I in Args'Range loop - Free (Args (I)); - end loop; - end; - --if Flags.Dump_Stats then - -- Name_Table.Disp_Stats; - -- Iirs.Disp_Stats; - --end if; - Set_Exit_Status (Success); - exception - when Option_Error - | Compile_Error - | Errorout.Compilation_Error => - Set_Exit_Status (Failure); - when Exec_Error => - Set_Exit_Status (3); - when E: others => - Bug.Disp_Bug_Box (E); - Set_Exit_Status (2); - end Main; - - procedure Register_Commands is - begin - Register_Command (new Command_Help); - Register_Command (new Command_Version); - Register_Command (new Command_Option_Help); - end Register_Commands; -end Ghdlmain; - diff --git a/src/translate/ghdldrv/ghdlmain.ads b/src/translate/ghdldrv/ghdlmain.ads deleted file mode 100644 index c01f1d63e..000000000 --- a/src/translate/ghdldrv/ghdlmain.ads +++ /dev/null @@ -1,85 +0,0 @@ --- GHDL driver - main part. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Errorout; - -package Ghdlmain is - type Command_Type; - - type Command_Acc is access all Command_Type'Class; - - type Command_Type is abstract tagged record - Next : Command_Acc; - end record; - - -- Return TRUE iff CMD handle action ACTION. - function Decode_Command (Cmd : Command_Type; Name : String) return Boolean - is abstract; - - -- Initialize the command, before decoding actions. - procedure Init (Cmd : in out Command_Type); - - -- Option_OK: OPTION is handled. - -- Option_Bad: OPTION is unknown. - -- Option_Arg_Req: OPTION requires an argument. Must be set only when - -- ARG = "", the manager will recall Decode_Option. - -- Option_Arg: OPTION used the argument. - type Option_Res is - (Option_Bad, Option_Ok, Option_Arg, Option_Arg_Req, Option_End); - procedure Decode_Option (Cmd : in out Command_Type; - Option : String; - Arg : String; - Res : out Option_Res); - - -- Get a one-line help for the command. - function Get_Short_Help (Cmd : Command_Type) return String - is abstract; - - -- Disp detailled help. - procedure Disp_Long_Help (Cmd : Command_Type); - - -- Perform the action. - procedure Perform_Action (Cmd : in out Command_Type; Args : Argument_List) - is abstract; - - -- Register a command. - procedure Register_Command (Cmd : Command_Acc); - - -- Disp MSG on the standard output with the command name. - procedure Error (Msg : String); - - -- May be raise by perform_action if the arguments are bad. - Option_Error : exception renames Errorout.Option_Error; - - -- Action failed. - Compile_Error : exception; - - -- Exec failed: either the program was not found, or failed. - Exec_Error : exception; - - procedure Main; - - -- Additionnal one-line message displayed by the --version command, - -- if defined. - -- Used to customize. - type String_Cst_Acc is access constant String; - Version_String : String_Cst_Acc := null; - - -- Registers all commands in this package. - procedure Register_Commands; -end Ghdlmain; diff --git a/src/translate/ghdldrv/ghdlprint.adb b/src/translate/ghdldrv/ghdlprint.adb deleted file mode 100644 index 45e70e118..000000000 --- a/src/translate/ghdldrv/ghdlprint.adb +++ /dev/null @@ -1,1757 +0,0 @@ --- GHDL driver - print commands. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Characters.Latin_1; -with Ada.Text_IO; use Ada.Text_IO; -with GNAT.Directory_Operations; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Table; -with Types; use Types; -with Flags; -with Name_Table; use Name_Table; -with Files_Map; -with Libraries; -with Errorout; use Errorout; -with Iirs; use Iirs; -with Iirs_Utils; use Iirs_Utils; -with Tokens; -with Scanner; -with Parse; -with Version; -with Xrefs; -with Ghdlmain; use Ghdlmain; -with Ghdllocal; use Ghdllocal; -with Disp_Vhdl; -with Back_End; - -package body Ghdlprint is - type Html_Format_Type is (Html_2, Html_Css); - Html_Format : Html_Format_Type := Html_2; - - procedure Put_Html (C : Character) is - begin - case C is - when '>' => - Put (">"); - when '<' => - Put ("<"); - when '&' => - Put ("&"); - when others => - Put (C); - end case; - end Put_Html; - - procedure Put_Html (S : String) is - begin - for I in S'Range loop - Put_Html (S (I)); - end loop; - end Put_Html; - - package Nat_IO is new Ada.Text_IO.Integer_IO (Num => Natural); - procedure Put_Nat (N : Natural) is - begin - Nat_IO.Put (N, Width => 0); - end Put_Nat; - - type Filexref_Info_Type is record - Output : String_Acc; - Referenced : Boolean; - end record; - type Filexref_Info_Arr is array (Source_File_Entry range <>) - of Filexref_Info_Type; - type Filexref_Info_Arr_Acc is access Filexref_Info_Arr; - Filexref_Info : Filexref_Info_Arr_Acc := null; - - -- If True, at least one xref is missing. - Missing_Xref : Boolean := False; - - procedure PP_Html_File (File : Source_File_Entry) - is - use Flags; - use Scanner; - use Tokens; - use Files_Map; - use Ada.Characters.Latin_1; - - Line : Natural; - Buf : File_Buffer_Acc; - Prev_Tok : Token_Type; - - -- Current logical column number. Used to expand TABs. - Col : Natural; - - -- Position just after the last token. - Last_Tok : Source_Ptr; - - -- Position just before the current token. - Bef_Tok : Source_Ptr; - - -- Position just after the current token. - Aft_Tok : Source_Ptr; - - procedure Disp_Ln - is - N : Natural; - Str : String (1 .. 5); - begin - case Html_Format is - when Html_2 => - Put (""); - when Html_Css => - Put (""); - end case; - N := Line; - for I in reverse Str'Range loop - if N = 0 then - Str (I) := ' '; - else - Str (I) := Character'Val (48 + N mod 10); - N := N / 10; - end if; - end loop; - Put (Str); - case Html_Format is - when Html_2 => - Put (""); - when Html_Css => - Put (""); - end case; - Put (" "); - Col := 0; - end Disp_Ln; - - procedure Disp_Spaces - is - C : Character; - P : Source_Ptr; - N_Col : Natural; - begin - P := Last_Tok; - while P < Bef_Tok loop - C := Buf (P); - if C = HT then - -- Expand TABS. - N_Col := Col + 8; - N_Col := N_Col - N_Col mod 8; - while Col < N_Col loop - Put (' '); - Col := Col + 1; - end loop; - else - Put (' '); - Col := Col + 1; - end if; - P := P + 1; - end loop; - end Disp_Spaces; - - procedure Disp_Text - is - P : Source_Ptr; - begin - P := Bef_Tok; - while P < Aft_Tok loop - Put_Html (Buf (P)); - Col := Col + 1; - P := P + 1; - end loop; - end Disp_Text; - - procedure Disp_Reserved is - begin - Disp_Spaces; - case Html_Format is - when Html_2 => - Put (""); - Disp_Text; - Put (""); - when Html_Css => - Put (""); - Disp_Text; - Put (""); - end case; - end Disp_Reserved; - - procedure Disp_Href (Loc : Location_Type) - is - L_File : Source_File_Entry; - L_Pos : Source_Ptr; - begin - Location_To_File_Pos (Loc, L_File, L_Pos); - Put (" href="""); - if L_File /= File then - -- External reference. - if Filexref_Info (L_File).Output /= null then - Put (Filexref_Info (L_File).Output.all); - Put ("#"); - Put_Nat (Natural (L_Pos)); - else - -- Reference to an unused file. - Put ("index.html#f"); - Put_Nat (Natural (L_File)); - Filexref_Info (L_File).Referenced := True; - end if; - else - -- Local reference. - Put ("#"); - Put_Nat (Natural (L_Pos)); - end if; - Put (""""); - end Disp_Href; - - procedure Disp_Anchor (Loc : Location_Type) - is - L_File : Source_File_Entry; - L_Pos : Source_Ptr; - begin - Put (" name="""); - Location_To_File_Pos (Loc, L_File, L_Pos); - Put_Nat (Natural (L_Pos)); - Put (""""); - end Disp_Anchor; - - procedure Disp_Identifier - is - use Xrefs; - Ref : Xref; - Decl : Iir; - Bod : Iir; - Loc : Location_Type; - begin - Disp_Spaces; - if Flags.Flag_Xref then - Loc := File_Pos_To_Location (File, Bef_Tok); - Ref := Find (Loc); - if Ref = Bad_Xref then - Disp_Text; - Warning_Msg_Sem ("cannot find xref", Loc); - Missing_Xref := True; - return; - end if; - else - Disp_Text; - return; - end if; - case Get_Xref_Kind (Ref) is - when Xref_Decl => - Put (" - Bod := Get_Subprogram_Body (Decl); - when Iir_Kind_Package_Declaration => - Bod := Get_Package_Body (Decl); - when Iir_Kind_Type_Declaration => - Decl := Get_Type (Decl); - case Get_Kind (Decl) is - when Iir_Kind_Protected_Type_Declaration => - Bod := Get_Protected_Type_Body (Decl); - when Iir_Kind_Incomplete_Type_Definition => - Bod := Get_Type_Declarator (Decl); - when others => - Bod := Null_Iir; - end case; - when others => - Bod := Null_Iir; - end case; - if Bod /= Null_Iir then - Disp_Href (Get_Location (Bod)); - end if; - Put (">"); - Disp_Text; - Put (""); - when Xref_Ref - | Xref_End => - Decl := Get_Xref_Node (Ref); - Loc := Get_Location (Decl); - if Loc /= Location_Nil then - Put (""); - Disp_Text; - Put (""); - else - -- This may happen for overload list, in use clauses. - Disp_Text; - end if; - when Xref_Body => - Put (""); - Disp_Text; - Put (""); - end case; - end Disp_Identifier; - - procedure Disp_Attribute - is - use Xrefs; - Ref : Xref; - Decl : Iir; - Loc : Location_Type; - begin - Disp_Spaces; - if Flags.Flag_Xref then - Loc := File_Pos_To_Location (File, Bef_Tok); - Ref := Find (Loc); - else - Ref := Bad_Xref; - end if; - if Ref = Bad_Xref then - case Html_Format is - when Html_2 => - Put (""); - Disp_Text; - Put (""); - when Html_Css => - Put (""); - Disp_Text; - Put (""); - end case; - else - Decl := Get_Xref_Node (Ref); - Loc := Get_Location (Decl); - Put (""); - Disp_Text; - Put (""); - end if; - end Disp_Attribute; - begin - Scanner.Flag_Comment := True; - Scanner.Flag_Newline := True; - - Set_File (File); - Buf := Get_File_Source (File); - - Put_Line ("
");
-      Line := 1;
-      Disp_Ln;
-      Last_Tok := Source_Ptr_Org;
-      Prev_Tok := Tok_Invalid;
-      loop
-         Scan;
-         Bef_Tok := Get_Token_Position;
-         Aft_Tok := Get_Position;
-         case Current_Token is
-            when Tok_Eof =>
-               exit;
-            when Tok_Newline =>
-               New_Line;
-               Line := Line + 1;
-               Disp_Ln;
-            when Tok_Comment =>
-               Disp_Spaces;
-               case Html_Format is
-                  when Html_2 =>
-                     Put ("");
-                     Disp_Text;
-                     Put ("");
-                  when Html_Css =>
-                     Put ("");
-                     Disp_Text;
-                     Put ("");
-               end case;
-            when Tok_Access .. Tok_Elsif
-              | Tok_Entity .. Tok_With
-              | Tok_Mod .. Tok_Rem
-              | Tok_And .. Tok_Not =>
-               Disp_Reserved;
-            when Tok_End =>
-               Disp_Reserved;
-            when Tok_Semi_Colon =>
-               Disp_Spaces;
-               Disp_Text;
-            when Tok_Xnor .. Tok_Ror =>
-               Disp_Reserved;
-            when Tok_Protected =>
-               Disp_Reserved;
-            when Tok_Across .. Tok_Tolerance =>
-               Disp_Reserved;
-            when Tok_Psl_Default
-              | Tok_Psl_Clock
-              | Tok_Psl_Property
-              | Tok_Psl_Sequence
-              | Tok_Psl_Endpoint
-              | Tok_Psl_Assert
-              | Tok_Psl_Cover
-              | Tok_Psl_Boolean
-              | Tok_Psl_Const
-              | Tok_Inf
-              | Tok_Within
-              | Tok_Abort
-              | Tok_Before
-              | Tok_Always
-              | Tok_Never
-              | Tok_Eventually
-              | Tok_Next_A
-              | Tok_Next_E
-              | Tok_Next_Event
-              | Tok_Next_Event_A
-              | Tok_Next_Event_E =>
-               Disp_Spaces;
-               Disp_Text;
-            when Tok_String
-              | Tok_Bit_String
-              | Tok_Character =>
-               Disp_Spaces;
-               case Html_Format is
-                  when Html_2 =>
-                     Put ("");
-                     Disp_Text;
-                     Put ("");
-                  when Html_Css =>
-                     Put ("");
-                     Disp_Text;
-                     Put ("");
-               end case;
-            when Tok_Identifier =>
-               if Prev_Tok = Tok_Tick then
-                  Disp_Attribute;
-               else
-                  Disp_Identifier;
-               end if;
-            when Tok_Left_Paren .. Tok_Colon
-              | Tok_Comma .. Tok_Dot
-              | Tok_Equal_Equal
-              | Tok_Integer
-              | Tok_Real
-              | Tok_Equal .. Tok_Slash
-              | Tok_Invalid =>
-               Disp_Spaces;
-               Disp_Text;
-         end case;
-         Last_Tok := Aft_Tok;
-         Prev_Tok := Current_Token;
-      end loop;
-      Close_File;
-      New_Line;
-      Put_Line ("
"); - Put_Line ("
"); - end PP_Html_File; - - procedure Put_Html_Header - is - begin - Put (""); - Put_Line (" "); - case Html_Format is - when Html_2 => - null; - when Html_Css => - Put_Line (" "); - end case; - --Put_Line (""); - --Put_Line(""); - --Put_Line (""); - --Put_Line (""); - end Put_Html_Header; - - procedure Put_Css is - begin - Put_Line ("/* EM is used for reserved words */"); - Put_Line ("EM { color : red; font-style: normal }"); - New_Line; - Put_Line ("/* TT is used for comments */"); - Put_Line ("TT { color : green; font-style: normal }"); - New_Line; - Put_Line ("/* KBD is used for literals and strings */"); - Put_Line ("KBD { color : blue; font-style: normal }"); - New_Line; - Put_Line ("/* I is used for line numbers */"); - Put_Line ("I { color : gray; font-size: 50% }"); - New_Line; - Put_Line ("/* VAR is used for attributes name */"); - Put_Line ("VAR { color : orange; font-style: normal }"); - New_Line; - Put_Line ("/* A is used for identifiers. */"); - Put_Line ("A { color: blue; font-style: normal;"); - Put_Line (" text-decoration: none }"); - end Put_Css; - - procedure Put_Html_Foot - is - begin - Put_Line ("

"); - Put ("This page was generated using "); - Put (""); - Put (Version.Ghdl_Release); - Put (", a program written by"); - Put (" Tristan Gingold"); - New_Line; - Put_Line ("

"); - Put_Line (""); - Put_Line (""); - end Put_Html_Foot; - - function Create_Output_Filename (Name : String; Num : Natural) - return String_Acc - is - -- Position of the extension. 0 if none. - Ext_Pos : Natural; - - Num_Str : String := Natural'Image (Num); - begin - -- Search for the extension. - Ext_Pos := 0; - for I in reverse Name'Range loop - exit when Name (I) = Directory_Separator; - if Name (I) = '.' then - Ext_Pos := I - 1; - exit; - end if; - end loop; - if Ext_Pos = 0 then - Ext_Pos := Name'Last; - end if; - Num_Str (1) := '.'; - return new String'(Name (Name'First .. Ext_Pos) & Num_Str & ".html"); - end Create_Output_Filename; - - -- Command --chop. - type Command_Chop is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Chop; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Chop) return String; - procedure Perform_Action (Cmd : in out Command_Chop; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Chop; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--chop"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Chop) return String - is - pragma Unreferenced (Cmd); - begin - return "--chop [OPTS] FILEs Chop FILEs"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Chop; Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Ada.Characters.Latin_1; - - function Build_File_Name_Length (Lib : Iir) return Natural - is - Id : constant Name_Id := Get_Identifier (Lib); - Len : Natural; - Id1 : Name_Id; - begin - Len := Get_Name_Length (Id); - case Get_Kind (Lib) is - when Iir_Kind_Configuration_Declaration - | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Instantiation_Declaration => - null; - when Iir_Kind_Package_Body => - Len := Len + 1 + 4; -- add -body - when Iir_Kind_Architecture_Body => - Id1 := Get_Entity_Identifier_Of_Architecture (Lib); - Len := Len + 1 + Get_Name_Length (Id1); - when others => - Error_Kind ("build_file_name", Lib); - end case; - Len := Len + 1 + 4; -- add .vhdl - return Len; - end Build_File_Name_Length; - - procedure Build_File_Name (Lib : Iir; Res : out String) - is - Id : constant Name_Id := Get_Identifier (Lib); - P : Natural; - - procedure Append (Str : String) is - begin - Res (P + 1 .. P + Str'Length) := Str; - P := P + Str'Length; - end Append; - begin - P := Res'First - 1; - case Get_Kind (Lib) is - when Iir_Kind_Configuration_Declaration - | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Instantiation_Declaration => - Image (Id); - Append (Name_Buffer (1 .. Name_Length)); - when Iir_Kind_Package_Body => - Image (Id); - Append (Name_Buffer (1 .. Name_Length)); - Append ("-body"); - when Iir_Kind_Architecture_Body => - Image (Get_Entity_Identifier_Of_Architecture (Lib)); - Append (Name_Buffer (1 .. Name_Length)); - Append ("-"); - Image (Id); - Append (Name_Buffer (1 .. Name_Length)); - when others => - raise Internal_Error; - end case; - Append (".vhdl"); - end Build_File_Name; - - -- Scan source file BUF+START until end of line. - -- Return line kind to KIND and position of next line to NEXT. - type Line_Type is (Line_Blank, Line_Comment, Line_Text); - procedure Find_Eol (Buf : File_Buffer_Acc; - Start : Source_Ptr; - Next : out Source_Ptr; - Kind : out Line_Type) - is - P : Source_Ptr; - begin - P := Start; - - Kind := Line_Blank; - - -- Skip blanks. - while Buf (P) = ' ' or Buf (P) = HT loop - P := P + 1; - end loop; - - -- Skip comment if any. - if Buf (P) = '-' and Buf (P + 1) = '-' then - Kind := Line_Comment; - P := P + 2; - elsif Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT then - Kind := Line_Text; - end if; - - -- Skip until end of line. - while Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT loop - P := P + 1; - end loop; - - if Buf (P) = CR then - P := P + 1; - if Buf (P) = LF then - P := P + 1; - end if; - elsif Buf (P) = LF then - P := P + 1; - if Buf (P) = CR then - P := P + 1; - end if; - end if; - - Next := P; - end Find_Eol; - - Id : Name_Id; - Design_File : Iir_Design_File; - Unit : Iir; - Lib : Iir; - Len : Natural; - begin - Flags.Bootstrap := True; - -- Load word library. - Libraries.Load_Std_Library; - Libraries.Load_Work_Library; - - -- First loop: parse source file, check destination file does not - -- exist. - for I in Args'Range loop - Id := Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - if Design_File = Null_Iir then - raise Compile_Error; - end if; - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - Lib := Get_Library_Unit (Unit); - Len := Build_File_Name_Length (Lib); - declare - Filename : String (1 .. Len + 1); - begin - Build_File_Name (Lib, Filename); - Filename (Len + 1) := Ghdllocal.Nul; - if Is_Regular_File (Filename) then - Error ("file '" & Filename (1 .. Len) & "' already exists"); - raise Compile_Error; - end if; - Put (Filename (1 .. Len)); - Put (" (for "); - Disp_Library_Unit (Lib); - Put (")"); - New_Line; - end; - Unit := Get_Chain (Unit); - end loop; - end loop; - - -- Second loop: do the real work. - for I in Args'Range loop - Id := Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - Unit := Get_First_Design_Unit (Design_File); - declare - use Files_Map; - - File_Entry : Source_File_Entry; - Buffer : File_Buffer_Acc; - - Start : Source_Ptr; - Lend : Source_Ptr; - First : Source_Ptr; - Next : Source_Ptr; - Kind : Line_Type; - begin - -- A design_file must have at least one design unit. - if Unit = Null_Iir then - raise Compile_Error; - end if; - - Location_To_File_Pos - (Get_Location (Unit), File_Entry, Start); - Buffer := Get_File_Source (File_Entry); - - First := Source_Ptr_Org; - if Get_Chain (Unit) /= Null_Iir then - -- If there is only one unit, then the whole file is written. - -- First last blank line. - Next := Source_Ptr_Org; - loop - Start := Next; - Find_Eol (Buffer, Start, Next, Kind); - exit when Kind = Line_Text; - if Kind = Line_Blank then - First := Next; - end if; - end loop; - - -- FIXME: write header. - end if; - - while Unit /= Null_Iir loop - Lib := Get_Library_Unit (Unit); - - Location_To_File_Pos - (Get_End_Location (Unit), File_Entry, Lend); - if Lend < First then - raise Internal_Error; - end if; - - Location_To_File_Pos - (Get_End_Location (Unit), File_Entry, Lend); - -- Find the ';'. - while Buffer (Lend) /= ';' loop - Lend := Lend + 1; - end loop; - Lend := Lend + 1; - -- Find end of line. - Find_Eol (Buffer, Lend, Next, Kind); - if Kind = Line_Text then - -- There is another unit on the same line. - Next := Lend; - -- Skip blanks. - while Buffer (Next) = ' ' or Buffer (Next) = HT loop - Next := Next + 1; - end loop; - else - -- Find first blank line. - loop - Start := Next; - Find_Eol (Buffer, Start, Next, Kind); - exit when Kind /= Line_Comment; - end loop; - if Kind = Line_Text then - -- There is not blank lines. - -- All the comments are supposed to belong to the next - -- unit. - Find_Eol (Buffer, Lend, Next, Kind); - Lend := Next; - else - Lend := Start; - end if; - end if; - - if Get_Chain (Unit) = Null_Iir then - -- Last unit. - -- Put the end of the file in it. - Lend := Get_File_Length (File_Entry); - end if; - - -- FIXME: file with only one unit. - -- FIXME: set extension. - Len := Build_File_Name_Length (Lib); - declare - Filename : String (1 .. Len + 1); - Fd : File_Descriptor; - - Wlen : Integer; - begin - Build_File_Name (Lib, Filename); - Filename (Len + 1) := Character'Val (0); - Fd := Create_File (Filename, Binary); - if Fd = Invalid_FD then - Error - ("cannot create file '" & Filename (1 .. Len) & "'"); - raise Compile_Error; - end if; - Wlen := Integer (Lend - First); - if Write (Fd, Buffer (First)'Address, Wlen) /= Wlen then - Error ("cannot write to '" & Filename (1 .. Len) & "'"); - raise Compile_Error; - end if; - Close (Fd); - end; - First := Next; - - Unit := Get_Chain (Unit); - end loop; - end; - end loop; - end Perform_Action; - - -- Command --lines. - type Command_Lines is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Lines; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Lines) return String; - procedure Perform_Action (Cmd : in out Command_Lines; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Lines; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--lines"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Lines) return String - is - pragma Unreferenced (Cmd); - begin - return "--lines FILEs Precede line with its number"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Lines; Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Scanner; - use Tokens; - use Files_Map; - use Ada.Characters.Latin_1; - - Id : Name_Id; - Fe : Source_File_Entry; - Local_Id : Name_Id; - Line : Natural; - File : Source_File_Entry; - Buf : File_Buffer_Acc; - Ptr : Source_Ptr; - Eptr : Source_Ptr; - C : Character; - N : Natural; - Log : Natural; - Str : String (1 .. 10); - begin - Local_Id := Get_Identifier (""); - for I in Args'Range loop - -- Load the file. - Id := Get_Identifier (Args (I).all); - Fe := Files_Map.Load_Source_File (Local_Id, Id); - if Fe = No_Source_File_Entry then - Error ("cannot open file " & Args (I).all); - raise Compile_Error; - end if; - Set_File (Fe); - - -- Scan the content, to compute the number of lines. - loop - Scan; - exit when Current_Token = Tok_Eof; - end loop; - File := Get_Current_Source_File; - Line := Get_Current_Line; - Close_File; - - -- Compute log10 of line. - N := Line; - Log := 0; - loop - N := N / 10; - Log := Log + 1; - exit when N = 0; - end loop; - - -- Disp file name. - Put (Args (I).all); - Put (':'); - New_Line; - - Buf := Get_File_Source (File); - for J in 1 .. Line loop - Ptr := Line_To_Position (File, J); - exit when Ptr = Source_Ptr_Bad; - exit when Buf (Ptr) = Files_Map.EOT; - - -- Disp line number. - N := J; - for K in reverse 1 .. Log loop - if N = 0 then - Str (K) := ' '; - else - Str (K) := Character'Val (48 + N mod 10); - N := N / 10; - end if; - end loop; - Put (Str (1 .. Log)); - Put (": "); - - -- Search for end of line (or end of file). - Eptr := Ptr; - loop - C := Buf (Eptr); - exit when C = Files_Map.EOT or C = LF or C = CR; - Eptr := Eptr + 1; - end loop; - - -- Disp line. - if Eptr > Ptr then - -- Avoid constraint error on conversion of nul array. - Put (String (Buf (Ptr .. Eptr - 1))); - end if; - New_Line; - end loop; - end loop; - end Perform_Action; - - -- Command Reprint. - type Command_Reprint is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Reprint; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Reprint) return String; - procedure Perform_Action (Cmd : in out Command_Reprint; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Reprint; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--reprint"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Reprint) return String - is - pragma Unreferenced (Cmd); - begin - return "--reprint [OPTS] FILEs Redisplay FILEs"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Reprint; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - Design_File : Iir_Design_File; - Unit : Iir; - - Id : Name_Id; - Next_Unit : Iir; - begin - Setup_Libraries (True); - Parse.Flag_Parse_Parenthesis := True; - - -- Parse all files. - for I in Args'Range loop - Id := Name_Table.Get_Identifier (Args (I).all); - Design_File := Libraries.Load_File (Id); - if Design_File = Null_Iir then - raise Errorout.Compilation_Error; - end if; - - Unit := Get_First_Design_Unit (Design_File); - while Unit /= Null_Iir loop - -- Analyze the design unit. - Back_End.Finish_Compilation (Unit, True); - - Next_Unit := Get_Chain (Unit); - if Errorout.Nbr_Errors = 0 then - Disp_Vhdl.Disp_Vhdl (Unit); - Set_Chain (Unit, Null_Iir); - Libraries.Add_Design_Unit_Into_Library (Unit); - end if; - - Unit := Next_Unit; - end loop; - - if Errorout.Nbr_Errors > 0 then - raise Errorout.Compilation_Error; - end if; - end loop; - end Perform_Action; - - -- Command compare tokens. - type Command_Compare_Tokens is new Command_Lib with null record; - function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Compare_Tokens) return String; - procedure Perform_Action (Cmd : in out Command_Compare_Tokens; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--compare-tokens"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Compare_Tokens) return String - is - pragma Unreferenced (Cmd); - begin - return "--compare-tokens [OPTS] REF FILEs Compare FILEs with REF"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Compare_Tokens; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Tokens; - use Scanner; - - package Ref_Tokens is new GNAT.Table - (Table_Component_Type => Token_Type, - Table_Index_Type => Integer, - Table_Low_Bound => 0, - Table_Initial => 1024, - Table_Increment => 100); - - Id : Name_Id; - Fe : Source_File_Entry; - Local_Id : Name_Id; - Tok_Idx : Natural; - begin - if Args'Length < 1 then - Error ("missing ref file"); - raise Compile_Error; - end if; - - Local_Id := Get_Identifier (""); - - for I in Args'Range loop - -- Load the file. - Id := Get_Identifier (Args (I).all); - Fe := Files_Map.Load_Source_File (Local_Id, Id); - if Fe = No_Source_File_Entry then - Error ("cannot open file " & Args (I).all); - raise Compile_Error; - end if; - Set_File (Fe); - - if I = Args'First then - -- Scan ref file - loop - Scan; - Ref_Tokens.Append (Current_Token); - exit when Current_Token = Tok_Eof; - end loop; - else - -- Scane file - Tok_Idx := Ref_Tokens.First; - loop - Scan; - if Ref_Tokens.Table (Tok_Idx) /= Current_Token then - Error_Msg_Parse ("token mismatch"); - exit; - end if; - case Current_Token is - when Tok_Eof => - exit; - when others => - null; - end case; - Tok_Idx := Tok_Idx + 1; - end loop; - end if; - Close_File; - end loop; - - Ref_Tokens.Free; - - if Nbr_Errors /= 0 then - raise Compilation_Error; - end if; - end Perform_Action; - - -- Command html. - type Command_Html is abstract new Command_Lib with null record; - - procedure Decode_Option (Cmd : in out Command_Html; - Option : String; - Arg : String; - Res : out Option_Res); - - procedure Disp_Long_Help (Cmd : Command_Html); - - procedure Decode_Option (Cmd : in out Command_Html; - Option : String; - Arg : String; - Res : out Option_Res) - is - begin - if Option = "--format=css" then - Html_Format := Html_Css; - Res := Option_Ok; - elsif Option = "--format=html2" then - Html_Format := Html_2; - Res := Option_Ok; - else - Decode_Option (Command_Lib (Cmd), Option, Arg, Res); - end if; - end Decode_Option; - - procedure Disp_Long_Help (Cmd : Command_Html) is - begin - Disp_Long_Help (Command_Lib (Cmd)); - Put_Line ("--format=html2 Use FONT attributes"); - Put_Line ("--format=css Use ghdl.css file"); - end Disp_Long_Help; - - -- Command --pp-html. - type Command_PP_Html is new Command_Html with null record; - function Decode_Command (Cmd : Command_PP_Html; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_PP_Html) return String; - procedure Perform_Action (Cmd : in out Command_PP_Html; - Files : Argument_List); - - function Decode_Command (Cmd : Command_PP_Html; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--pp-html"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_PP_Html) return String - is - pragma Unreferenced (Cmd); - begin - return "--pp-html FILEs Pretty-print FILEs in HTML"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_PP_Html; - Files : Argument_List) - is - pragma Unreferenced (Cmd); - use Scanner; - use Tokens; - use Files_Map; - use Ada.Characters.Latin_1; - - Id : Name_Id; - Fe : Source_File_Entry; - Local_Id : Name_Id; - begin - Local_Id := Get_Identifier (""); - Put_Html_Header; - Put_Line (" "); - for I in Files'Range loop - Put (" "); - Put_Line (Files (I).all); - end loop; - Put_Line (" "); - Put_Line (""); - New_Line; - Put_Line (""); - - for I in Files'Range loop - Id := Get_Identifier (Files (I).all); - Fe := Files_Map.Load_Source_File (Local_Id, Id); - if Fe = No_Source_File_Entry then - Error ("cannot open file " & Files (I).all); - raise Compile_Error; - end if; - Put ("

"); - Put (Files (I).all); - Put ("

"); - New_Line; - - PP_Html_File (Fe); - end loop; - Put_Html_Foot; - end Perform_Action; - - -- Command --xref-html. - type Command_Xref_Html is new Command_Html with record - Output_Dir : String_Access := null; - Check_Missing : Boolean := False; - end record; - - function Decode_Command (Cmd : Command_Xref_Html; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Xref_Html) return String; - procedure Decode_Option (Cmd : in out Command_Xref_Html; - Option : String; - Arg : String; - Res : out Option_Res); - procedure Disp_Long_Help (Cmd : Command_Xref_Html); - - procedure Perform_Action (Cmd : in out Command_Xref_Html; - Files_Name : Argument_List); - - function Decode_Command (Cmd : Command_Xref_Html; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--xref-html"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Xref_Html) return String - is - pragma Unreferenced (Cmd); - begin - return "--xref-html FILEs Display FILEs in HTML with xrefs"; - end Get_Short_Help; - - procedure Decode_Option (Cmd : in out Command_Xref_Html; - Option : String; - Arg : String; - Res : out Option_Res) - is - begin - if Option = "-o" then - if Arg = "" then - Res := Option_Arg_Req; - else - Cmd.Output_Dir := new String'(Arg); - Res := Option_Arg; - end if; - elsif Option = "--check-missing" then - Cmd.Check_Missing := True; - Res := Option_Ok; - else - Decode_Option (Command_Html (Cmd), Option, Arg, Res); - end if; - end Decode_Option; - - procedure Disp_Long_Help (Cmd : Command_Xref_Html) is - begin - Disp_Long_Help (Command_Html (Cmd)); - Put_Line ("-o DIR Put generated files into DIR (def: html/)"); - Put_Line ("--check-missing Fail if a reference is missing"); - New_Line; - Put_Line ("When format is css, the CSS file 'ghdl.css' " - & "is never overwritten."); - end Disp_Long_Help; - - procedure Analyze_Design_File_Units (File : Iir_Design_File) - is - Unit : Iir_Design_Unit; - begin - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - case Get_Date_State (Unit) is - when Date_Extern - | Date_Disk => - raise Internal_Error; - when Date_Parse => - Libraries.Load_Design_Unit (Unit, Null_Iir); - when Date_Analyze => - null; - end case; - Unit := Get_Chain (Unit); - end loop; - end Analyze_Design_File_Units; - - procedure Perform_Action - (Cmd : in out Command_Xref_Html; Files_Name : Argument_List) - is - use GNAT.Directory_Operations; - - Id : Name_Id; - File : Source_File_Entry; - - type File_Data is record - Fe : Source_File_Entry; - Design_File : Iir; - Output : String_Acc; - end record; - type File_Data_Array is array (Files_Name'Range) of File_Data; - - Files : File_Data_Array; - Output : File_Type; - begin - Xrefs.Init; - Flags.Flag_Xref := True; - - -- Load work library. - Setup_Libraries (True); - - if Cmd.Output_Dir = null then - Cmd.Output_Dir := new String'("html"); - elsif Cmd.Output_Dir.all = "-" then - Cmd.Output_Dir := null; - end if; - - -- Try to create the directory. - if Cmd.Output_Dir /= null - and then not Is_Directory (Cmd.Output_Dir.all) - then - declare - begin - Make_Dir (Cmd.Output_Dir.all); - exception - when Directory_Error => - Error ("cannot create directory " & Cmd.Output_Dir.all); - return; - end; - end if; - - -- Parse all files. - for I in Files'Range loop - Id := Get_Identifier (Files_Name (I).all); - File := Files_Map.Load_Source_File (Libraries.Local_Directory, Id); - if File = No_Source_File_Entry then - Error ("cannot open " & Image (Id)); - return; - end if; - Files (I).Fe := File; - Files (I).Design_File := Libraries.Load_File (File); - if Files (I).Design_File = Null_Iir then - return; - end if; - Files (I).Output := Create_Output_Filename - (Base_Name (Files_Name (I).all), I); - if Is_Regular_File (Files (I).Output.all) then - -- Prevent overwrite. - null; - end if; - -- Put units in library. - Libraries.Add_Design_File_Into_Library (Files (I).Design_File); - end loop; - - -- Analyze all files. - for I in Files'Range loop - Analyze_Design_File_Units (Files (I).Design_File); - end loop; - - Xrefs.Sort_By_Location; - - if False then - for I in 1 .. Xrefs.Get_Last_Xref loop - declare - use Xrefs; - - procedure Put_Loc (L : Location_Type) - is - use Files_Map; - - L_File : Source_File_Entry; - L_Pos : Source_Ptr; - begin - Files_Map.Location_To_File_Pos (L, L_File, L_Pos); - Put_Nat (Natural (L_File)); - --Image (Get_File_Name (L_File)); - --Put (Name_Buffer (1 .. Name_Length)); - Put (":"); - Put_Nat (Natural (L_Pos)); - end Put_Loc; - begin - Put_Loc (Get_Xref_Location (I)); - case Get_Xref_Kind (I) is - when Xref_Decl => - Put (" decl "); - Put (Image (Get_Identifier (Get_Xref_Node (I)))); - when Xref_Ref => - Put (" use "); - Put_Loc (Get_Location (Get_Xref_Node (I))); - when Xref_End => - Put (" end "); - when Xref_Body => - Put (" body "); - end case; - New_Line; - end; - end loop; - end if; - - -- Create filexref_info. - Filexref_Info := new Filexref_Info_Arr - (No_Source_File_Entry .. Files_Map.Get_Last_Source_File_Entry); - Filexref_Info.all := (others => (Output => null, - Referenced => False)); - for I in Files'Range loop - Filexref_Info (Files (I).Fe).Output := Files (I).Output; - end loop; - - for I in Files'Range loop - if Cmd.Output_Dir /= null then - Create (Output, Out_File, - Cmd.Output_Dir.all & Directory_Separator - & Files (I).Output.all); - - Set_Output (Output); - end if; - - Put_Html_Header; - Put_Line (" "); - Put_Html (Files_Name (I).all); - Put (""); - Put_Line (""); - New_Line; - Put_Line (""); - - Put ("

"); - Put_Html (Files_Name (I).all); - Put ("

"); - New_Line; - - PP_Html_File (Files (I).Fe); - Put_Html_Foot; - - if Cmd.Output_Dir /= null then - Close (Output); - end if; - end loop; - - -- Create indexes. - if Cmd.Output_Dir /= null then - Create (Output, Out_File, - Cmd.Output_Dir.all & Directory_Separator & "index.html"); - Set_Output (Output); - - Put_Html_Header; - Put_Line (" Xrefs indexes"); - Put_Line (""); - New_Line; - Put_Line (""); - Put_Line ("

list of files:"); - Put_Line ("

"); - Put_Line ("
"); - - -- TODO: list of design units. - - Put_Line ("

list of files referenced but not available:"); - Put_Line ("

"); - Put_Html_Foot; - - Close (Output); - end if; - - if Html_Format = Html_Css - and then Cmd.Output_Dir /= null - then - declare - Css_Filename : constant String := - Cmd.Output_Dir.all & Directory_Separator & "ghdl.css"; - begin - if not Is_Regular_File (Css_Filename & Nul) then - Create (Output, Out_File, Css_Filename); - Set_Output (Output); - Put_Css; - Close (Output); - end if; - end; - end if; - - if Missing_Xref and Cmd.Check_Missing then - Error ("missing xrefs"); - raise Compile_Error; - end if; - exception - when Compilation_Error => - Error ("xrefs has failed due to compilation error"); - end Perform_Action; - - - -- Command --xref - type Command_Xref is new Command_Lib with null record; - - function Decode_Command (Cmd : Command_Xref; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Xref) return String; - - procedure Perform_Action (Cmd : in out Command_Xref; - Files_Name : Argument_List); - - function Decode_Command (Cmd : Command_Xref; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--xref"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Xref) return String - is - pragma Unreferenced (Cmd); - begin - return "--xref FILEs Generate xrefs"; - end Get_Short_Help; - - procedure Perform_Action - (Cmd : in out Command_Xref; Files_Name : Argument_List) - is - pragma Unreferenced (Cmd); - - use Files_Map; - - Id : Name_Id; - File : Source_File_Entry; - - type File_Data is record - Fe : Source_File_Entry; - Design_File : Iir; - end record; - type File_Data_Array is array (Files_Name'Range) of File_Data; - - Files : File_Data_Array; - begin - -- Load work library. - Setup_Libraries (True); - - Xrefs.Init; - Flags.Flag_Xref := True; - - -- Parse all files. - for I in Files'Range loop - Id := Get_Identifier (Files_Name (I).all); - File := Load_Source_File (Libraries.Local_Directory, Id); - if File = No_Source_File_Entry then - Error ("cannot open " & Image (Id)); - return; - end if; - Files (I).Fe := File; - Files (I).Design_File := Libraries.Load_File (File); - if Files (I).Design_File = Null_Iir then - return; - end if; - -- Put units in library. - -- Note: design_units stay while design_file get empty. - Libraries.Add_Design_File_Into_Library (Files (I).Design_File); - end loop; - - -- Analyze all files. - for I in Files'Range loop - Analyze_Design_File_Units (Files (I).Design_File); - end loop; - - Xrefs.Fix_End_Xrefs; - Xrefs.Sort_By_Node_Location; - - for F in Files'Range loop - - Put ("GHDL-XREF V0"); - - declare - use Xrefs; - - Cur_Decl : Iir; - Cur_File : Source_File_Entry; - - procedure Emit_Loc (Loc : Location_Type; C : Character) - is - L_File : Source_File_Entry; - L_Pos : Source_Ptr; - L_Line : Natural; - L_Off : Natural; - begin - Location_To_Coord (Loc, L_File, L_Pos, L_Line, L_Off); - --Put_Nat (Natural (L_File)); - --Put (':'); - Put_Nat (L_Line); - Put (C); - Put_Nat (L_Off); - end Emit_Loc; - - procedure Emit_Decl (N : Iir) - is - Loc : Location_Type; - Loc_File : Source_File_Entry; - Loc_Pos : Source_Ptr; - C : Character; - Dir : Name_Id; - begin - New_Line; - Cur_Decl := N; - Loc := Get_Location (N); - Location_To_File_Pos (Loc, Loc_File, Loc_Pos); - if Loc_File /= Cur_File then - Cur_File := Loc_File; - Put ("XFILE: "); - Dir := Get_Source_File_Directory (Cur_File); - if Dir /= Null_Identifier then - Image (Dir); - Put (Name_Buffer (1 .. Name_Length)); - end if; - Image (Get_File_Name (Cur_File)); - Put (Name_Buffer (1 .. Name_Length)); - New_Line; - end if; - - -- Letters: - -- b d fgh jk no qr uvwxyz - -- D H JK MNO QR U WXYZ - case Get_Kind (N) is - when Iir_Kind_Type_Declaration => - C := 'T'; - when Iir_Kind_Subtype_Declaration => - C := 't'; - when Iir_Kind_Entity_Declaration => - C := 'E'; - when Iir_Kind_Architecture_Body => - C := 'A'; - when Iir_Kind_Library_Declaration => - C := 'L'; - when Iir_Kind_Package_Declaration => - C := 'P'; - when Iir_Kind_Package_Body => - C := 'B'; - when Iir_Kind_Function_Declaration => - C := 'F'; - when Iir_Kind_Procedure_Declaration => - C := 'p'; - when Iir_Kind_Interface_Signal_Declaration => - C := 's'; - when Iir_Kind_Signal_Declaration => - C := 'S'; - when Iir_Kind_Interface_Constant_Declaration => - C := 'c'; - when Iir_Kind_Constant_Declaration => - C := 'C'; - when Iir_Kind_Variable_Declaration => - C := 'V'; - when Iir_Kind_Element_Declaration => - C := 'e'; - when Iir_Kind_Iterator_Declaration => - C := 'i'; - when Iir_Kind_Attribute_Declaration => - C := 'a'; - when Iir_Kind_Enumeration_Literal => - C := 'l'; - when Iir_Kind_Component_Declaration => - C := 'm'; - when Iir_Kind_Component_Instantiation_Statement => - C := 'I'; - when Iir_Kind_Generate_Statement => - C := 'G'; - when others => - C := '?'; - end case; - Emit_Loc (Loc, C); - --Disp_Tree.Disp_Iir_Address (N); - Put (' '); - case Get_Kind (N) is - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - null; - when others => - Image (Get_Identifier (N)); - Put (Name_Buffer (1 .. Name_Length)); - end case; - end Emit_Decl; - - procedure Emit_Ref (R : Xref; T : Character) - is - N : Iir; - begin - N := Get_Xref_Node (R); - if N /= Cur_Decl then - Emit_Decl (N); - end if; - Put (' '); - Emit_Loc (Get_Xref_Location (R), T); - end Emit_Ref; - - Loc : Location_Type; - Loc_File : Source_File_Entry; - Loc_Pos : Source_Ptr; - begin - Cur_Decl := Null_Iir; - Cur_File := No_Source_File_Entry; - - for I in First_Xref .. Get_Last_Xref loop - Loc := Get_Xref_Location (I); - Location_To_File_Pos (Loc, Loc_File, Loc_Pos); - if Loc_File = Files (F).Fe then - -- This is a local location. - case Get_Xref_Kind (I) is - when Xref_Decl => - Emit_Decl (Get_Xref_Node (I)); - when Xref_End => - Emit_Ref (I, 'e'); - when Xref_Ref => - Emit_Ref (I, 'r'); - when Xref_Body => - Emit_Ref (I, 'b'); - end case; - end if; - end loop; - New_Line; - end; - end loop; - exception - when Compilation_Error => - Error ("xrefs has failed due to compilation error"); - end Perform_Action; - - procedure Register_Commands is - begin - Register_Command (new Command_Chop); - Register_Command (new Command_Lines); - Register_Command (new Command_Reprint); - Register_Command (new Command_Compare_Tokens); - Register_Command (new Command_PP_Html); - Register_Command (new Command_Xref_Html); - Register_Command (new Command_Xref); - end Register_Commands; -end Ghdlprint; diff --git a/src/translate/ghdldrv/ghdlprint.ads b/src/translate/ghdldrv/ghdlprint.ads deleted file mode 100644 index 82c3e6072..000000000 --- a/src/translate/ghdldrv/ghdlprint.ads +++ /dev/null @@ -1,20 +0,0 @@ --- GHDL driver - print commands. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package Ghdlprint is - procedure Register_Commands; -end Ghdlprint; diff --git a/src/translate/ghdldrv/ghdlrun.adb b/src/translate/ghdldrv/ghdlrun.adb deleted file mode 100644 index f6237214e..000000000 --- a/src/translate/ghdldrv/ghdlrun.adb +++ /dev/null @@ -1,661 +0,0 @@ --- GHDL driver - JIT commands. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Interfaces.C; - -with Ghdlmain; use Ghdlmain; -with Ghdllocal; use Ghdllocal; -with GNAT.OS_Lib; use GNAT.OS_Lib; - -with Ada.Unchecked_Conversion; -with Ada.Command_Line; -with Ada.Text_IO; - -with Ortho_Jit; -with Ortho_Nodes; use Ortho_Nodes; -with Interfaces; -with System; use System; -with Trans_Decls; -with Iirs; use Iirs; -with Flags; -with Errorout; use Errorout; -with Libraries; -with Canon; -with Trans_Be; -with Translation; -with Ieee.Std_Logic_1164; - -with Lists; -with Str_Table; -with Nodes; -with Files_Map; -with Name_Table; - -with Grt.Main; -with Grt.Modules; -with Grt.Lib; -with Grt.Processes; -with Grt.Rtis; -with Grt.Files; -with Grt.Signals; -with Grt.Options; -with Grt.Types; -with Grt.Images; -with Grt.Values; -with Grt.Names; -with Grt.Std_Logic_1164; - -with Ghdlcomp; -with Foreigns; -with Grtlink; - -package body Ghdlrun is - procedure Foreign_Hook (Decl : Iir; - Info : Translation.Foreign_Info_Type; - Ortho : O_Dnode); - - procedure Compile_Init (Analyze_Only : Boolean) is - begin - if Analyze_Only then - return; - end if; - - Translation.Foreign_Hook := Foreign_Hook'Access; - - -- FIXME: add a flag to force unnesting. - -- Translation.Flag_Unnest_Subprograms := True; - - -- The design is always analyzed in whole. - Flags.Flag_Whole_Analyze := True; - - Setup_Libraries (False); - Libraries.Load_Std_Library; - - Ortho_Jit.Init; - - Translation.Initialize; - Canon.Canon_Flag_Add_Labels := True; - end Compile_Init; - - procedure Compile_Elab - (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural) - is - begin - Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg); - if Sec_Name = null then - Sec_Name := new String'(""); - end if; - - Flags.Flag_Elaborate := True; - Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True); - - if Errorout.Nbr_Errors > 0 then - -- This may happen (bad entity for example). - raise Compilation_Error; - end if; - end Compile_Elab; - - -- Set options. - -- This is a little bit over-kill: from C to Ada and then again to C... - procedure Set_Run_Options (Args : Argument_List) - is - use Interfaces.C; - use Grt.Options; - use Grt.Types; - - function Malloc (Size : size_t) return Argv_Type; - pragma Import (C, Malloc); - - function Strdup (Str : String) return Ghdl_C_String; - pragma Import (C, Strdup); --- is --- T : Grt.Types.String_Access; --- begin --- T := new String'(Str & Ghdllocal.Nul); --- return To_Ghdl_C_String (T.all'Address); --- end Strdup; - begin - Argc := 1 + Args'Length; - Argv := Malloc - (size_t (Argc * (Ghdl_C_String'Size / System.Storage_Unit))); - Argv (0) := Strdup (Ada.Command_Line.Command_Name & Ghdllocal.Nul); - Progname := Argv (0); - for I in Args'Range loop - Argv (1 + I - Args'First) := Strdup (Args (I).all & Ghdllocal.Nul); - end loop; - end Set_Run_Options; - - procedure Ghdl_Elaborate; - pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE"); - - type Elaborate_Acc is access procedure; - pragma Convention (C, Elaborate_Acc); - Elaborate_Proc : Elaborate_Acc := null; - - procedure Ghdl_Elaborate is - begin - --Ada.Text_IO.Put_Line (Standard_Error, "ghdl_elaborate"); - Elaborate_Proc.all; - end Ghdl_Elaborate; - - procedure Def (Decl : O_Dnode; Addr : Address) - renames Ortho_Jit.Set_Address; - - procedure Foreign_Hook (Decl : Iir; - Info : Translation.Foreign_Info_Type; - Ortho : O_Dnode) - is - use Translation; - Res : Address; - begin - case Info.Kind is - when Foreign_Vhpidirect => - declare - Name : constant String := - Name_Table.Name_Buffer (Info.Subprg_First - .. Info.Subprg_Last); - begin - Res := Foreigns.Find_Foreign (Name); - if Res /= Null_Address then - Def (Ortho, Res); - else - Error_Msg_Sem ("unknown foreign VHPIDIRECT '" & Name & "'", - Decl); - end if; - end; - when Foreign_Intrinsic => - Name_Table.Image (Get_Identifier (Decl)); - declare - Name : constant String := - Name_Table.Name_Buffer (1 .. Name_Table.Name_Length); - begin - if Name = "untruncated_text_read" then - Def (Ortho, Grt.Files.Ghdl_Untruncated_Text_Read'Address); - elsif Name = "control_simulation" then - Def (Ortho, Grt.Lib.Ghdl_Control_Simulation'Address); - elsif Name = "get_resolution_limit" then - Def (Ortho, Grt.Lib.Ghdl_Get_Resolution_Limit'Address); - else - Error_Msg_Sem ("unknown foreign intrinsic '" & Name & "'", - Decl); - end if; - end; - when Foreign_Unknown => - null; - end case; - end Foreign_Hook; - - procedure Run - is - use Interfaces; - --use Ortho_Code.Binary; - - function Conv is new Ada.Unchecked_Conversion - (Source => Address, Target => Elaborate_Acc); - Err : Boolean; - Decl : O_Dnode; - begin - if Flag_Verbose then - Ada.Text_IO.Put_Line ("Linking in memory"); - end if; - - Def (Trans_Decls.Ghdl_Memcpy, - Grt.Lib.Ghdl_Memcpy'Address); - Def (Trans_Decls.Ghdl_Bound_Check_Failed_L1, - Grt.Lib.Ghdl_Bound_Check_Failed_L1'Address); - Def (Trans_Decls.Ghdl_Malloc0, - Grt.Lib.Ghdl_Malloc0'Address); - Def (Trans_Decls.Ghdl_Std_Ulogic_To_Boolean_Array, - Grt.Lib.Ghdl_Std_Ulogic_To_Boolean_Array'Address); - - Def (Trans_Decls.Ghdl_Report, - Grt.Lib.Ghdl_Report'Address); - Def (Trans_Decls.Ghdl_Assert_Failed, - Grt.Lib.Ghdl_Assert_Failed'Address); - Def (Trans_Decls.Ghdl_Ieee_Assert_Failed, - Grt.Lib.Ghdl_Ieee_Assert_Failed'Address); - Def (Trans_Decls.Ghdl_Psl_Assert_Failed, - Grt.Lib.Ghdl_Psl_Assert_Failed'Address); - Def (Trans_Decls.Ghdl_Psl_Cover, - Grt.Lib.Ghdl_Psl_Cover'Address); - Def (Trans_Decls.Ghdl_Psl_Cover_Failed, - Grt.Lib.Ghdl_Psl_Cover_Failed'Address); - Def (Trans_Decls.Ghdl_Program_Error, - Grt.Lib.Ghdl_Program_Error'Address); - Def (Trans_Decls.Ghdl_Malloc, - Grt.Lib.Ghdl_Malloc'Address); - Def (Trans_Decls.Ghdl_Deallocate, - Grt.Lib.Ghdl_Deallocate'Address); - Def (Trans_Decls.Ghdl_Real_Exp, - Grt.Lib.Ghdl_Real_Exp'Address); - Def (Trans_Decls.Ghdl_Integer_Exp, - Grt.Lib.Ghdl_Integer_Exp'Address); - - Def (Trans_Decls.Ghdl_Sensitized_Process_Register, - Grt.Processes.Ghdl_Sensitized_Process_Register'Address); - Def (Trans_Decls.Ghdl_Process_Register, - Grt.Processes.Ghdl_Process_Register'Address); - Def (Trans_Decls.Ghdl_Postponed_Sensitized_Process_Register, - Grt.Processes.Ghdl_Postponed_Sensitized_Process_Register'Address); - Def (Trans_Decls.Ghdl_Postponed_Process_Register, - Grt.Processes.Ghdl_Postponed_Process_Register'Address); - Def (Trans_Decls.Ghdl_Finalize_Register, - Grt.Processes.Ghdl_Finalize_Register'Address); - - Def (Trans_Decls.Ghdl_Stack2_Allocate, - Grt.Processes.Ghdl_Stack2_Allocate'Address); - Def (Trans_Decls.Ghdl_Stack2_Mark, - Grt.Processes.Ghdl_Stack2_Mark'Address); - Def (Trans_Decls.Ghdl_Stack2_Release, - Grt.Processes.Ghdl_Stack2_Release'Address); - Def (Trans_Decls.Ghdl_Process_Wait_Exit, - Grt.Processes.Ghdl_Process_Wait_Exit'Address); - Def (Trans_Decls.Ghdl_Process_Wait_Suspend, - Grt.Processes.Ghdl_Process_Wait_Suspend'Address); - Def (Trans_Decls.Ghdl_Process_Wait_Timeout, - Grt.Processes.Ghdl_Process_Wait_Timeout'Address); - Def (Trans_Decls.Ghdl_Process_Wait_Set_Timeout, - Grt.Processes.Ghdl_Process_Wait_Set_Timeout'Address); - Def (Trans_Decls.Ghdl_Process_Wait_Add_Sensitivity, - Grt.Processes.Ghdl_Process_Wait_Add_Sensitivity'Address); - Def (Trans_Decls.Ghdl_Process_Wait_Close, - Grt.Processes.Ghdl_Process_Wait_Close'Address); - - Def (Trans_Decls.Ghdl_Process_Add_Sensitivity, - Grt.Processes.Ghdl_Process_Add_Sensitivity'Address); - - Def (Trans_Decls.Ghdl_Now, - Grt.Types.Current_Time'Address); - - Def (Trans_Decls.Ghdl_Process_Add_Driver, - Grt.Signals.Ghdl_Process_Add_Driver'Address); - Def (Trans_Decls.Ghdl_Signal_Add_Direct_Driver, - Grt.Signals.Ghdl_Signal_Add_Direct_Driver'Address); - - Def (Trans_Decls.Ghdl_Signal_Add_Source, - Grt.Signals.Ghdl_Signal_Add_Source'Address); - Def (Trans_Decls.Ghdl_Signal_In_Conversion, - Grt.Signals.Ghdl_Signal_In_Conversion'Address); - Def (Trans_Decls.Ghdl_Signal_Out_Conversion, - Grt.Signals.Ghdl_Signal_Out_Conversion'Address); - Def (Trans_Decls.Ghdl_Signal_Effective_Value, - Grt.Signals.Ghdl_Signal_Effective_Value'Address); - Def (Trans_Decls.Ghdl_Signal_Create_Resolution, - Grt.Signals.Ghdl_Signal_Create_Resolution'Address); - - Def (Trans_Decls.Ghdl_Signal_Disconnect, - Grt.Signals.Ghdl_Signal_Disconnect'Address); - Def (Trans_Decls.Ghdl_Signal_Set_Disconnect, - Grt.Signals.Ghdl_Signal_Set_Disconnect'Address); - Def (Trans_Decls.Ghdl_Signal_Merge_Rti, - Grt.Signals.Ghdl_Signal_Merge_Rti'Address); - Def (Trans_Decls.Ghdl_Signal_Name_Rti, - Grt.Signals.Ghdl_Signal_Name_Rti'Address); - Def (Trans_Decls.Ghdl_Signal_Read_Port, - Grt.Signals.Ghdl_Signal_Read_Port'Address); - Def (Trans_Decls.Ghdl_Signal_Read_Driver, - Grt.Signals.Ghdl_Signal_Read_Driver'Address); - - Def (Trans_Decls.Ghdl_Signal_Driving, - Grt.Signals.Ghdl_Signal_Driving'Address); - Def (Trans_Decls.Ghdl_Signal_Driving_Value_B1, - Grt.Signals.Ghdl_Signal_Driving_Value_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Driving_Value_E8, - Grt.Signals.Ghdl_Signal_Driving_Value_E8'Address); - Def (Trans_Decls.Ghdl_Signal_Driving_Value_E32, - Grt.Signals.Ghdl_Signal_Driving_Value_E32'Address); - Def (Trans_Decls.Ghdl_Signal_Driving_Value_I32, - Grt.Signals.Ghdl_Signal_Driving_Value_I32'Address); - Def (Trans_Decls.Ghdl_Signal_Driving_Value_I64, - Grt.Signals.Ghdl_Signal_Driving_Value_I64'Address); - Def (Trans_Decls.Ghdl_Signal_Driving_Value_F64, - Grt.Signals.Ghdl_Signal_Driving_Value_F64'Address); - - Def (Trans_Decls.Ghdl_Signal_Create_Guard, - Grt.Signals.Ghdl_Signal_Create_Guard'Address); - Def (Trans_Decls.Ghdl_Signal_Guard_Dependence, - Grt.Signals.Ghdl_Signal_Guard_Dependence'Address); - - Def (Trans_Decls.Ghdl_Signal_Simple_Assign_Error, - Grt.Signals.Ghdl_Signal_Simple_Assign_Error'Address); - Def (Trans_Decls.Ghdl_Signal_Start_Assign_Error, - Grt.Signals.Ghdl_Signal_Start_Assign_Error'Address); - Def (Trans_Decls.Ghdl_Signal_Next_Assign_Error, - Grt.Signals.Ghdl_Signal_Next_Assign_Error'Address); - - Def (Trans_Decls.Ghdl_Signal_Start_Assign_Null, - Grt.Signals.Ghdl_Signal_Start_Assign_Null'Address); - - Def (Trans_Decls.Ghdl_Signal_Direct_Assign, - Grt.Signals.Ghdl_Signal_Direct_Assign'Address); - - Def (Trans_Decls.Ghdl_Create_Signal_B1, - Grt.Signals.Ghdl_Create_Signal_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Init_B1, - Grt.Signals.Ghdl_Signal_Init_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Simple_Assign_B1, - Grt.Signals.Ghdl_Signal_Simple_Assign_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Start_Assign_B1, - Grt.Signals.Ghdl_Signal_Start_Assign_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Next_Assign_B1, - Grt.Signals.Ghdl_Signal_Next_Assign_B1'Address); - Def (Trans_Decls.Ghdl_Signal_Associate_B1, - Grt.Signals.Ghdl_Signal_Associate_B1'Address); - - Def (Trans_Decls.Ghdl_Create_Signal_E8, - Grt.Signals.Ghdl_Create_Signal_E8'Address); - Def (Trans_Decls.Ghdl_Signal_Init_E8, - Grt.Signals.Ghdl_Signal_Init_E8'Address); - Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E8, - Grt.Signals.Ghdl_Signal_Simple_Assign_E8'Address); - Def (Trans_Decls.Ghdl_Signal_Start_Assign_E8, - Grt.Signals.Ghdl_Signal_Start_Assign_E8'Address); - Def (Trans_Decls.Ghdl_Signal_Next_Assign_E8, - Grt.Signals.Ghdl_Signal_Next_Assign_E8'Address); - Def (Trans_Decls.Ghdl_Signal_Associate_E8, - Grt.Signals.Ghdl_Signal_Associate_E8'Address); - - Def (Trans_Decls.Ghdl_Create_Signal_E32, - Grt.Signals.Ghdl_Create_Signal_E32'Address); - Def (Trans_Decls.Ghdl_Signal_Init_E32, - Grt.Signals.Ghdl_Signal_Init_E32'Address); - Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E32, - Grt.Signals.Ghdl_Signal_Simple_Assign_E32'Address); - Def (Trans_Decls.Ghdl_Signal_Start_Assign_E32, - Grt.Signals.Ghdl_Signal_Start_Assign_E32'Address); - Def (Trans_Decls.Ghdl_Signal_Next_Assign_E32, - Grt.Signals.Ghdl_Signal_Next_Assign_E32'Address); - Def (Trans_Decls.Ghdl_Signal_Associate_E32, - Grt.Signals.Ghdl_Signal_Associate_E32'Address); - - Def (Trans_Decls.Ghdl_Create_Signal_I32, - Grt.Signals.Ghdl_Create_Signal_I32'Address); - Def (Trans_Decls.Ghdl_Signal_Init_I32, - Grt.Signals.Ghdl_Signal_Init_I32'Address); - Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I32, - Grt.Signals.Ghdl_Signal_Simple_Assign_I32'Address); - Def (Trans_Decls.Ghdl_Signal_Start_Assign_I32, - Grt.Signals.Ghdl_Signal_Start_Assign_I32'Address); - Def (Trans_Decls.Ghdl_Signal_Next_Assign_I32, - Grt.Signals.Ghdl_Signal_Next_Assign_I32'Address); - Def (Trans_Decls.Ghdl_Signal_Associate_I32, - Grt.Signals.Ghdl_Signal_Associate_I32'Address); - - Def (Trans_Decls.Ghdl_Create_Signal_I64, - Grt.Signals.Ghdl_Create_Signal_I64'Address); - Def (Trans_Decls.Ghdl_Signal_Init_I64, - Grt.Signals.Ghdl_Signal_Init_I64'Address); - Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I64, - Grt.Signals.Ghdl_Signal_Simple_Assign_I64'Address); - Def (Trans_Decls.Ghdl_Signal_Start_Assign_I64, - Grt.Signals.Ghdl_Signal_Start_Assign_I64'Address); - Def (Trans_Decls.Ghdl_Signal_Next_Assign_I64, - Grt.Signals.Ghdl_Signal_Next_Assign_I64'Address); - Def (Trans_Decls.Ghdl_Signal_Associate_I64, - Grt.Signals.Ghdl_Signal_Associate_I64'Address); - - Def (Trans_Decls.Ghdl_Create_Signal_F64, - Grt.Signals.Ghdl_Create_Signal_F64'Address); - Def (Trans_Decls.Ghdl_Signal_Init_F64, - Grt.Signals.Ghdl_Signal_Init_F64'Address); - Def (Trans_Decls.Ghdl_Signal_Simple_Assign_F64, - Grt.Signals.Ghdl_Signal_Simple_Assign_F64'Address); - Def (Trans_Decls.Ghdl_Signal_Start_Assign_F64, - Grt.Signals.Ghdl_Signal_Start_Assign_F64'Address); - Def (Trans_Decls.Ghdl_Signal_Next_Assign_F64, - Grt.Signals.Ghdl_Signal_Next_Assign_F64'Address); - Def (Trans_Decls.Ghdl_Signal_Associate_F64, - Grt.Signals.Ghdl_Signal_Associate_F64'Address); - - Def (Trans_Decls.Ghdl_Signal_Attribute_Register_Prefix, - Grt.Signals.Ghdl_Signal_Attribute_Register_Prefix'Address); - Def (Trans_Decls.Ghdl_Create_Stable_Signal, - Grt.Signals.Ghdl_Create_Stable_Signal'Address); - Def (Trans_Decls.Ghdl_Create_Quiet_Signal, - Grt.Signals.Ghdl_Create_Quiet_Signal'Address); - Def (Trans_Decls.Ghdl_Create_Transaction_Signal, - Grt.Signals.Ghdl_Create_Transaction_Signal'Address); - Def (Trans_Decls.Ghdl_Create_Delayed_Signal, - Grt.Signals.Ghdl_Create_Delayed_Signal'Address); - - Def (Trans_Decls.Ghdl_Rti_Add_Package, - Grt.Rtis.Ghdl_Rti_Add_Package'Address); - Def (Trans_Decls.Ghdl_Rti_Add_Top, - Grt.Rtis.Ghdl_Rti_Add_Top'Address); - - Def (Trans_Decls.Ghdl_Protected_Enter, - Grt.Processes.Ghdl_Protected_Enter'Address); - Def (Trans_Decls.Ghdl_Protected_Leave, - Grt.Processes.Ghdl_Protected_Leave'Address); - Def (Trans_Decls.Ghdl_Protected_Init, - Grt.Processes.Ghdl_Protected_Init'Address); - Def (Trans_Decls.Ghdl_Protected_Fini, - Grt.Processes.Ghdl_Protected_Fini'Address); - - Def (Trans_Decls.Ghdl_Text_File_Elaborate, - Grt.Files.Ghdl_Text_File_Elaborate'Address); - Def (Trans_Decls.Ghdl_Text_File_Finalize, - Grt.Files.Ghdl_Text_File_Finalize'Address); - Def (Trans_Decls.Ghdl_Text_File_Open, - Grt.Files.Ghdl_Text_File_Open'Address); - Def (Trans_Decls.Ghdl_Text_File_Open_Status, - Grt.Files.Ghdl_Text_File_Open_Status'Address); - Def (Trans_Decls.Ghdl_Text_Write, - Grt.Files.Ghdl_Text_Write'Address); - Def (Trans_Decls.Ghdl_Text_Read_Length, - Grt.Files.Ghdl_Text_Read_Length'Address); - Def (Trans_Decls.Ghdl_Text_File_Close, - Grt.Files.Ghdl_Text_File_Close'Address); - - Def (Trans_Decls.Ghdl_File_Elaborate, - Grt.Files.Ghdl_File_Elaborate'Address); - Def (Trans_Decls.Ghdl_File_Finalize, - Grt.Files.Ghdl_File_Finalize'Address); - Def (Trans_Decls.Ghdl_File_Open, - Grt.Files.Ghdl_File_Open'Address); - Def (Trans_Decls.Ghdl_File_Open_Status, - Grt.Files.Ghdl_File_Open_Status'Address); - Def (Trans_Decls.Ghdl_File_Close, - Grt.Files.Ghdl_File_Close'Address); - Def (Trans_Decls.Ghdl_File_Flush, - Grt.Files.Ghdl_File_Flush'Address); - Def (Trans_Decls.Ghdl_Write_Scalar, - Grt.Files.Ghdl_Write_Scalar'Address); - Def (Trans_Decls.Ghdl_Read_Scalar, - Grt.Files.Ghdl_Read_Scalar'Address); - - Def (Trans_Decls.Ghdl_File_Endfile, - Grt.Files.Ghdl_File_Endfile'Address); - - Def (Trans_Decls.Ghdl_Image_B1, - Grt.Images.Ghdl_Image_B1'Address); - Def (Trans_Decls.Ghdl_Image_E8, - Grt.Images.Ghdl_Image_E8'Address); - Def (Trans_Decls.Ghdl_Image_E32, - Grt.Images.Ghdl_Image_E32'Address); - Def (Trans_Decls.Ghdl_Image_I32, - Grt.Images.Ghdl_Image_I32'Address); - Def (Trans_Decls.Ghdl_Image_F64, - Grt.Images.Ghdl_Image_F64'Address); - Def (Trans_Decls.Ghdl_Image_P64, - Grt.Images.Ghdl_Image_P64'Address); - Def (Trans_Decls.Ghdl_Image_P32, - Grt.Images.Ghdl_Image_P32'Address); - - Def (Trans_Decls.Ghdl_Value_B1, - Grt.Values.Ghdl_Value_B1'Address); - Def (Trans_Decls.Ghdl_Value_E8, - Grt.Values.Ghdl_Value_E8'Address); - Def (Trans_Decls.Ghdl_Value_E32, - Grt.Values.Ghdl_Value_E32'Address); - Def (Trans_Decls.Ghdl_Value_I32, - Grt.Values.Ghdl_Value_I32'Address); - Def (Trans_Decls.Ghdl_Value_F64, - Grt.Values.Ghdl_Value_F64'Address); - Def (Trans_Decls.Ghdl_Value_P32, - Grt.Values.Ghdl_Value_P32'Address); - Def (Trans_Decls.Ghdl_Value_P64, - Grt.Values.Ghdl_Value_P64'Address); - - Def (Trans_Decls.Ghdl_Get_Path_Name, - Grt.Names.Ghdl_Get_Path_Name'Address); - Def (Trans_Decls.Ghdl_Get_Instance_Name, - Grt.Names.Ghdl_Get_Instance_Name'Address); - - Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Eq, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Eq'Address); - Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Ne, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Ne'Address); - Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Lt, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Lt'Address); - Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Le, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Le'Address); - - Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Eq, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Eq'Address); - Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Ne, - Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Ne'Address); - - Def (Trans_Decls.Ghdl_To_String_I32, - Grt.Images.Ghdl_To_String_I32'Address); - Def (Trans_Decls.Ghdl_To_String_F64, - Grt.Images.Ghdl_To_String_F64'Address); - Def (Trans_Decls.Ghdl_To_String_F64_Digits, - Grt.Images.Ghdl_To_String_F64_Digits'Address); - Def (Trans_Decls.Ghdl_To_String_F64_Format, - Grt.Images.Ghdl_To_String_F64_Format'Address); - Def (Trans_Decls.Ghdl_To_String_B1, - Grt.Images.Ghdl_To_String_B1'Address); - Def (Trans_Decls.Ghdl_To_String_E8, - Grt.Images.Ghdl_To_String_E8'Address); - Def (Trans_Decls.Ghdl_To_String_E32, - Grt.Images.Ghdl_To_String_E32'Address); - Def (Trans_Decls.Ghdl_To_String_Char, - Grt.Images.Ghdl_To_String_Char'Address); - Def (Trans_Decls.Ghdl_To_String_P32, - Grt.Images.Ghdl_To_String_P32'Address); - Def (Trans_Decls.Ghdl_To_String_P64, - Grt.Images.Ghdl_To_String_P64'Address); - Def (Trans_Decls.Ghdl_Time_To_String_Unit, - Grt.Images.Ghdl_Time_To_String_Unit'Address); - Def (Trans_Decls.Ghdl_BV_To_Ostring, - Grt.Images.Ghdl_BV_To_Ostring'Address); - Def (Trans_Decls.Ghdl_BV_To_Hstring, - Grt.Images.Ghdl_BV_To_Hstring'Address); - Def (Trans_Decls.Ghdl_Array_Char_To_String_B1, - Grt.Images.Ghdl_Array_Char_To_String_B1'Address); - Def (Trans_Decls.Ghdl_Array_Char_To_String_E8, - Grt.Images.Ghdl_Array_Char_To_String_E8'Address); - Def (Trans_Decls.Ghdl_Array_Char_To_String_E32, - Grt.Images.Ghdl_Array_Char_To_String_E32'Address); - - Ortho_Jit.Link (Err); - if Err then - raise Compile_Error; - end if; - - Grtlink.Std_Standard_Boolean_RTI_Ptr := - Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Boolean_Rti); - Grtlink.Std_Standard_Bit_RTI_Ptr := - Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Bit_Rti); - if Ieee.Std_Logic_1164.Resolved /= Null_Iir then - Decl := Translation.Get_Resolv_Ortho_Decl - (Ieee.Std_Logic_1164.Resolved); - if Decl /= O_Dnode_Null then - Grtlink.Ieee_Std_Logic_1164_Resolved_Resolv_Ptr := - Ortho_Jit.Get_Address (Decl); - end if; - end if; - - Grtlink.Flag_String := Flags.Flag_String; - - Elaborate_Proc := - Conv (Ortho_Jit.Get_Address (Trans_Decls.Ghdl_Elaborate)); - - Ortho_Jit.Finish; - - Translation.Finalize; - Lists.Initialize; - Str_Table.Initialize; - Nodes.Initialize; - Files_Map.Initialize; - Name_Table.Initialize; - - if Flag_Verbose then - Ada.Text_IO.Put_Line ("Starting simulation"); - end if; - - Grt.Main.Run; - --V := Ghdl_Main (1, Gnat_Argv); - end Run; - - - -- Command run help. - type Command_Run_Help is new Command_Type with null record; - function Decode_Command (Cmd : Command_Run_Help; Name : String) - return Boolean; - function Get_Short_Help (Cmd : Command_Run_Help) return String; - procedure Perform_Action (Cmd : in out Command_Run_Help; - Args : Argument_List); - - function Decode_Command (Cmd : Command_Run_Help; Name : String) - return Boolean - is - pragma Unreferenced (Cmd); - begin - return Name = "--run-help"; - end Decode_Command; - - function Get_Short_Help (Cmd : Command_Run_Help) return String - is - pragma Unreferenced (Cmd); - begin - return "--run-help Disp help for RUNOPTS options"; - end Get_Short_Help; - - procedure Perform_Action (Cmd : in out Command_Run_Help; - Args : Argument_List) - is - pragma Unreferenced (Cmd); - use Ada.Text_IO; - begin - if Args'Length /= 0 then - Error - ("warning: command '--run-help' does not accept any argument"); - end if; - Put_Line ("These options can only be placed at [RUNOPTS]"); - -- Register modules, since they add commands. - Grt.Modules.Register_Modules; - -- Bypass usual help header. - Grt.Options.Argc := 0; - Grt.Options.Help; - end Perform_Action; - - procedure Register_Commands - is - begin - Ghdlcomp.Hooks := (Compile_Init'Access, - Compile_Elab'Access, - Set_Run_Options'Access, - Run'Access, - Ortho_Jit.Decode_Option'Access, - Ortho_Jit.Disp_Help'Access); - Ghdlcomp.Register_Commands; - Register_Command (new Command_Run_Help); - Trans_Be.Register_Translation_Back_End; - end Register_Commands; -end Ghdlrun; diff --git a/src/translate/ghdldrv/ghdlrun.ads b/src/translate/ghdldrv/ghdlrun.ads deleted file mode 100644 index 07095bd5d..000000000 --- a/src/translate/ghdldrv/ghdlrun.ads +++ /dev/null @@ -1,20 +0,0 @@ --- GHDL driver - JIT commands. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package Ghdlrun is - procedure Register_Commands; -end Ghdlrun; diff --git a/src/translate/ghdldrv/ghdlsimul.adb b/src/translate/ghdldrv/ghdlsimul.adb deleted file mode 100644 index 17cece726..000000000 --- a/src/translate/ghdldrv/ghdlsimul.adb +++ /dev/null @@ -1,209 +0,0 @@ --- GHDL driver - simulator commands. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ada.Text_IO; -with Ada.Command_Line; - -with Ghdllocal; use Ghdllocal; -with GNAT.OS_Lib; use GNAT.OS_Lib; - -with Types; -with Iirs; use Iirs; -with Flags; -with Back_End; -with Name_Table; -with Errorout; use Errorout; -with Std_Package; -with Libraries; -with Canon; -with Configuration; -with Iirs_Utils; -with Annotations; -with Elaboration; -with Sim_Be; -with Simulation; -with Execution; - -with Ghdlcomp; - -with Grt.Vpi; -pragma Unreferenced (Grt.Vpi); -with Grt.Types; -with Grt.Options; -with Grtlink; - -package body Ghdlsimul is - - -- FIXME: reuse simulation.top_config - Top_Conf : Iir; - - procedure Compile_Init (Analyze_Only : Boolean) is - begin - if Analyze_Only then - return; - end if; - - -- Initialize. - Back_End.Finish_Compilation := Sim_Be.Finish_Compilation'Access; - Back_End.Sem_Foreign := null; - - Setup_Libraries (False); - Libraries.Load_Std_Library; - - -- Here, time_base can be set. - Annotations.Annotate (Std_Package.Std_Standard_Unit); - - Canon.Canon_Flag_Add_Labels := True; - Canon.Canon_Flag_Sequentials_Stmts := True; - Canon.Canon_Flag_Expressions := True; - Canon.Canon_Flag_All_Sensitivity := True; - end Compile_Init; - - procedure Compile_Elab - (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural) - is - use Name_Table; - use Types; - - First_Id : Name_Id; - Sec_Id : Name_Id; - begin - Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg); - - Flags.Flag_Elaborate := True; - -- Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True); - - if Errorout.Nbr_Errors > 0 then - -- This may happen (bad entity for example). - raise Compilation_Error; - end if; - - First_Id := Get_Identifier (Prim_Name.all); - if Sec_Name = null then - Sec_Id := Null_Identifier; - else - Sec_Id := Get_Identifier (Sec_Name.all); - end if; - Top_Conf := Configuration.Configure (First_Id, Sec_Id); - if Top_Conf = Null_Iir then - raise Compilation_Error; - end if; - - -- Check (and possibly abandon) if entity can be at the top of the - -- hierarchy. - declare - Conf_Unit : constant Iir := Get_Library_Unit (Top_Conf); - Arch : constant Iir := - Get_Block_Specification (Get_Block_Configuration (Conf_Unit)); - Entity : constant Iir := Iirs_Utils.Get_Entity (Arch); - begin - Configuration.Check_Entity_Declaration_Top (Entity); - if Nbr_Errors > 0 then - raise Compilation_Error; - end if; - end; - end Compile_Elab; - - -- Set options. - procedure Set_Run_Options (Args : Argument_List) - is - use Grt.Options; - use Types; - Arg : String_Access; - Status : Decode_Option_Status; - Argv0 : String_Acc; - begin - -- Set progname (used for grt error messages) - Argv0 := new String'(Ada.Command_Line.Command_Name & ASCII.Nul); - Grt.Options.Progname := Grt.Types.To_Ghdl_C_String (Argv0.all'Address); - - for I in Args'Range loop - Arg := Args (I); - if Arg.all = "--disp-tree" then - Simulation.Disp_Tree := True; - elsif Arg.all = "--expect-failure" then - Decode_Option (Arg.all, Status); - pragma Assert (Status = Decode_Option_Ok); - elsif Arg.all = "--trace-elab" then - Elaboration.Trace_Elaboration := True; - elsif Arg.all = "--trace-drivers" then - Elaboration.Trace_Drivers := True; - elsif Arg.all = "--trace-annotation" then - Annotations.Trace_Annotation := True; - elsif Arg.all = "--trace-simu" then - Simulation.Trace_Simulation := True; - elsif Arg.all = "--trace-stmt" then - Execution.Trace_Statements := True; - elsif Arg.all = "--stats" then - Simulation.Disp_Stats := True; - elsif Arg.all = "-i" then - Simulation.Flag_Interractive := True; - else - Decode_Option (Arg.all, Status); - case Status is - when Decode_Option_Last => - exit; - when Decode_Option_Help => - -- FIXME: is that correct ? - exit; - when Decode_Option_Ok => - null; - end case; - -- Ghdlmain.Error ("unknown run options '" & Arg.all & "'"); - -- raise Option_Error; - end if; - end loop; - end Set_Run_Options; - - procedure Run is - begin - Grtlink.Flag_String := Flags.Flag_String; - - Simulation.Simulation_Entity (Top_Conf); - end Run; - - function Decode_Option (Option : String) return Boolean - is - begin - if Option = "--debug" then - Simulation.Flag_Debugger := True; - else - return False; - end if; - return True; - end Decode_Option; - - procedure Disp_Long_Help - is - use Ada.Text_IO; - begin - Put_Line (" --debug Run with debugger"); - end Disp_Long_Help; - - procedure Register_Commands - is - begin - Ghdlcomp.Hooks := (Compile_Init'Access, - Compile_Elab'Access, - Set_Run_Options'Access, - Run'Access, - Decode_Option'Access, - Disp_Long_Help'Access); - Ghdlcomp.Register_Commands; - end Register_Commands; -end Ghdlsimul; diff --git a/src/translate/ghdldrv/ghdlsimul.ads b/src/translate/ghdldrv/ghdlsimul.ads deleted file mode 100644 index 264cbf8c6..000000000 --- a/src/translate/ghdldrv/ghdlsimul.ads +++ /dev/null @@ -1,20 +0,0 @@ --- GHDL driver - simulator commands. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -package Ghdlsimul is - procedure Register_Commands; -end Ghdlsimul; diff --git a/src/translate/ghdldrv/grtlink.ads b/src/translate/ghdldrv/grtlink.ads deleted file mode 100644 index 4b3951e78..000000000 --- a/src/translate/ghdldrv/grtlink.ads +++ /dev/null @@ -1,39 +0,0 @@ --- GHDL driver - shared variables with grt. --- Copyright (C) 2011 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System; use System; - -package Grtlink is - - Flag_String : String (1 .. 5); - pragma Export (C, Flag_String, "__ghdl_flag_string"); - - Std_Standard_Bit_RTI_Ptr : Address := Null_Address; - - Std_Standard_Boolean_RTI_Ptr : Address := Null_Address; - - pragma Export (C, Std_Standard_Bit_RTI_Ptr, - "std__standard__bit__RTI_ptr"); - - pragma Export (C, Std_Standard_Boolean_RTI_Ptr, - "std__standard__boolean__RTI_ptr"); - - Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address := Null_Address; - pragma Export (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr, - "ieee__std_logic_1164__resolved_RESOLV_ptr"); - -end Grtlink; diff --git a/src/translate/grt/Makefile b/src/translate/grt/Makefile deleted file mode 100644 index 107aef7bf..000000000 --- a/src/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/src/translate/grt/Makefile.inc b/src/translate/grt/Makefile.inc deleted file mode 100644 index ec1b0df09..000000000 --- a/src/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/src/translate/grt/config/Makefile b/src/translate/grt/config/Makefile deleted file mode 100644 index 7d5f57def..000000000 --- a/src/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/src/translate/grt/config/amd64.S b/src/translate/grt/config/amd64.S deleted file mode 100644 index 0a7f0044b..000000000 --- a/src/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/src/translate/grt/config/chkstk.S b/src/translate/grt/config/chkstk.S deleted file mode 100644 index ab244d0cd..000000000 --- a/src/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/src/translate/grt/config/clock.c b/src/translate/grt/config/clock.c deleted file mode 100644 index 242af604b..000000000 --- a/src/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 - -int -grt_get_clk_tck (void) -{ - return CLOCKS_PER_SEC; -} - -void -grt_get_times (int *wall, int *user, int *sys) -{ - clock_t res; - - *wall = clock (); - *user = 0; - *sys = 0; -} - diff --git a/src/translate/grt/config/i386.S b/src/translate/grt/config/i386.S deleted file mode 100644 index 00d4719ac..000000000 --- a/src/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/src/translate/grt/config/ia64.S b/src/translate/grt/config/ia64.S deleted file mode 100644 index 9ce3800bb..000000000 --- a/src/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/src/translate/grt/config/linux.c b/src/translate/grt/config/linux.c deleted file mode 100644 index 74dce0903..000000000 --- a/src/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 -#include -#include -#include -#include -#include -//#include - -#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 -static int run_env_en; -static jmp_buf run_env; - -void -__ghdl_maybe_return_via_longjump (int val) -{ - if (run_env_en) - longjmp (run_env, val); -} - -int -__ghdl_run_through_longjump (int (*func)(void)) -{ - int res; - - run_env_en = 1; - res = setjmp (run_env); - if (res == 0) - res = (*func)(); - run_env_en = 0; - return res; -} - diff --git a/src/translate/grt/config/ppc.S b/src/translate/grt/config/ppc.S deleted file mode 100644 index bedd48ab4..000000000 --- a/src/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/src/translate/grt/config/pthread.c b/src/translate/grt/config/pthread.c deleted file mode 100644 index 189ae90c8..000000000 --- a/src/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 -#include -#include -#include -#include - -//#define INFO printf -#define INFO (void) - -// GHDL names an endless loop calling FUNC with ARG a 'stack' -// at a given time, only one stack may be 'executed' -typedef struct -{ - pthread_t thread; // stack's thread - pthread_mutex_t mutex; // mutex to suspend/resume thread -#if defined(__CYGWIN__) - pthread_mutexattr_t mxAttr; -#endif - void (*Func)(void*); // stack's FUNC - void* Arg; // ARG passed to FUNC -} Stack_Type_t, *Stack_Type; - -static Stack_Type_t main_stack_context; -static Stack_Type_t *current; -extern void grt_set_main_stack (Stack_Type_t *stack); - -//---------------------------------------------------------------------------- -void grt_stack_init(void) -// Initialize the stacks package. -// This may adjust stack sizes. -// Must be called after grt.options.decode. -// => procedure Stack_Init; -{ - int res; - INFO("grt_stack_init\n"); - INFO(" main_stack_context=0x%08x\n", &main_stack_context); - - -#if defined(__CYGWIN__) - res = pthread_mutexattr_init (&main_stack_context.mxAttr); - assert (res == 0); - res = pthread_mutexattr_settype (&main_stack_context.mxAttr, - PTHREAD_MUTEX_DEFAULT); - assert (res == 0); - res = pthread_mutex_init (&main_stack_context.mutex, - &main_stack_context.mxAttr); - assert (res == 0); -#else - res = pthread_mutex_init (&main_stack_context.mutex, NULL); - assert (res == 0); -#endif - // lock the mutex, as we are currently running - res = pthread_mutex_lock (&main_stack_context.mutex); - assert (res == 0); - - current = &main_stack_context; - - grt_set_main_stack (&main_stack_context); -} - -//---------------------------------------------------------------------------- -static void* grt_stack_loop(void* pv_myStack) -{ - Stack_Type myStack= (Stack_Type)pv_myStack; - - INFO("grt_stack_loop\n"); - - INFO(" myStack=0x%08x\n", myStack); - - // block until mutex becomes available again. - // this happens when this stack is enabled for the first time - pthread_mutex_lock(&(myStack->mutex)); - - // run stack's function in endless loop - while(1) - { - INFO(" call 0x%08x with 0x%08x\n", myStack->Func, myStack->Arg); - myStack->Func(myStack->Arg); - } - - // we never get here... - return 0; -} - -//---------------------------------------------------------------------------- -Stack_Type grt_stack_create(void* Func, void* Arg) -// Create a new stack, which on first execution will call FUNC with -// an argument ARG. -// => function Stack_Create (Func : Address; Arg : Address) return Stack_Type; -{ - Stack_Type newStack; - int res; - - INFO("grt_stack_create\n"); - INFO(" call 0x%08x with 0x%08x\n", Func, Arg); - - newStack = malloc (sizeof(Stack_Type_t)); - - // init function and argument - newStack->Func = Func; - newStack->Arg = Arg; - - // create mutex -#if defined(__CYGWIN__) - res = pthread_mutexattr_init (&newStack->mxAttr); - assert (res == 0); - res = pthread_mutexattr_settype (&newStack->mxAttr, PTHREAD_MUTEX_DEFAULT); - assert (res == 0); - res = pthread_mutex_init (&newStack->mutex, &newStack->mxAttr); - assert (res == 0); -#else - res = pthread_mutex_init (&newStack->mutex, NULL); - assert (res == 0); -#endif - - // block the mutex, so that thread will blocked in grt_stack_loop - res = pthread_mutex_lock (&newStack->mutex); - assert (res == 0); - - INFO(" newStack=0x%08x\n", newStack); - - // create thread, which executes grt_stack_loop - pthread_create (&newStack->thread, NULL, grt_stack_loop, newStack); - - return newStack; -} - -static int need_longjmp; -static int run_env_en; -static jmp_buf run_env; - -//---------------------------------------------------------------------------- -void grt_stack_switch(Stack_Type To, Stack_Type From) -// Resume stack TO and save the current context to the stack pointed by -// CUR. -// => procedure Stack_Switch (To : Stack_Type; From : Stack_Type); -{ - int res; - INFO("grt_stack_switch\n"); - INFO(" from 0x%08x to 0x%08x\n", From, To); - - current = To; - - // unlock 'To' mutex. this will make the other thread either - // - starts for first time in grt_stack_loop - // - resumes at lock below - res = pthread_mutex_unlock (&To->mutex); - assert (res == 0); - - // block until 'From' mutex becomes available again - // as we are running, our mutex is locked and we block here - // when stacks are switched, with above unlock, we may proceed - res = pthread_mutex_lock (&From->mutex); - assert (res == 0); - - if (From == &main_stack_context && need_longjmp != 0) - longjmp (run_env, need_longjmp); -} - -//---------------------------------------------------------------------------- -void grt_stack_delete(Stack_Type Stack) -// Delete stack STACK, which must not be currently executed. -// => procedure Stack_Delete (Stack : Stack_Type); -{ - INFO("grt_stack_delete\n"); -} - -void -__ghdl_maybe_return_via_longjump (int val) -{ - if (!run_env_en) - return; - - if (current != &main_stack_context) - { - need_longjmp = val; - grt_stack_switch (&main_stack_context, current); - } - else - longjmp (run_env, val); -} - -int -__ghdl_run_through_longjump (int (*func)(void)) -{ - int res; - - run_env_en = 1; - res = setjmp (run_env); - if (res == 0) - res = (*func)(); - run_env_en = 0; - return res; -} - - -//---------------------------------------------------------------------------- - -#ifndef WITH_GNAT_RUN_TIME -void __gnat_raise_storage_error(void) -{ - abort (); -} - -void __gnat_raise_program_error(void) -{ - abort (); -} -#endif /* WITH_GNAT_RUN_TIME */ - -//---------------------------------------------------------------------------- -// end of file - diff --git a/src/translate/grt/config/sparc.S b/src/translate/grt/config/sparc.S deleted file mode 100644 index 0ffe412ed..000000000 --- a/src/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/src/translate/grt/config/teststack.c b/src/translate/grt/config/teststack.c deleted file mode 100644 index 6a6966d6f..000000000 --- a/src/translate/grt/config/teststack.c +++ /dev/null @@ -1,174 +0,0 @@ -#include -#include - -extern void grt_stack_init (void); -extern void grt_stack_switch (void *from, void *to); -extern void *grt_stack_create (void (*func)(void *), void *arg); - -int stack_size = 4096; -int stack_max_size = 8 * 4096; - -static void *stack1; -static void *stack2; -void *grt_stack_main_stack; - -void *grt_cur_proc; - -static int step; - -void -grt_overflow_error (void) -{ - abort (); -} - -void -grt_stack_error_null_access (void) -{ - abort (); -} - -void -grt_stack_error_memory_access (void) -{ - abort (); -} - -void -grt_stack_error_grow_failed (void) -{ - abort (); -} - -void -error (void) -{ - printf ("Test failure at step %d\n", step); - fflush (stdout); - exit (1); -} - -static void -func1 (void *ptr) -{ - if (ptr != (void *)1) - error (); - - if (step != 0) - error (); - - step = 1; - - grt_stack_switch (grt_stack_main_stack, stack1); - - if (step != 5) - error (); - - step = 6; - - grt_stack_switch (grt_stack_main_stack, stack1); - - if (step != 7) - error (); - - step = 8; - - grt_stack_switch (stack2, stack1); - - if (step != 9) - error (); - - step = 10; - - grt_stack_switch (grt_stack_main_stack, stack1); - - error (); -} - -static void -func2 (void *ptr) -{ - if (ptr != (void *)2) - error (); - - if (step == 11) - { - step = 12; - - grt_stack_switch (grt_stack_main_stack, stack2); - - error (); - } - - if (step != 1) - error (); - - step = 2; - - grt_stack_switch (grt_stack_main_stack, stack2); - - if (step != 3) - error (); - - step = 4; - - grt_stack_switch (grt_stack_main_stack, stack2); - - if (step != 8) - error (); - - step = 9; - - grt_stack_switch (stack1, stack2); -} - -int -main (void) -{ - grt_stack_init (); - - stack1 = grt_stack_create (&func1, (void *)1); - stack2 = grt_stack_create (&func2, (void *)2); - - step = 0; - grt_stack_switch (stack1, grt_stack_main_stack); - - if (step != 1) - error (); - - grt_stack_switch (stack2, grt_stack_main_stack); - - if (step != 2) - error (); - - step = 3; - - grt_stack_switch (stack2, grt_stack_main_stack); - - if (step != 4) - error (); - - step = 5; - - grt_stack_switch (stack1, grt_stack_main_stack); - - if (step != 6) - error (); - - step = 7; - - grt_stack_switch (stack1, grt_stack_main_stack); - - if (step != 10) - error (); - - step = 11; - - grt_stack_switch (stack2, grt_stack_main_stack); - - if (step != 12) - error (); - - printf ("Test successful\n"); - return 0; -} diff --git a/src/translate/grt/config/times.c b/src/translate/grt/config/times.c deleted file mode 100644 index 9c0b4ebba..000000000 --- a/src/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 -#include - -int -grt_get_clk_tck (void) -{ - return sysconf (_SC_CLK_TCK); -} - -void -grt_get_times (int *wall, int *user, int *sys) -{ - clock_t res; - struct tms buf; - - res = times (&buf); - if (res == (clock_t)-1) - { - *wall = 0; - *user = 0; - *sys = 0; - } - else - { - *wall = res; - *user = buf.tms_utime; - *sys = buf.tms_stime; - } -} - diff --git a/src/translate/grt/config/win32.c b/src/translate/grt/config/win32.c deleted file mode 100644 index 35322ba9f..000000000 --- a/src/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 -#include -#include -#include -#include - -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 - -double acosh (double x) -{ - return log (x + sqrt (x*x - 1)); -} - -double asinh (double x) -{ - return log (x + sqrt (x*x + 1)); -} - -double atanh (double x) -{ - return log ((1 + x) / (1 - x)) / 2; -} - -#ifndef WITH_GNAT_RUN_TIME -void __gnat_raise_storage_error(void) -{ - abort (); -} - -void __gnat_raise_program_error(void) -{ - abort (); -} -#endif - diff --git a/src/translate/grt/config/win32thr.c b/src/translate/grt/config/win32thr.c deleted file mode 100644 index bcebc49d5..000000000 --- a/src/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 -//#include -//#include -//#include - - -//#define INFO printf -#define INFO (void) - -// GHDL names an endless loop calling FUNC with ARG a 'stack' -// at a given time, only one stack may be 'executed' -typedef struct -{ HANDLE thread; // stack's thread - HANDLE mutex; // mutex to suspend/resume thread - void (*Func)(void*); // stack's FUNC - void* Arg; // ARG passed to FUNC -} Stack_Type_t, *Stack_Type; - - -static Stack_Type_t main_stack_context; -extern void grt_set_main_stack (Stack_Type_t *stack); - -//------------------------------------------------------------------------------ -void grt_stack_init(void) -// Initialize the stacks package. -// This may adjust stack sizes. -// Must be called after grt.options.decode. -// => procedure Stack_Init; -{ INFO("grt_stack_init\n"); - INFO(" main_stack_context=0x%08x\n", &main_stack_context); - - // create event. reset event, as we are currently running - main_stack_context.mutex = CreateEvent(NULL, // lpsa - FALSE, // fManualReset - FALSE, // fInitialState - NULL); // lpszEventName - - grt_set_main_stack (&main_stack_context); -} - -//------------------------------------------------------------------------------ -static unsigned long __stdcall grt_stack_loop(void* pv_myStack) -{ - Stack_Type myStack= (Stack_Type)pv_myStack; - - INFO("grt_stack_loop\n"); - - INFO(" myStack=0x%08x\n", myStack); - - // block until event becomes set again. - // this happens when this stack is enabled for the first time - WaitForSingleObject(myStack->mutex, INFINITE); - - // run stack's function in endless loop - while(1) - { INFO(" call 0x%08x with 0x%08x\n", myStack->Func, myStack->Arg); - myStack->Func(myStack->Arg); - } - - // we never get here... - return 0; -} - -//------------------------------------------------------------------------------ -Stack_Type grt_stack_create(void* Func, void* Arg) -// Create a new stack, which on first execution will call FUNC with -// an argument ARG. -// => function Stack_Create (Func : Address; Arg : Address) return Stack_Type; -{ Stack_Type newStack; - DWORD m_IDThread; // Thread's ID (dummy) - - INFO("grt_stack_create\n"); - INFO(" call 0x%08x with 0x%08x\n", Func, Arg); - - newStack= malloc(sizeof(Stack_Type_t)); - - // init function and argument - newStack->Func= Func; - newStack->Arg= Arg; - - // create event. reset event, so that thread will blocked in grt_stack_loop - newStack->mutex= CreateEvent(NULL, // lpsa - FALSE, // fManualReset - FALSE, // fInitialState - NULL); // lpszEventName - - INFO(" newStack=0x%08x\n", newStack); - - // create thread, which executes grt_stack_loop - newStack->thread= CreateThread(NULL, // lpsa - 0, // cbStack - grt_stack_loop, // lpStartAddr - newStack, // lpvThreadParm - 0, // fdwCreate - &m_IDThread); // lpIDThread - - return newStack; -} - -//------------------------------------------------------------------------------ -void grt_stack_switch(Stack_Type To, Stack_Type From) -// Resume stack TO and save the current context to the stack pointed by -// CUR. -// => procedure Stack_Switch (To : Stack_Type; From : Stack_Type); -{ INFO("grt_stack_switch\n"); - INFO(" from 0x%08x to 0x%08x\n", From, To); - - // set 'To' event. this will make the other thread either - // - start for first time in grt_stack_loop - // - resume at WaitForSingleObject below - SetEvent(To->mutex); - - // block until 'From' event becomes set again - // as we are running, our event is reset and we block here - // when stacks are switched, with above SetEvent, we may proceed - WaitForSingleObject(From->mutex, INFINITE); -} - -//------------------------------------------------------------------------------ -void grt_stack_delete(Stack_Type Stack) -// Delete stack STACK, which must not be currently executed. -// => procedure Stack_Delete (Stack : Stack_Type); -{ INFO("grt_stack_delete\n"); -} - -//---------------------------------------------------------------------------- -#ifndef WITH_GNAT_RUN_TIME -void __gnat_raise_storage_error(void) -{ - abort (); -} - -void __gnat_raise_program_error(void) -{ - abort (); -} -#endif - -//---------------------------------------------------------------------------- -// end of file - diff --git a/src/translate/grt/ghdl_main.adb b/src/translate/grt/ghdl_main.adb deleted file mode 100644 index ce5b67d7e..000000000 --- a/src/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/src/translate/grt/ghdl_main.ads b/src/translate/grt/ghdl_main.ads deleted file mode 100644 index 88d181a0a..000000000 --- a/src/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/src/translate/grt/ghwdump.c b/src/translate/grt/ghwdump.c deleted file mode 100644 index 4affc2b5c..000000000 --- a/src/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 -#include -#include -#include -#include - -#include "ghwlib.h" - -static const char *progname; -void -usage (void) -{ - printf ("usage: %s [OPTIONS] FILEs...\n", progname); - printf ("Options are:\n" - " -t display types\n" - " -h display hierarchy\n" - " -T display time\n" - " -s display signals (and time)\n" - " -l display list of sections\n" - " -v verbose\n"); -} - -int -main (int argc, char **argv) -{ - int i; - int flag_disp_types; - int flag_disp_hierarchy; - int flag_disp_time; - int flag_disp_signals; - int flag_list; - int flag_verbose; - int eof; - enum ghw_sm_type sm; - - progname = argv[0]; - flag_disp_types = 0; - flag_disp_hierarchy = 0; - flag_disp_time = 0; - flag_disp_signals = 0; - flag_list = 0; - flag_verbose = 0; - - while (1) - { - int c; - - c = getopt (argc, argv, "thTslv"); - if (c == -1) - break; - switch (c) - { - case 't': - flag_disp_types = 1; - break; - case 'h': - flag_disp_hierarchy = 1; - break; - case 'T': - flag_disp_time = 1; - break; - case 's': - flag_disp_signals = 1; - flag_disp_time = 1; - break; - case 'l': - flag_list = 1; - break; - case 'v': - flag_verbose++; - break; - default: - usage (); - exit (2); - } - } - - if (optind >= argc) - { - usage (); - return 1; - } - - for (i = optind; i < argc; i++) - { - struct ghw_handler h; - struct ghw_handler *hp = &h; - - hp->flag_verbose = flag_verbose; - - if (ghw_open (hp, argv[i]) != 0) - { - fprintf (stderr, "cannot open ghw file %s\n", argv[i]); - return 1; - } - if (flag_list) - { - while (1) - { - int section; - - section = ghw_read_section (hp); - if (section == -2) - { - printf ("eof of file\n"); - break; - } - else if (section < 0) - { - printf ("Error in file\n"); - break; - } - else if (section == 0) - { - printf ("Unknown section\n"); - break; - } - printf ("Section %s\n", ghw_sections[section].name); - if ((*ghw_sections[section].handler)(hp) < 0) - break; - } - } - else - { - if (ghw_read_base (hp) < 0) - { - fprintf (stderr, "cannot read ghw file\n"); - return 2; - } - if (0) - { - int i; - printf ("String table:\n"); - - for (i = 1; i < hp->nbr_str; i++) - printf (" %s\n", hp->str_table[i]); - } - if (flag_disp_types) - ghw_disp_types (hp); - if (flag_disp_hierarchy) - ghw_disp_hie (hp, hp->hie); - -#if 1 - sm = ghw_sm_init; - eof = 0; - while (!eof) - { - switch (ghw_read_sm (hp, &sm)) - { - case ghw_res_snapshot: - case ghw_res_cycle: - if (flag_disp_time) - printf ("Time is %lld fs\n", hp->snap_time); - if (flag_disp_signals) - ghw_disp_values (hp); - break; - case ghw_res_eof: - eof = 1; - break; - default: - abort (); - } - } - -#else - if (ghw_read_dump (hp) < 0) - { - fprintf (stderr, "error in ghw dump\n"); - return 3; - } -#endif - } - ghw_close (&h); - } - return 0; -} diff --git a/src/translate/grt/ghwlib.c b/src/translate/grt/ghwlib.c deleted file mode 100644 index 2db63d9c9..000000000 --- a/src/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 -#include -#include -#include - -#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] = ""; - p = h->str_content; - prev_len = 0; - for (i = 1; i < h->nbr_str; i++) - { - int j; - int c; - char *prev; - int sh; - - h->str_table[i] = p; - prev = h->str_table[i - 1]; - for (j = 0; j < prev_len; j++) - *p++ = prev[j]; - - while (1) - { - c = fgetc (h->stream); - if (c == EOF) - return -1; - if ((c >= 0 && c <= 31) - || (c >= 128 && c <= 159)) - break; - *p++ = c; - } - *p++ = 0; - - if (h->flag_verbose > 1) - printf (" string %d (pl=%d): %s\n", i, prev_len, h->str_table[i]); - - prev_len = c & 0x1f; - sh = 5; - while (c >= 128) - { - c = fgetc (h->stream); - if (c == EOF) - return -1; - prev_len |= (c & 0x1f) << sh; - sh += 5; - } - } - if (fread (hdr, 4, 1, h->stream) != 1) - return -1; - if (memcmp (hdr, "EOS", 4) != 0) - return -1; - return 0; -} - -union ghw_type * -ghw_get_base_type (union ghw_type *t) -{ - switch (t->kind) - { - case ghdl_rtik_type_b2: - case ghdl_rtik_type_e8: - case ghdl_rtik_type_e32: - case ghdl_rtik_type_i32: - case ghdl_rtik_type_i64: - case ghdl_rtik_type_f64: - case ghdl_rtik_type_p32: - case ghdl_rtik_type_p64: - return t; - case ghdl_rtik_subtype_scalar: - return t->ss.base; - case ghdl_rtik_subtype_array: - return (union ghw_type*)(t->sa.base); - default: - fprintf (stderr, "ghw_get_base_type: cannot handle type %d\n", t->kind); - abort (); - } -} - -int -get_nbr_elements (union ghw_type *t) -{ - switch (t->kind) - { - case ghdl_rtik_type_b2: - case ghdl_rtik_type_e8: - case ghdl_rtik_type_e32: - case ghdl_rtik_type_i32: - case ghdl_rtik_type_i64: - case ghdl_rtik_type_f64: - case ghdl_rtik_type_p32: - case ghdl_rtik_type_p64: - case ghdl_rtik_subtype_scalar: - return 1; - case ghdl_rtik_subtype_array: - case ghdl_rtik_subtype_array_ptr: - return t->sa.nbr_el; - case ghdl_rtik_type_record: - return t->rec.nbr_el; - default: - fprintf (stderr, "get_nbr_elements: unhandled type %d\n", t->kind); - abort (); - } -} - -int -get_range_length (union ghw_range *rng) -{ - switch (rng->kind) - { - case ghdl_rtik_type_i32: - if (rng->i32.dir) - return (rng->i32.left - rng->i32.right + 1); - else - return (rng->i32.right - rng->i32.left + 1); - default: - fprintf (stderr, "get_range_length: unhandled kind %d\n", rng->kind); - abort (); - } -} - -int -ghw_read_type (struct ghw_handler *h) -{ - unsigned char hdr[8]; - int i; - - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - return -1; - - if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) - return -1; - h->nbr_types = ghw_get_i32 (h, &hdr[4]); - h->types = (union ghw_type **) - malloc (h->nbr_types * sizeof (union ghw_type *)); - - for (i = 0; i < h->nbr_types; i++) - { - int t; - - t = fgetc (h->stream); - if (t == EOF) - return -1; - /* printf ("type[%d]= %d\n", i, t); */ - switch (t) - { - case ghdl_rtik_type_b2: - case ghdl_rtik_type_e8: - { - struct ghw_type_enum *e; - int j; - - e = malloc (sizeof (struct ghw_type_enum)); - e->kind = t; - e->wkt = ghw_wkt_unknown; - e->name = ghw_read_strid (h); - if (ghw_read_uleb128 (h, &e->nbr) != 0) - return -1; - e->lits = (const char **) malloc (e->nbr * sizeof (char *)); - if (h->flag_verbose > 1) - printf ("enum %s:", e->name); - for (j = 0; j < e->nbr; j++) - { - e->lits[j] = ghw_read_strid (h); - if (h->flag_verbose > 1) - printf (" %s", e->lits[j]); - } - if (h->flag_verbose > 1) - printf ("\n"); - h->types[i] = (union ghw_type *)e; - } - break; - case ghdl_rtik_type_i32: - case ghdl_rtik_type_i64: - case ghdl_rtik_type_f64: - { - struct ghw_type_scalar *sc; - - sc = malloc (sizeof (struct ghw_type_scalar)); - sc->kind = t; - sc->name = ghw_read_strid (h); - if (h->flag_verbose > 1) - printf ("scalar: %s\n", sc->name); - h->types[i] = (union ghw_type *)sc; - } - break; - case ghdl_rtik_type_p32: - case ghdl_rtik_type_p64: - { - struct ghw_type_physical *ph; - - ph = malloc (sizeof (struct ghw_type_physical)); - ph->kind = t; - ph->name = ghw_read_strid (h); - if (h->version == 0) - ph->nbr_units = 0; - else - { - int i; - - if (ghw_read_uleb128 (h, &ph->nbr_units) != 0) - return -1; - ph->units = malloc (ph->nbr_units * sizeof (struct ghw_unit)); - for (i = 0; i < ph->nbr_units; i++) - { - ph->units[i].name = ghw_read_strid (h); - if (ghw_read_lsleb128 (h, &ph->units[i].val) < 0) - return -1; - } - } - if (h->flag_verbose > 1) - printf ("physical: %s\n", ph->name); - h->types[i] = (union ghw_type *)ph; - } - break; - case ghdl_rtik_subtype_scalar: - { - struct ghw_subtype_scalar *ss; - - ss = malloc (sizeof (struct ghw_subtype_scalar)); - ss->kind = t; - ss->name = ghw_read_strid (h); - ss->base = ghw_read_typeid (h); - ss->rng = ghw_read_range (h); - if (h->flag_verbose > 1) - printf ("subtype scalar: %s\n", ss->name); - h->types[i] = (union ghw_type *)ss; - } - break; - case ghdl_rtik_type_array: - { - struct ghw_type_array *arr; - int j; - - arr = malloc (sizeof (struct ghw_type_array)); - arr->kind = t; - arr->name = ghw_read_strid (h); - arr->el = ghw_read_typeid (h); - if (ghw_read_uleb128 (h, &arr->nbr_dim) != 0) - return -1; - arr->dims = (union ghw_type **) - malloc (arr->nbr_dim * sizeof (union ghw_type *)); - for (j = 0; j < arr->nbr_dim; j++) - arr->dims[j] = ghw_read_typeid (h); - if (h->flag_verbose > 1) - printf ("array: %s\n", arr->name); - h->types[i] = (union ghw_type *)arr; - } - break; - case ghdl_rtik_subtype_array: - case ghdl_rtik_subtype_array_ptr: - { - struct ghw_subtype_array *sa; - int j; - int nbr_el; - - sa = malloc (sizeof (struct ghw_subtype_array)); - sa->kind = t; - sa->name = ghw_read_strid (h); - sa->base = (struct ghw_type_array *)ghw_read_typeid (h); - nbr_el = get_nbr_elements (sa->base->el); - sa->rngs = malloc (sa->base->nbr_dim * sizeof (union ghw_range *)); - for (j = 0; j < sa->base->nbr_dim; j++) - { - sa->rngs[j] = ghw_read_range (h); - nbr_el *= get_range_length (sa->rngs[j]); - } - sa->nbr_el = nbr_el; - if (h->flag_verbose > 1) - printf ("subtype array: %s (nbr_el=%d)\n", sa->name, sa->nbr_el); - h->types[i] = (union ghw_type *)sa; - } - break; - case ghdl_rtik_type_record: - { - struct ghw_type_record *rec; - int j; - int nbr_el; - - rec = malloc (sizeof (struct ghw_type_record)); - rec->kind = t; - rec->name = ghw_read_strid (h); - if (ghw_read_uleb128 (h, &rec->nbr_fields) != 0) - return -1; - rec->el = malloc - (rec->nbr_fields * sizeof (struct ghw_record_element)); - nbr_el = 0; - for (j = 0; j < rec->nbr_fields; j++) - { - rec->el[j].name = ghw_read_strid (h); - rec->el[j].type = ghw_read_typeid (h); - nbr_el += get_nbr_elements (rec->el[j].type); - } - rec->nbr_el = nbr_el; - if (h->flag_verbose > 1) - printf ("record type: %s (nbr_el=%d)\n", rec->name, rec->nbr_el); - h->types[i] = (union ghw_type *)rec; - } - break; - default: - fprintf (stderr, "ghw_read_type: unknown type %d\n", t); - return -1; - } - } - if (fgetc (h->stream) != 0) - return -1; - return 0; -} - -int -ghw_read_wk_types (struct ghw_handler *h) -{ - char hdr[4]; - - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - return -1; - - if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) - return -1; - - while (1) - { - int t; - union ghw_type *tid; - - t = fgetc (h->stream); - if (t == EOF) - return -1; - else if (t == 0) - break; - - tid = ghw_read_typeid (h); - if (tid->kind == ghdl_rtik_type_b2 - || tid->kind == ghdl_rtik_type_e8) - { - if (h->flag_verbose > 0) - printf ("%s: wkt=%d\n", tid->en.name, t); - tid->en.wkt = t; - } - } - return 0; -} - -void -ghw_disp_typename (struct ghw_handler *h, union ghw_type *t) -{ - printf ("%s", t->common.name); -} - -/* Read a signal composed of severals elements. */ -int -ghw_read_signal (struct ghw_handler *h, unsigned int *sigs, union ghw_type *t) -{ - switch (t->kind) - { - case ghdl_rtik_type_b2: - case ghdl_rtik_type_e8: - case ghdl_rtik_type_e32: - case ghdl_rtik_subtype_scalar: - { - unsigned int sig_el; - - if (ghw_read_uleb128 (h, &sig_el) < 0) - return -1; - *sigs = sig_el; - if (sig_el >= h->nbr_sigs) - abort (); - if (h->sigs[sig_el].type == NULL) - h->sigs[sig_el].type = ghw_get_base_type (t); - } - return 0; - case ghdl_rtik_subtype_array: - case ghdl_rtik_subtype_array_ptr: - { - int i; - int stride; - int len; - - len = t->sa.nbr_el; - stride = get_nbr_elements (t->sa.base->el); - - for (i = 0; i < len; i += stride) - if (ghw_read_signal (h, &sigs[i], t->sa.base->el) < 0) - return -1; - } - return 0; - case ghdl_rtik_type_record: - { - int i; - int off; - - off = 0; - for (i = 0; i < t->rec.nbr_fields; i++) - { - if (ghw_read_signal (h, &sigs[off], t->rec.el[i].type) < 0) - return -1; - off += get_nbr_elements (t->rec.el[i].type); - } - } - return 0; - default: - fprintf (stderr, "ghw_read_signal: type kind %d unhandled\n", t->kind); - abort (); - } -} - - -int -ghw_read_value (struct ghw_handler *h, - union ghw_val *val, union ghw_type *type) -{ - switch (ghw_get_base_type (type)->kind) - { - case ghdl_rtik_type_b2: - { - int v; - v = fgetc (h->stream); - if (v == EOF) - return -1; - val->b2 = v; - } - break; - case ghdl_rtik_type_e8: - { - int v; - v = fgetc (h->stream); - if (v == EOF) - return -1; - val->e8 = v; - } - break; - case ghdl_rtik_type_i32: - case ghdl_rtik_type_p32: - { - int32_t v; - if (ghw_read_sleb128 (h, &v) < 0) - return -1; - val->i32 = v; - } - break; - case ghdl_rtik_type_f64: - { - double v; - if (ghw_read_f64 (h, &v) < 0) - return -1; - val->f64 = v; - } - break; - case ghdl_rtik_type_p64: - { - int64_t v; - if (ghw_read_lsleb128 (h, &v) < 0) - return -1; - val->i64 = v; - } - break; - default: - fprintf (stderr, "read_value: cannot handle format %d\n", type->kind); - abort (); - } - return 0; -} - -int -ghw_read_hie (struct ghw_handler *h) -{ - unsigned char hdr[16]; - int nbr_scopes; - int nbr_sigs; - int i; - struct ghw_hie *blk; - struct ghw_hie **last; - - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - return -1; - - if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) - return -1; - nbr_scopes = ghw_get_i32 (h, &hdr[4]); - /* Number of declared signals (which may be composite). */ - nbr_sigs = ghw_get_i32 (h, &hdr[8]); - /* Number of basic signals. */ - h->nbr_sigs = ghw_get_i32 (h, &hdr[12]); - - if (h->flag_verbose) - printf ("%d scopes, %d signals, %d signal elements\n", - nbr_scopes, nbr_sigs, h->nbr_sigs); - - blk = (struct ghw_hie *)malloc (sizeof (struct ghw_hie)); - blk->kind = ghw_hie_design; - blk->name = NULL; - blk->parent = NULL; - blk->brother = NULL; - blk->u.blk.child = NULL; - - last = &blk->u.blk.child; - h->hie = blk; - - h->nbr_sigs++; - h->sigs = (struct ghw_sig *) malloc (h->nbr_sigs * sizeof (struct ghw_sig)); - memset (h->sigs, 0, h->nbr_sigs * sizeof (struct ghw_sig)); - - while (1) - { - int t; - struct ghw_hie *el; - unsigned int str; - - t = fgetc (h->stream); - if (t == EOF) - return -1; - if (t == 0) - break; - - if (t == ghw_hie_eos) - { - blk = blk->parent; - if (blk->u.blk.child == NULL) - last = &blk->u.blk.child; - else - { - struct ghw_hie *l = blk->u.blk.child; - while (l->brother != NULL) - l = l->brother; - last = &l->brother; - } - - continue; - } - - el = (struct ghw_hie *) malloc (sizeof (struct ghw_hie)); - el->kind = t; - el->parent = blk; - el->brother = NULL; - - /* Link. */ - *last = el; - last = &el->brother; - - /* Read name. */ - if (ghw_read_uleb128 (h, &str) != 0) - return -1; - el->name = h->str_table[str]; - - switch (t) - { - case ghw_hie_eoh: - case ghw_hie_design: - case ghw_hie_eos: - /* Should not be here. */ - abort (); - case ghw_hie_process: - break; - case ghw_hie_block: - case ghw_hie_generate_if: - case ghw_hie_generate_for: - case ghw_hie_instance: - case ghw_hie_generic: - case ghw_hie_package: - /* Create a block. */ - el->u.blk.child = NULL; - - if (t == ghw_hie_generate_for) - { - el->u.blk.iter_type = ghw_read_typeid (h); - el->u.blk.iter_value = malloc (sizeof (union ghw_val)); - if (ghw_read_value (h, el->u.blk.iter_value, - el->u.blk.iter_type) < 0) - return -1; - } - blk = el; - last = &el->u.blk.child; - break; - case ghw_hie_signal: - case ghw_hie_port_in: - case ghw_hie_port_out: - case ghw_hie_port_inout: - case ghw_hie_port_buffer: - case ghw_hie_port_linkage: - /* For a signal, read type. */ - { - int nbr_el; - unsigned int *sigs; - - el->u.sig.type = ghw_read_typeid (h); - nbr_el = get_nbr_elements (el->u.sig.type); - sigs = (unsigned int *) malloc - ((nbr_el + 1) * sizeof (unsigned int)); - el->u.sig.sigs = sigs; - /* Last element is NULL. */ - sigs[nbr_el] = 0; - - if (h->flag_verbose > 1) - printf ("signal %s: %d el [", el->name, nbr_el); - if (ghw_read_signal (h, sigs, el->u.sig.type) < 0) - return -1; - if (h->flag_verbose > 1) - { - int i; - for (i = 0; i < nbr_el; i++) - printf (" #%u", sigs[i]); - printf ("]\n"); - } - } - break; - default: - fprintf (stderr, "ghw_read_hie: unhandled kind %d\n", t); - abort (); - } - } - - /* Allocate values. */ - for (i = 0; i < h->nbr_sigs; i++) - if (h->sigs[i].type != NULL) - h->sigs[i].val = (union ghw_val *) malloc (sizeof (union ghw_val)); - return 0; -} - -const char * -ghw_get_hie_name (struct ghw_hie *h) -{ - switch (h->kind) - { - case ghw_hie_eoh: - return "eoh"; - case ghw_hie_design: - return "design"; - case ghw_hie_block: - return "block"; - case ghw_hie_generate_if: - return "generate-if"; - case ghw_hie_generate_for: - return "generate-for"; - case ghw_hie_instance: - return "instance"; - case ghw_hie_package: - return "package"; - case ghw_hie_process: - return "process"; - case ghw_hie_generic: - return "generic"; - case ghw_hie_eos: - return "eos"; - case ghw_hie_signal: - return "signal"; - case ghw_hie_port_in: - return "port-in"; - case ghw_hie_port_out: - return "port-out"; - case ghw_hie_port_inout: - return "port-inout"; - case ghw_hie_port_buffer: - return "port-buffer"; - case ghw_hie_port_linkage: - return "port-linkage"; - default: - return "??"; - } -} - -void -ghw_disp_value (union ghw_val *val, union ghw_type *type); - -void -ghw_disp_hie (struct ghw_handler *h, struct ghw_hie *top) -{ - int i; - int indent; - struct ghw_hie *hie; - struct ghw_hie *n; - - hie = top; - indent = 0; - - while (1) - { - for (i = 0; i < indent; i++) - fputc (' ', stdout); - printf ("%s", ghw_get_hie_name (hie)); - - switch (hie->kind) - { - case ghw_hie_design: - case ghw_hie_block: - case ghw_hie_generate_if: - case ghw_hie_generate_for: - case ghw_hie_instance: - case ghw_hie_process: - case ghw_hie_package: - if (hie->name) - printf (" %s", hie->name); - if (hie->kind == ghw_hie_generate_for) - { - printf ("("); - ghw_disp_value (hie->u.blk.iter_value, hie->u.blk.iter_type); - printf (")"); - } - n = hie->u.blk.child; - if (n == NULL) - n = hie->brother; - else - indent++; - break; - case ghw_hie_generic: - case ghw_hie_eos: - abort (); - case ghw_hie_signal: - case ghw_hie_port_in: - case ghw_hie_port_out: - case ghw_hie_port_inout: - case ghw_hie_port_buffer: - case ghw_hie_port_linkage: - { - unsigned int *sigs; - - printf (" %s: ", hie->name); - ghw_disp_typename (h, hie->u.sig.type); - for (sigs = hie->u.sig.sigs; *sigs != 0; sigs++) - printf (" #%u", *sigs); - n = hie->brother; - } - break; - default: - abort (); - } - printf ("\n"); - - while (n == NULL) - { - if (hie->parent == NULL) - return; - hie = hie->parent; - indent--; - n = hie->brother; - } - hie = n; - } -} - -int -ghw_read_eoh (struct ghw_handler *h) -{ - return 0; -} - - -int -ghw_read_base (struct ghw_handler *h) -{ - unsigned char hdr[4]; - int res; - - while (1) - { - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - return -1; - if (memcmp (hdr, "STR", 4) == 0) - res = ghw_read_str (h); - else if (memcmp (hdr, "HIE", 4) == 0) - res = ghw_read_hie (h); - else if (memcmp (hdr, "TYP", 4) == 0) - res = ghw_read_type (h); - else if (memcmp (hdr, "WKT", 4) == 0) - res = ghw_read_wk_types (h); - else if (memcmp (hdr, "EOH", 4) == 0) - return 0; - else - { - fprintf (stderr, "ghw_read_base: unknown GHW section %c%c%c%c\n", - hdr[0], hdr[1], hdr[2], hdr[3]); - return -1; - } - if (res != 0) - { - fprintf (stderr, "ghw_read_base: error in section %s\n", hdr); - return res; - } - } -} - -int -ghw_read_signal_value (struct ghw_handler *h, struct ghw_sig *s) -{ - return ghw_read_value (h, s->val, s->type); -} - -int -ghw_read_snapshot (struct ghw_handler *h) -{ - unsigned char hdr[12]; - int i; - struct ghw_sig *s; - - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - return -1; - - if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) - return -1; - h->snap_time = ghw_get_i64 (h, &hdr[4]); - if (h->flag_verbose > 1) - printf ("Time is %lld fs\n", h->snap_time); - - for (i = 0; i < h->nbr_sigs; i++) - { - s = &h->sigs[i]; - if (s->type != NULL) - { - if (h->flag_verbose > 1) - printf ("read type %d for sig %d\n", s->type->kind, i); - if (ghw_read_signal_value (h, s) < 0) - return -1; - } - } - if (fread (hdr, 4, 1, h->stream) != 1) - return -1; - - if (memcmp (hdr, "ESN", 4)) - return -1; - - return 0; -} - -void ghw_disp_values (struct ghw_handler *h); - -int -ghw_read_cycle_start (struct ghw_handler *h) -{ - unsigned char hdr[8]; - - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - return -1; - - h->snap_time = ghw_get_i64 (h, hdr); - return 0; -} - -int -ghw_read_cycle_cont (struct ghw_handler *h, int *list) -{ - int i; - int *list_p; - - i = 0; - list_p = list; - while (1) - { - uint32_t d; - - /* Read delta to next signal. */ - if (ghw_read_uleb128 (h, &d) < 0) - return -1; - if (d == 0) - { - /* Last signal reached. */ - break; - } - - /* Find next signal. */ - while (d > 0) - { - i++; - if (h->sigs[i].type != NULL) - d--; - } - - if (ghw_read_signal_value (h, &h->sigs[i]) < 0) - return -1; - if (list_p) - *list_p++ = i; - } - - if (list_p) - *list_p = 0; - return 0; -} - -int -ghw_read_cycle_next (struct ghw_handler *h) -{ - int64_t d_time; - - if (ghw_read_lsleb128 (h, &d_time) < 0) - return -1; - if (d_time == -1) - return 0; - h->snap_time += d_time; - return 1; -} - - -int -ghw_read_cycle_end (struct ghw_handler *h) -{ - char hdr[4]; - - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - return -1; - if (memcmp (hdr, "ECY", 4)) - return -1; - - return 0; -} - -static const char * -ghw_get_lit (union ghw_type *type, int e) -{ - if (e >= type->en.nbr || e < 0) - return "??"; - else - return type->en.lits[e]; -} - -static void -ghw_disp_lit (union ghw_type *type, int e) -{ - printf ("%s (%d)", ghw_get_lit (type, e), e); -} - -void -ghw_disp_value (union ghw_val *val, union ghw_type *type) -{ - switch (ghw_get_base_type (type)->kind) - { - case ghdl_rtik_type_b2: - ghw_disp_lit (type, val->b2); - break; - case ghdl_rtik_type_e8: - ghw_disp_lit (type, val->e8); - break; - case ghdl_rtik_type_i32: - printf ("%d", val->i32); - break; - case ghdl_rtik_type_p64: - printf ("%lld", val->i64); - break; - case ghdl_rtik_type_f64: - printf ("%g", val->f64); - break; - default: - fprintf (stderr, "ghw_disp_value: cannot handle type %d\n", - type->kind); - abort (); - } -} - -/* Put the ASCII representation of VAL into BUF, whose size if LEN. - A NUL is always written to BUF. -*/ -void -ghw_get_value (char *buf, int len, union ghw_val *val, union ghw_type *type) -{ - switch (ghw_get_base_type (type)->kind) - { - case ghdl_rtik_type_b2: - if (val->b2 <= 1) - { - strncpy (buf, type->en.lits[val->b2], len - 1); - buf[len - 1] = 0; - } - else - { - snprintf (buf, len, "?%d", val->b2); - } - break; - case ghdl_rtik_type_e8: - if (val->b2 <= type->en.nbr) - { - strncpy (buf, type->en.lits[val->e8], len - 1); - buf[len - 1] = 0; - } - else - { - snprintf (buf, len, "?%d", val->e8); - } - break; - case ghdl_rtik_type_i32: - snprintf (buf, len, "%d", val->i32); - break; - case ghdl_rtik_type_p64: - snprintf (buf, len, "%lld", val->i64); - break; - case ghdl_rtik_type_f64: - snprintf (buf, len, "%g", val->f64); - break; - default: - snprintf (buf, len, "?bad type %d?", type->kind); - } -} - -void -ghw_disp_values (struct ghw_handler *h) -{ - int i; - - for (i = 0; i < h->nbr_sigs; i++) - { - struct ghw_sig *s = &h->sigs[i]; - if (s->type != NULL) - { - printf ("#%d: ", i); - ghw_disp_value (s->val, s->type); - printf ("\n"); - } - } -} - -int -ghw_read_directory (struct ghw_handler *h) -{ - unsigned char hdr[8]; - int nbr_entries; - int i; - - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - return -1; - - nbr_entries = ghw_get_i32 (h, &hdr[4]); - - if (h->flag_verbose) - printf ("Directory (%d entries):\n", nbr_entries); - - for (i = 0; i < nbr_entries; i++) - { - unsigned char ent[8]; - int pos; - - if (fread (ent, sizeof (ent), 1, h->stream) != 1) - return -1; - - pos = ghw_get_i32 (h, &ent[4]); - if (h->flag_verbose) - printf (" %s at %d\n", ent, pos); - } - - if (fread (hdr, 4, 1, h->stream) != 1) - return -1; - if (memcmp (hdr, "EOD", 4)) - return -1; - return 0; -} - -int -ghw_read_tailer (struct ghw_handler *h) -{ - unsigned char hdr[8]; - int pos; - - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - return -1; - - pos = ghw_get_i32 (h, &hdr[4]); - - if (h->flag_verbose) - printf ("Tailer: directory at %d\n", pos); - return 0; -} - -enum ghw_res -ghw_read_sm_hdr (struct ghw_handler *h, int *list) -{ - unsigned char hdr[4]; - int res; - - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - { - if (feof (h->stream)) - return ghw_res_eof; - else - return ghw_res_error; - } - if (memcmp (hdr, "SNP", 4) == 0) - { - res = ghw_read_snapshot (h); - if (res < 0) - return res; - return ghw_res_snapshot; - } - else if (memcmp (hdr, "CYC", 4) == 0) - { - res = ghw_read_cycle_start (h); - if (res < 0) - return res; - res = ghw_read_cycle_cont (h, list); - if (res < 0) - return res; - - return ghw_res_cycle; - } - else if (memcmp (hdr, "DIR", 4) == 0) - { - res = ghw_read_directory (h); - } - else if (memcmp (hdr, "TAI", 4) == 0) - { - res = ghw_read_tailer (h); - } - else - { - fprintf (stderr, "unknown GHW section %c%c%c%c\n", - hdr[0], hdr[1], hdr[2], hdr[3]); - return -1; - } - if (res != 0) - return res; - return ghw_res_other; -} - -int -ghw_read_sm (struct ghw_handler *h, enum ghw_sm_type *sm) -{ - int res; - - while (1) - { - /* printf ("sm: state = %d\n", *sm); */ - switch (*sm) - { - case ghw_sm_init: - case ghw_sm_sect: - res = ghw_read_sm_hdr (h, NULL); - switch (res) - { - case ghw_res_other: - break; - case ghw_res_snapshot: - *sm = ghw_sm_sect; - return res; - case ghw_res_cycle: - *sm = ghw_sm_cycle; - return res; - default: - return res; - } - break; - case ghw_sm_cycle: - if (0) - printf ("Time is %lld fs\n", h->snap_time); - if (0) - ghw_disp_values (h); - - res = ghw_read_cycle_next (h); - if (res < 0) - return res; - if (res == 1) - { - res = ghw_read_cycle_cont (h, NULL); - if (res < 0) - return res; - return ghw_res_cycle; - } - res = ghw_read_cycle_end (h); - if (res < 0) - return res; - *sm = ghw_sm_sect; - break; - } - } -} - -int -ghw_read_cycle (struct ghw_handler *h) -{ - int res; - - res = ghw_read_cycle_start (h); - if (res < 0) - return res; - while (1) - { - res = ghw_read_cycle_cont (h, NULL); - if (res < 0) - return res; - - if (0) - printf ("Time is %lld fs\n", h->snap_time); - if (0) - ghw_disp_values (h); - - - res = ghw_read_cycle_next (h); - if (res < 0) - return res; - if (res == 0) - break; - } - res = ghw_read_cycle_end (h); - return res; -} - -int -ghw_read_dump (struct ghw_handler *h) -{ - unsigned char hdr[4]; - int res; - - while (1) - { - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - { - if (feof (h->stream)) - return 0; - else - return -1; - } - if (memcmp (hdr, "SNP", 4) == 0) - { - res = ghw_read_snapshot (h); - if (0 && res >= 0) - ghw_disp_values (h); - } - else if (memcmp (hdr, "CYC", 4) == 0) - { - res = ghw_read_cycle (h); - } - else if (memcmp (hdr, "DIR", 4) == 0) - { - res = ghw_read_directory (h); - } - else if (memcmp (hdr, "TAI", 4) == 0) - { - res = ghw_read_tailer (h); - } - else - { - fprintf (stderr, "unknown GHW section %c%c%c%c\n", - hdr[0], hdr[1], hdr[2], hdr[3]); - return -1; - } - if (res != 0) - return res; - } -} - -struct ghw_section ghw_sections[] = { - { "\0\0\0", NULL }, - { "STR", ghw_read_str }, - { "HIE", ghw_read_hie }, - { "TYP", ghw_read_type }, - { "WKT", ghw_read_wk_types }, - { "EOH", ghw_read_eoh }, - { "SNP", ghw_read_snapshot }, - { "CYC", ghw_read_cycle }, - { "DIR", ghw_read_directory }, - { "TAI", ghw_read_tailer } -}; - -int -ghw_read_section (struct ghw_handler *h) -{ - unsigned char hdr[4]; - int i; - - if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) - { - if (feof (h->stream)) - return -2; - else - return -1; - } - - for (i = 1; i < sizeof (ghw_sections) / sizeof (*ghw_sections); i++) - if (memcmp (hdr, ghw_sections[i].name, 4) == 0) - return i; - - fprintf (stderr, "ghw_read_section: unknown GHW section %c%c%c%c\n", - hdr[0], hdr[1], hdr[2], hdr[3]); - return 0; -} - -void -ghw_close (struct ghw_handler *h) -{ - if (h->stream) - { - fclose (h->stream); - h->stream = NULL; - } -} - -const char * -ghw_get_dir (int is_downto) -{ - return is_downto ? "downto" : "to"; -} - -void -ghw_disp_range (union ghw_type *type, union ghw_range *rng) -{ - switch (rng->kind) - { - case ghdl_rtik_type_e8: - printf ("%s %s %s", ghw_get_lit (type, rng->e8.left), - ghw_get_dir (rng->e8.dir), ghw_get_lit (type, rng->e8.right)); - break; - case ghdl_rtik_type_i32: - case ghdl_rtik_type_p32: - printf ("%d %s %d", - rng->i32.left, ghw_get_dir (rng->i32.dir), rng->i32.right); - break; - case ghdl_rtik_type_i64: - case ghdl_rtik_type_p64: - printf ("%lld %s %lld", - rng->i64.left, ghw_get_dir (rng->i64.dir), rng->i64.right); - break; - case ghdl_rtik_type_f64: - printf ("%g %s %g", - rng->f64.left, ghw_get_dir (rng->f64.dir), rng->f64.right); - break; - default: - printf ("?(%d)", rng->kind); - } -} - -void -ghw_disp_type (struct ghw_handler *h, union ghw_type *t) -{ - switch (t->kind) - { - case ghdl_rtik_type_b2: - case ghdl_rtik_type_e8: - { - struct ghw_type_enum *e = &t->en; - int i; - - printf ("type %s is (", e->name); - for (i = 0; i < e->nbr; i++) - { - if (i != 0) - printf (", "); - printf ("%s", e->lits[i]); - } - printf (");"); - if (e->wkt != ghw_wkt_unknown) - printf (" -- WKT:%d", e->wkt); - printf ("\n"); - } - break; - case ghdl_rtik_type_i32: - case ghdl_rtik_type_f64: - { - struct ghw_type_scalar *s = &t->sc; - printf ("type %s is range <>;\n", s->name); - } - break; - case ghdl_rtik_type_p32: - case ghdl_rtik_type_p64: - { - int i; - - struct ghw_type_physical *p = &t->ph; - printf ("type %s is range <> units\n", p->name); - for (i = 0; i < p->nbr_units; i++) - { - struct ghw_unit *u = &p->units[i]; - printf (" %s = %lld %s;\n", u->name, u->val, p->units[0].name); - } - printf ("end units\n"); - } - break; - case ghdl_rtik_subtype_scalar: - { - struct ghw_subtype_scalar *s = &t->ss; - printf ("subtype %s is ", s->name); - ghw_disp_typename (h, s->base); - printf (" range "); - ghw_disp_range (s->base, s->rng); - printf (";\n"); - } - break; - case ghdl_rtik_type_array: - { - struct ghw_type_array *a = &t->ar; - int i; - - printf ("type %s is array (", a->name); - for (i = 0; i < a->nbr_dim; i++) - { - if (i != 0) - printf (", "); - ghw_disp_typename (h, a->dims[i]); - printf (" range <>"); - } - printf (") of "); - ghw_disp_typename (h, a->el); - printf (";\n"); - } - break; - case ghdl_rtik_subtype_array: - case ghdl_rtik_subtype_array_ptr: - { - struct ghw_subtype_array *a = &t->sa; - int i; - - printf ("subtype %s is ", a->name); - ghw_disp_typename (h, (union ghw_type *)a->base); - printf (" ("); - for (i = 0; i < a->base->nbr_dim; i++) - { - if (i != 0) - printf (", "); - ghw_disp_range ((union ghw_type *)a->base, a->rngs[i]); - } - printf (");\n"); - } - break; - case ghdl_rtik_type_record: - { - struct ghw_type_record *r = &t->rec; - int i; - - printf ("type %s is record\n", r->name); - for (i = 0; i < r->nbr_fields; i++) - { - printf (" %s: ", r->el[i].name); - ghw_disp_typename (h, r->el[i].type); - printf ("\n"); - } - printf ("end record;\n"); - } - break; - default: - printf ("ghw_disp_type: unhandled type kind %d\n", t->kind); - } -} - -void -ghw_disp_types (struct ghw_handler *h) -{ - int i; - - for (i = 0; i < h->nbr_types; i++) - ghw_disp_type (h, h->types[i]); -} diff --git a/src/translate/grt/ghwlib.h b/src/translate/grt/ghwlib.h deleted file mode 100644 index 0138267ed..000000000 --- a/src/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 -#include - -#ifdef __GNUC__ -#include -#endif - -enum ghdl_rtik { - ghdl_rtik_top, /* 0 */ - ghdl_rtik_library, - ghdl_rtik_package, - ghdl_rtik_package_body, - ghdl_rtik_entity, - ghdl_rtik_architecture, /* 5 */ - ghdl_rtik_process, - ghdl_rtik_block, - ghdl_rtik_if_generate, - ghdl_rtik_for_generate, - ghdl_rtik_instance, - ghdl_rtik_constant, - ghdl_rtik_iterator, - ghdl_rtik_variable, - ghdl_rtik_signal, - ghdl_rtik_file, - ghdl_rtik_port, - ghdl_rtik_generic, - ghdl_rtik_alias, - ghdl_rtik_guard, - ghdl_rtik_component, - ghdl_rtik_attribute, - ghdl_rtik_type_b2, /* 22 */ - ghdl_rtik_type_e8, - ghdl_rtik_type_e32, - ghdl_rtik_type_i32, /* 25 */ - ghdl_rtik_type_i64, - ghdl_rtik_type_f64, - ghdl_rtik_type_p32, - ghdl_rtik_type_p64, - ghdl_rtik_type_access, /* 30 */ - ghdl_rtik_type_array, - ghdl_rtik_type_record, - ghdl_rtik_type_file, - ghdl_rtik_subtype_scalar, - ghdl_rtik_subtype_array, /* 35 */ - ghdl_rtik_subtype_array_ptr, - ghdl_rtik_subtype_unconstrained_array, - ghdl_rtik_subtype_record, - ghdl_rtik_subtype_access, - ghdl_rtik_type_protected, - ghdl_rtik_element, - ghdl_rtik_unit, - ghdl_rtik_attribute_transaction, - ghdl_rtik_attribute_quiet, - ghdl_rtik_attribute_stable, - ghdl_rtik_error -}; - -/* Well-known types. */ -enum ghw_wkt_type { - ghw_wkt_unknown, - ghw_wkt_boolean, - ghw_wkt_bit, - ghw_wkt_std_ulogic -}; - -struct ghw_range_b2 -{ - enum ghdl_rtik kind : 8; - int dir : 8; /* 0: to, !0: downto. */ - unsigned char left; - unsigned char right; -}; - -struct ghw_range_e8 -{ - enum ghdl_rtik kind : 8; - int dir : 8; /* 0: to, !0: downto. */ - unsigned char left; - unsigned char right; -}; - -struct ghw_range_i32 -{ - enum ghdl_rtik kind : 8; - int dir : 8; /* 0: to, !0: downto. */ - int32_t left; - int32_t right; -}; - -struct ghw_range_i64 -{ - enum ghdl_rtik kind : 8; - int dir : 8; - int64_t left; - int64_t right; -}; - -struct ghw_range_f64 -{ - enum ghdl_rtik kind : 8; - int dir : 8; - double left; - double right; -}; - -union ghw_range -{ - enum ghdl_rtik kind : 8; - struct ghw_range_e8 e8; - struct ghw_range_i32 i32; - struct ghw_range_i64 i64; - struct ghw_range_f64 f64; -}; - -/* Note: the first two fields must be kind and name. */ -union ghw_type; - -struct ghw_type_common -{ - enum ghdl_rtik kind; - const char *name; -}; - -struct ghw_type_enum -{ - enum ghdl_rtik kind; - const char *name; - - enum ghw_wkt_type wkt; - unsigned int nbr; - const char **lits; -}; - -struct ghw_type_scalar -{ - enum ghdl_rtik kind; - const char *name; -}; - -struct ghw_unit -{ - const char *name; - int64_t val; -}; - -struct ghw_type_physical -{ - enum ghdl_rtik kind; - const char *name; - uint32_t nbr_units; - struct ghw_unit *units; -}; - -struct ghw_type_array -{ - enum ghdl_rtik kind; - const char *name; - - unsigned int nbr_dim; - union ghw_type *el; - union ghw_type **dims; -}; - -struct ghw_subtype_array -{ - enum ghdl_rtik kind; - const char *name; - - struct ghw_type_array *base; - int nbr_el; - union ghw_range **rngs; -}; - -struct ghw_subtype_scalar -{ - enum ghdl_rtik kind; - const char *name; - - union ghw_type *base; - union ghw_range *rng; -}; - -struct ghw_record_element -{ - const char *name; - union ghw_type *type; -}; - -struct ghw_type_record -{ - enum ghdl_rtik kind; - const char *name; - - unsigned int nbr_fields; - int nbr_el; /* Number of scalar signals. */ - struct ghw_record_element *el; -}; - -union ghw_type -{ - enum ghdl_rtik kind; - struct ghw_type_common common; - struct ghw_type_enum en; - struct ghw_type_scalar sc; - struct ghw_type_physical ph; - struct ghw_subtype_scalar ss; - struct ghw_subtype_array sa; - struct ghw_type_array ar; - struct ghw_type_record rec; -}; - -union ghw_val -{ - unsigned char b2; - unsigned char e8; - int32_t i32; - int64_t i64; - double f64; -}; - -/* A non-composite signal. */ -struct ghw_sig -{ - union ghw_type *type; - union ghw_val *val; -}; - -enum ghw_hie_kind { - ghw_hie_eoh = 0, - ghw_hie_design = 1, - ghw_hie_block = 3, - ghw_hie_generate_if = 4, - ghw_hie_generate_for = 5, - ghw_hie_instance = 6, - ghw_hie_package = 7, - ghw_hie_process = 13, - ghw_hie_generic = 14, - ghw_hie_eos = 15, - ghw_hie_signal = 16, - ghw_hie_port_in = 17, - ghw_hie_port_out = 18, - ghw_hie_port_inout = 19, - ghw_hie_port_buffer = 20, - ghw_hie_port_linkage = 21 -}; - -struct ghw_hie -{ - enum ghw_hie_kind kind; - struct ghw_hie *parent; - const char *name; - struct ghw_hie *brother; - union - { - struct - { - struct ghw_hie *child; - union ghw_type *iter_type; - union ghw_val *iter_value; - } blk; - struct - { - union ghw_type *type; - /* Array of signal elements. - Last element is 0. */ - unsigned int *sigs; - } sig; - } u; -}; - -struct ghw_handler -{ - FILE *stream; - /* True if words are big-endian. */ - int word_be; - int word_len; - int off_len; - /* Minor version. */ - int version; - - /* Set by user. */ - int flag_verbose; - - /* String table. */ - /* Number of strings. */ - int nbr_str; - /* Size of the strings (without nul). */ - int str_size; - /* String table. */ - char **str_table; - /* Array containing strings. */ - char *str_content; - - /* Type table. */ - int nbr_types; - union ghw_type **types; - - /* Non-composite (or basic) signals. */ - int nbr_sigs; - struct ghw_sig *sigs; - - /* Hierarchy. */ - struct ghw_hie *hie; - - /* Time of the next cycle. */ - int64_t snap_time; -}; - -/* Open a GHW file with H. - Return < 0 in case of error. */ -int ghw_open (struct ghw_handler *h, const char *filename); - -union ghw_type *ghw_get_base_type (union ghw_type *t); - -/* Put the ASCII representation of VAL into BUF, whose size if LEN. - A NUL is always written to BUF. */ -void ghw_get_value (char *buf, int len, - union ghw_val *val, union ghw_type *type); - -const char *ghw_get_hie_name (struct ghw_hie *h); - -void ghw_disp_hie (struct ghw_handler *h, struct ghw_hie *top); - -int ghw_read_base (struct ghw_handler *h); - -void ghw_disp_values (struct ghw_handler *h); - -int ghw_read_cycle_start (struct ghw_handler *h); - -int ghw_read_cycle_cont (struct ghw_handler *h, int *list); - -int ghw_read_cycle_next (struct ghw_handler *h); - -int ghw_read_cycle_end (struct ghw_handler *h); - -enum ghw_sm_type { - /* At init; - Read section name. */ - ghw_sm_init = 0, - ghw_sm_sect = 1, - ghw_sm_cycle = 2 -}; - -enum ghw_res { - ghw_res_error = -1, - ghw_res_eof = -2, - ghw_res_ok = 0, - ghw_res_snapshot = 1, - ghw_res_cycle = 2, - ghw_res_other = 3 -}; - -int ghw_read_sm (struct ghw_handler *h, enum ghw_sm_type *sm); - -int ghw_read_dump (struct ghw_handler *h); - -struct ghw_section { - const char name[4]; - int (*handler)(struct ghw_handler *h); -}; - -extern struct ghw_section ghw_sections[]; - -int ghw_read_section (struct ghw_handler *h); - -void ghw_close (struct ghw_handler *h); - -const char *ghw_get_dir (int is_downto); - -/* Note: TYPE must be a base type (used only to display literals). */ -void ghw_disp_range (union ghw_type *type, union ghw_range *rng); - -void ghw_disp_type (struct ghw_handler *h, union ghw_type *t); - -void ghw_disp_types (struct ghw_handler *h); -#endif /* _GHWLIB_H_ */ diff --git a/src/translate/grt/grt-arch.ads b/src/translate/grt/grt-arch.ads deleted file mode 100644 index 5f5aa0e4c..000000000 --- a/src/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/src/translate/grt/grt-arch_none.adb b/src/translate/grt/grt-arch_none.adb deleted file mode 100644 index 14db1c7d5..000000000 --- a/src/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/src/translate/grt/grt-arch_none.ads b/src/translate/grt/grt-arch_none.ads deleted file mode 100644 index f8ae437d6..000000000 --- a/src/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/src/translate/grt/grt-astdio.adb b/src/translate/grt/grt-astdio.adb deleted file mode 100644 index 456d024ac..000000000 --- a/src/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/src/translate/grt/grt-astdio.ads b/src/translate/grt/grt-astdio.ads deleted file mode 100644 index 8e8b739cc..000000000 --- a/src/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/src/translate/grt/grt-avhpi.adb b/src/translate/grt/grt-avhpi.adb deleted file mode 100644 index b935fd9a3..000000000 --- a/src/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/src/translate/grt/grt-avhpi.ads b/src/translate/grt/grt-avhpi.ads deleted file mode 100644 index 1eff5a8a3..000000000 --- a/src/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/src/translate/grt/grt-avls.adb b/src/translate/grt/grt-avls.adb deleted file mode 100644 index 7f13ed39a..000000000 --- a/src/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/src/translate/grt/grt-avls.ads b/src/translate/grt/grt-avls.ads deleted file mode 100644 index 790053c6f..000000000 --- a/src/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/src/translate/grt/grt-c.ads b/src/translate/grt/grt-c.ads deleted file mode 100644 index 24003cf4a..000000000 --- a/src/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/src/translate/grt/grt-cbinding.c b/src/translate/grt/grt-cbinding.c deleted file mode 100644 index b95c0f0a9..000000000 --- a/src/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 -#include -#include - -FILE * -__ghdl_get_stdout (void) -{ - return stdout; -} - -FILE * -__ghdl_get_stdin (void) -{ - return stdin; -} - -FILE * -__ghdl_get_stderr (void) -{ - return stderr; -} - -int -__ghdl_snprintf_g (char *buf, unsigned int len, double val) -{ - snprintf (buf, len, "%g", val); - return strlen (buf); -} - -void -__ghdl_snprintf_nf (char *buf, unsigned int len, int ndigits, double val) -{ - snprintf (buf, len, "%.*f", ndigits, val); -} - -void -__ghdl_snprintf_fmtf (char *buf, unsigned int len, - const char *format, double v) -{ - snprintf (buf, len, format, v); -} - -void -__ghdl_fprintf_g (FILE *stream, double val) -{ - fprintf (stream, "%g", val); -} - -void -__ghdl_fprintf_clock (FILE *stream, int a, int b) -{ - fprintf (stream, "%3d.%03d", a, b); -} - -#ifndef WITH_GNAT_RUN_TIME -void -__gnat_last_chance_handler (void) -{ - abort (); -} - -void * -__gnat_malloc (size_t size) -{ - void *res; - res = malloc (size); - return res; -} - -void -__gnat_free (void *ptr) -{ - free (ptr); -} - -void * -__gnat_realloc (void *ptr, size_t size) -{ - return realloc (ptr, size); -} -#endif diff --git a/src/translate/grt/grt-cvpi.c b/src/translate/grt/grt-cvpi.c deleted file mode 100644 index 51edd678f..000000000 --- a/src/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 -#include - -//----------------------------------------------------------------------------- -// 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 -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 -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 -static void * -module_open (const char *path) -{ - return dlopen (path, RTLD_LAZY); -} - -static void * -module_symbol (void *handle, const char *symbol) -{ - return dlsym (handle, symbol); -} - -static const char * -module_error (void) -{ - return dlerror (); -} -#endif - -int -loadVpiModule (const char* modulename) -{ - static const char * const vpitablenames[] = - { - "_vlog_startup_routines", // with leading underscore: MacOSX - "vlog_startup_routines" // w/o leading underscore: Linux - }; - static const char * const vpithunknames[] = - { - "_vpi_register_sim", // with leading underscore: MacOSX - "vpi_register_sim" // w/o leading underscore: Linux - }; - - int i; - void* vpimod; - - fprintf (stderr, "loading VPI module '%s'\n", modulename); - - vpimod = module_open (modulename); - - if (vpimod == NULL) - { - const char *msg; - - msg = module_error (); - - fprintf (stderr, "%s\n", msg == NULL ? "unknown dlopen error" : msg); - return -1; - } - - for (i = 0; i < 2; i++) // try with and w/o leading underscores - { - void* vpithunk; - void* vpitable; - - vpitable = module_symbol (vpimod, vpitablenames[i]); - vpithunk = module_symbol (vpimod, vpithunknames[i]); - - if (vpithunk) - { - typedef int (*funT)(p_vpi_thunk tp); - funT regsim; - - regsim = (funT)vpithunk; - regsim (&thunkTable); - } - else - { - // this is not an error, as the register-mechanism - // is not standardized - } - - if (vpitable) - { - unsigned int tmp; - //extern void (*vlog_startup_routines[])(); - typedef void (*vlog_startup_routines_t)(void); - vlog_startup_routines_t *vpifuns; - - vpifuns = (vlog_startup_routines_t*)vpitable; - for (tmp = 0; vpifuns[tmp]; tmp++) - { - vpifuns[tmp](); - } - - fprintf (stderr, "VPI module loaded!\n"); - return 0; // successfully registered VPI module - } - } - fprintf (stderr, "vlog_startup_routines not found\n"); - return -1; // failed to register VPI module -} - -void -vpi_printf (const char *fmt, ...) -{ - va_list params; - - va_start (params, fmt); - vprintf (fmt, params); - va_end (params); -} - -//----------------------------------------------------------------------------- -// end of file - diff --git a/src/translate/grt/grt-disp.adb b/src/translate/grt/grt-disp.adb deleted file mode 100644 index e68b1168b..000000000 --- a/src/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/src/translate/grt/grt-disp.ads b/src/translate/grt/grt-disp.ads deleted file mode 100644 index 6c15b37c9..000000000 --- a/src/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/src/translate/grt/grt-disp_rti.adb b/src/translate/grt/grt-disp_rti.adb deleted file mode 100644 index 08d27dacb..000000000 --- a/src/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, ""); - else - Put (stdout, Name); - end if; - end Disp_Name; - - -- Disp value stored at ADDR and whose type is described by RTI. - procedure Disp_Enum_Value - (Stream : FILEs; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) - is - Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; - begin - Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); - Put (Stream, Enum_Rti.Names (Val)); - end Disp_Enum_Value; - - procedure Disp_Scalar_Value - (Stream : FILEs; - Rti : Ghdl_Rti_Access; - Addr : in out Address; - Is_Sig : Boolean) - is - procedure Update (S : Ghdl_Index_Type) is - begin - Addr := Addr + (S / Storage_Unit); - end Update; - - Vptr : Ghdl_Value_Ptr; - begin - if Is_Sig then - Vptr := To_Ghdl_Value_Ptr (To_Addr_Acc (Addr).all); - Update (Address'Size); - else - Vptr := To_Ghdl_Value_Ptr (Addr); - end if; - - case Rti.Kind is - when Ghdl_Rtik_Type_I32 => - Put_I32 (Stream, Vptr.I32); - if not Is_Sig then - Update (32); - end if; - when Ghdl_Rtik_Type_E8 => - Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E8)); - if not Is_Sig then - Update (8); - end if; - when Ghdl_Rtik_Type_E32 => - Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E32)); - if not Is_Sig then - Update (32); - end if; - when Ghdl_Rtik_Type_B1 => - Disp_Enum_Value (Stream, Rti, - Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1))); - if not Is_Sig then - Update (8); - end if; - when Ghdl_Rtik_Type_F64 => - Put_F64 (Stream, Vptr.F64); - if not Is_Sig then - Update (64); - end if; - when Ghdl_Rtik_Type_P64 => - Put_I64 (Stream, Vptr.I64); - Put (Stream, " "); - Put (Stream, - Get_Physical_Unit_Name - (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); - if not Is_Sig then - Update (64); - end if; - when Ghdl_Rtik_Type_P32 => - Put_I32 (Stream, Vptr.I32); - Put (Stream, " "); - Put (Stream, - Get_Physical_Unit_Name - (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); - if not Is_Sig then - Update (32); - end if; - when others => - Internal_Error ("disp_rti.disp_scalar_value"); - end case; - end Disp_Scalar_Value; - --- function Get_Scalar_Type_Kind (Rti : Ghdl_Rti_Access) return Ghdl_Rtik --- is --- Ndef : Ghdl_Rti_Access; --- begin --- if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then --- Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype; --- else --- Ndef := Rti; --- end if; --- case Ndef.Kind is --- when Ghdl_Rtik_Type_I32 => --- return Ndef.Kind; --- when others => --- return Ghdl_Rtik_Error; --- end case; --- end Get_Scalar_Type_Kind; - - procedure Disp_Array_Value_1 (Stream : FILEs; - El_Rti : Ghdl_Rti_Access; - Ctxt : Rti_Context; - Rngs : Ghdl_Range_Array; - Rtis : Ghdl_Rti_Arr_Acc; - Index : Ghdl_Index_Type; - Obj : in out Address; - Is_Sig : Boolean) - is - Length : Ghdl_Index_Type; - begin - Length := Range_To_Length (Rngs (Index), Get_Base_Type (Rtis (Index))); - Put (Stream, "("); - for I in 1 .. Length loop - if I /= 1 then - Put (Stream, ", "); - end if; - if Index = Rngs'Last then - Disp_Value (Stream, El_Rti, Ctxt, Obj, Is_Sig); - else - Disp_Array_Value_1 - (Stream, El_Rti, Ctxt, Rngs, Rtis, Index + 1, Obj, Is_Sig); - end if; - end loop; - Put (Stream, ")"); - end Disp_Array_Value_1; - - procedure Disp_Array_Value (Stream : FILEs; - Rti : Ghdl_Rtin_Type_Array_Acc; - Ctxt : Rti_Context; - Vals : Ghdl_Uc_Array_Acc; - Is_Sig : Boolean) - is - Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; - Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); - Obj : Address; - begin - Bound_To_Range (Vals.Bounds, Rti, Rngs); - Obj := Vals.Base; - Disp_Array_Value_1 - (Stream, Rti.Element, Ctxt, Rngs, Rti.Indexes, 0, Obj, Is_Sig); - end Disp_Array_Value; - - procedure Disp_Record_Value (Stream : FILEs; - Rti : Ghdl_Rtin_Type_Record_Acc; - Ctxt : Rti_Context; - Obj : Address; - Is_Sig : Boolean) - is - El : Ghdl_Rtin_Element_Acc; - El_Addr : Address; - begin - Put (Stream, "("); - for I in 1 .. Rti.Nbrel loop - El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); - if I /= 1 then - Put (", "); - end if; - Put (Stream, El.Name); - Put (" => "); - if Is_Sig then - El_Addr := Obj + El.Sig_Off; - else - El_Addr := Obj + El.Val_Off; - end if; - if Rti_Complex_Type (El.Eltype) then - El_Addr := Obj + To_Ghdl_Index_Acc (El_Addr).all; - end if; - Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Is_Sig); - end loop; - Put (")"); - -- FIXME: update ADDR. - end Disp_Record_Value; - - procedure Disp_Value - (Stream : FILEs; - Rti : Ghdl_Rti_Access; - Ctxt : Rti_Context; - Obj : in out Address; - Is_Sig : Boolean) - is - begin - case Rti.Kind is - when Ghdl_Rtik_Subtype_Scalar => - Disp_Scalar_Value - (Stream, To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype, - Obj, Is_Sig); - when Ghdl_Rtik_Type_I32 - | Ghdl_Rtik_Type_E8 - | Ghdl_Rtik_Type_E32 - | Ghdl_Rtik_Type_B1 => - Disp_Scalar_Value (Stream, Rti, Obj, Is_Sig); - when Ghdl_Rtik_Type_Array => - Disp_Array_Value (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, - To_Ghdl_Uc_Array_Acc (Obj), Is_Sig); - when Ghdl_Rtik_Subtype_Array => - declare - St : constant Ghdl_Rtin_Subtype_Array_Acc := - To_Ghdl_Rtin_Subtype_Array_Acc (Rti); - Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; - Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); - B : Address; - begin - Bound_To_Range - (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); - B := Obj; - Disp_Array_Value_1 - (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig); - end; - when Ghdl_Rtik_Type_File => - declare - Vptr : Ghdl_Value_Ptr; - begin - Vptr := To_Ghdl_Value_Ptr (Obj); - Put (Stream, "File#"); - Put_I32 (Stream, Vptr.I32); - -- FIXME: update OBJ (not very useful since never in a - -- composite type). - end; - when Ghdl_Rtik_Type_Record => - Disp_Record_Value - (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Is_Sig); - when Ghdl_Rtik_Type_Protected => - Put (Stream, "Unhandled protected type"); - when others => - Put (Stream, "Unknown Rti Kind : "); - Disp_Kind(Rti.Kind); - end case; - -- Put_Line(":"); - end Disp_Value; - - procedure Disp_Kind (Kind : Ghdl_Rtik) is - begin - case Kind is - when Ghdl_Rtik_Top => - Put ("ghdl_rtik_top"); - when Ghdl_Rtik_Package => - Put ("ghdl_rtik_package"); - when Ghdl_Rtik_Package_Body => - Put ("ghdl_rtik_package_body"); - when Ghdl_Rtik_Entity => - Put ("ghdl_rtik_entity"); - when Ghdl_Rtik_Architecture => - Put ("ghdl_rtik_architecture"); - - when Ghdl_Rtik_Port => - Put ("ghdl_rtik_port"); - when Ghdl_Rtik_Generic => - Put ("ghdl_rtik_generic"); - when Ghdl_Rtik_Process => - Put ("ghdl_rtik_process"); - when Ghdl_Rtik_Component => - Put ("ghdl_rtik_component"); - when Ghdl_Rtik_Attribute => - Put ("ghdl_rtik_attribute"); - - when Ghdl_Rtik_Attribute_Quiet => - Put ("ghdl_rtik_attribute_quiet"); - when Ghdl_Rtik_Attribute_Stable => - Put ("ghdl_rtik_attribute_stable"); - when Ghdl_Rtik_Attribute_Transaction => - Put ("ghdl_rtik_attribute_transaction"); - - when Ghdl_Rtik_Constant => - Put ("ghdl_rtik_constant"); - when Ghdl_Rtik_Iterator => - Put ("ghdl_rtik_iterator"); - when Ghdl_Rtik_Signal => - Put ("ghdl_rtik_signal"); - when Ghdl_Rtik_Variable => - Put ("ghdl_rtik_variable"); - when Ghdl_Rtik_Guard => - Put ("ghdl_rtik_guard"); - when Ghdl_Rtik_File => - Put ("ghdl_rtik_file"); - - when Ghdl_Rtik_Instance => - Put ("ghdl_rtik_instance"); - when Ghdl_Rtik_Block => - Put ("ghdl_rtik_block"); - when Ghdl_Rtik_If_Generate => - Put ("ghdl_rtik_if_generate"); - when Ghdl_Rtik_For_Generate => - Put ("ghdl_rtik_for_generate"); - - when Ghdl_Rtik_Type_B1 => - Put ("ghdl_rtik_type_b1"); - when Ghdl_Rtik_Type_E8 => - Put ("ghdl_rtik_type_e8"); - when Ghdl_Rtik_Type_E32 => - Put ("ghdl_rtik_type_e32"); - when Ghdl_Rtik_Type_P64 => - Put ("ghdl_rtik_type_p64"); - when Ghdl_Rtik_Type_I32 => - Put ("ghdl_rtik_type_i32"); - - when Ghdl_Rtik_Type_Array => - Put ("ghdl_rtik_type_array"); - when Ghdl_Rtik_Subtype_Array => - Put ("ghdl_rtik_subtype_array"); - when Ghdl_Rtik_Type_Record => - Put ("ghdl_rtik_type_record"); - - when Ghdl_Rtik_Type_Access => - Put ("ghdl_rtik_type_access"); - when Ghdl_Rtik_Type_File => - Put ("ghdl_rtik_type_file"); - when Ghdl_Rtik_Type_Protected => - Put ("ghdl_rtik_type_protected"); - - when Ghdl_Rtik_Subtype_Scalar => - Put ("ghdl_rtik_subtype_scalar"); - - when Ghdl_Rtik_Element => - Put ("ghdl_rtik_element"); - when Ghdl_Rtik_Unit64 => - Put ("ghdl_rtik_unit64"); - when Ghdl_Rtik_Unitptr => - Put ("ghdl_rtik_unitptr"); - - when others => - Put ("ghdl_rtik_#"); - Put_I32 (stdout, Ghdl_Rtik'Pos (Kind)); - end case; - end Disp_Kind; - - procedure Disp_Depth (Depth : Ghdl_Rti_Depth) is - begin - Put (", D="); - Put_I32 (stdout, Ghdl_I32 (Depth)); - end Disp_Depth; - - procedure Disp_Indent (Indent : Natural) is - begin - for I in 1 .. Indent loop - Put (' '); - end loop; - end Disp_Indent; - - -- Disp a subtype_indication. - -- OBJ may be necessary when the subtype is an unconstrained array type, - -- whose bounds are stored with the object. - procedure Disp_Subtype_Indication - (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address); - - procedure Disp_Range - (Stream : FILEs; Kind : Ghdl_Rtik; Rng : Ghdl_Range_Ptr) - is - begin - case Kind is - when Ghdl_Rtik_Type_I32 - | Ghdl_Rtik_Type_P32 => - Put_I32 (Stream, Rng.I32.Left); - Put_Dir (Stream, Rng.I32.Dir); - Put_I32 (Stream, Rng.I32.Right); - when Ghdl_Rtik_Type_F64 => - Put_F64 (Stream, Rng.F64.Left); - Put_Dir (Stream, Rng.F64.Dir); - Put_F64 (Stream, Rng.F64.Right); - when Ghdl_Rtik_Type_P64 => - Put_I64 (Stream, Rng.P64.Left); - Put_Dir (Stream, Rng.P64.Dir); - Put_I64 (Stream, Rng.P64.Right); - when others => - Put ("?Scal"); - end case; - end Disp_Range; - - procedure Disp_Scalar_Type_Name (Def : Ghdl_Rti_Access) is - begin - case Def.Kind is - when Ghdl_Rtik_Subtype_Scalar => - declare - Rti : Ghdl_Rtin_Subtype_Scalar_Acc; - begin - Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); - if Rti.Name /= null then - Disp_Name (Rti.Name); - else - Disp_Scalar_Type_Name (Rti.Basetype); - end if; - end; - when Ghdl_Rtik_Type_B1 - | Ghdl_Rtik_Type_E8 - | Ghdl_Rtik_Type_E32 => - Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); - when Ghdl_Rtik_Type_I32 - | Ghdl_Rtik_Type_I64 => - Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); - when others => - Put ("#disp_scalar_type_name#"); - end case; - end Disp_Scalar_Type_Name; - - procedure Disp_Type_Array_Name (Def : Ghdl_Rtin_Type_Array_Acc; - Bounds_Ptr : Address) - is - Bounds : Address; - - procedure Align (A : Ghdl_Index_Type) is - begin - Bounds := Align (Bounds, Ghdl_Rti_Loc (A)); - end Align; - - procedure Update (S : Ghdl_Index_Type) is - begin - Bounds := Bounds + (S / Storage_Unit); - end Update; - - procedure Disp_Bounds (Def : Ghdl_Rti_Access) - is - Ndef : Ghdl_Rti_Access; - begin - if Bounds = Null_Address then - Put ("?"); - else - if Def.Kind = Ghdl_Rtik_Subtype_Scalar then - Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def).Basetype; - else - Ndef := Def; - end if; - case Ndef.Kind is - when Ghdl_Rtik_Type_I32 => - Align (Ghdl_Range_I32'Alignment); - Disp_Range (stdout, Ndef.Kind, To_Ghdl_Range_Ptr (Bounds)); - Update (Ghdl_Range_I32'Size); - when others => - Disp_Kind (Ndef.Kind); - -- Bounds are not known anymore. - Bounds := Null_Address; - end case; - end if; - end Disp_Bounds; - begin - Disp_Name (Def.Name); - if Bounds_Ptr = Null_Address then - return; - end if; - Put (" ("); - Bounds := Bounds_Ptr; - for I in 0 .. Def.Nbr_Dim - 1 loop - if I /= 0 then - Put (", "); - end if; - Disp_Scalar_Type_Name (Def.Indexes (I)); - Put (" range "); - Disp_Bounds (Def.Indexes (I)); - end loop; - Put (")"); - end Disp_Type_Array_Name; - - procedure Disp_Subtype_Scalar_Range - (Stream : FILEs; Def : Ghdl_Rtin_Subtype_Scalar_Acc; Ctxt : Rti_Context) - is - Range_Addr : Address; - Rng : Ghdl_Range_Ptr; - begin - Range_Addr := Loc_To_Addr (Def.Common.Depth, - Def.Range_Loc, Ctxt); - Rng := To_Ghdl_Range_Ptr (Range_Addr); - Disp_Range (Stream, Def.Basetype.Kind, Rng); - end Disp_Subtype_Scalar_Range; - - procedure Disp_Subtype_Indication - (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address) - is - begin - case Def.Kind is - when Ghdl_Rtik_Subtype_Scalar => - declare - Rti : Ghdl_Rtin_Subtype_Scalar_Acc; - begin - Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); - if Rti.Name /= null then - Disp_Name (Rti.Name); - else - Disp_Subtype_Indication - (Rti.Basetype, Null_Context, Null_Address); - Put (" range "); - Disp_Subtype_Scalar_Range (stdout, Rti, Ctxt); - end if; - end; - --Disp_Scalar_Subtype_Name (To_Ghdl_Rtin_Scalsubtype_Acc (Def), - -- Base); - when Ghdl_Rtik_Type_B1 - | Ghdl_Rtik_Type_E8 - | Ghdl_Rtik_Type_E32 => - Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); - when Ghdl_Rtik_Type_I32 - | Ghdl_Rtik_Type_I64 => - Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); - when Ghdl_Rtik_Type_File - | Ghdl_Rtik_Type_Access => - Disp_Name (To_Ghdl_Rtin_Type_Fileacc_Acc (Def).Name); - when Ghdl_Rtik_Type_Record => - Disp_Name (To_Ghdl_Rtin_Type_Record_Acc (Def).Name); - when Ghdl_Rtik_Type_Array => - declare - Bounds : Address; - begin - if Obj = Null_Address then - Bounds := Null_Address; - else - Bounds := To_Ghdl_Uc_Array_Acc (Obj).Bounds; - end if; - Disp_Type_Array_Name (To_Ghdl_Rtin_Type_Array_Acc (Def), - Bounds); - end; - when Ghdl_Rtik_Subtype_Array => - declare - Sdef : Ghdl_Rtin_Subtype_Array_Acc; - begin - Sdef := To_Ghdl_Rtin_Subtype_Array_Acc (Def); - if Sdef.Name /= null then - Disp_Name (Sdef.Name); - else - Disp_Type_Array_Name - (Sdef.Basetype, - Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt)); - end if; - end; - when Ghdl_Rtik_Type_Protected => - Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); - when others => - Disp_Kind (Def.Kind); - Put (' '); - end case; - end Disp_Subtype_Indication; - - - procedure Disp_Rti (Rti : Ghdl_Rti_Access; - Ctxt : Rti_Context; - Indent : Natural); - - procedure Disp_Rti_Arr (Nbr : Ghdl_Index_Type; - Arr : Ghdl_Rti_Arr_Acc; - Ctxt : Rti_Context; - Indent : Natural) - is - begin - for I in 1 .. Nbr loop - Disp_Rti (Arr (I - 1), Ctxt, Indent); - end loop; - end Disp_Rti_Arr; - - procedure Disp_Block (Blk : Ghdl_Rtin_Block_Acc; - Ctxt : Rti_Context; - Indent : Natural) - is - Nctxt : Rti_Context; - begin - Disp_Indent (Indent); - Disp_Kind (Blk.Common.Kind); - Disp_Depth (Blk.Common.Depth); - Put (": "); - Disp_Name (Blk.Name); - New_Line; - if Blk.Parent /= null then - case Blk.Common.Kind is - when Ghdl_Rtik_Architecture => - -- Disp entity. - Disp_Rti (Blk.Parent, Ctxt, Indent + 1); - when others => - null; - end case; - end if; - case Blk.Common.Kind is - when Ghdl_Rtik_Package - | Ghdl_Rtik_Package_Body - | Ghdl_Rtik_Entity - | Ghdl_Rtik_Architecture - | Ghdl_Rtik_Block - | Ghdl_Rtik_Process => - Nctxt := (Base => Ctxt.Base + Blk.Loc, - Block => To_Ghdl_Rti_Access (Blk)); - Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, - Nctxt, Indent + 1); - when Ghdl_Rtik_For_Generate => - declare - Length : Ghdl_Index_Type; - begin - Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all, - Block => To_Ghdl_Rti_Access (Blk)); - Length := Get_For_Generate_Length (Blk, Ctxt); - for I in 1 .. Length loop - Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, - Nctxt, Indent + 1); - Nctxt.Base := Nctxt.Base + Blk.Size; - end loop; - end; - when Ghdl_Rtik_If_Generate => - Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all, - Block => To_Ghdl_Rti_Access (Blk)); - if Nctxt.Base /= Null_Address then - Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, - Nctxt, Indent + 1); - end if; - when others => - Internal_Error ("disp_block"); - end case; - end Disp_Block; - - procedure Disp_Object (Obj : Ghdl_Rtin_Object_Acc; - Is_Sig : Boolean; - Ctxt : Rti_Context; - Indent : Natural) - is - Addr : Address; - Obj_Type : Ghdl_Rti_Access; - begin - Disp_Indent (Indent); - Disp_Kind (Obj.Common.Kind); - Disp_Depth (Obj.Common.Depth); - Put ("; "); - Disp_Name (Obj.Name); - Put (": "); - Addr := Loc_To_Addr (Obj.Common.Depth, Obj.Loc, Ctxt); - Obj_Type := Obj.Obj_Type; - Disp_Subtype_Indication (Obj_Type, Ctxt, Addr); - Put (" := "); - - -- FIXME: put this into a function. - if (Obj_Type.Kind = Ghdl_Rtik_Subtype_Array - or Obj_Type.Kind = Ghdl_Rtik_Type_Record) - and then Rti_Complex_Type (Obj_Type) - then - Addr := To_Addr_Acc (Addr).all; - end if; - Disp_Value (stdout, Obj_Type, Ctxt, Addr, Is_Sig); - New_Line; - end Disp_Object; - - procedure Disp_Attribute (Obj : Ghdl_Rtin_Object_Acc; - Ctxt : Rti_Context; - Indent : Natural) - is - begin - Disp_Indent (Indent); - Disp_Kind (Obj.Common.Kind); - Disp_Depth (Obj.Common.Depth); - Put ("; "); - Disp_Name (Obj.Name); - Put (": "); - Disp_Subtype_Indication (Obj.Obj_Type, Ctxt, Null_Address); - New_Line; - end Disp_Attribute; - - procedure Disp_Component (Comp : Ghdl_Rtin_Component_Acc; - Indent : Natural) - is - begin - Disp_Indent (Indent); - Disp_Kind (Comp.Common.Kind); - Disp_Depth (Comp.Common.Depth); - Put (": "); - Disp_Name (Comp.Name); - New_Line; - --Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Base, Ident + 1); - end Disp_Component; - - procedure Disp_Instance (Inst : Ghdl_Rtin_Instance_Acc; - Ctxt : Rti_Context; - Indent : Natural) - is - Inst_Addr : Address; - Inst_Base : Address; - Inst_Rti : Ghdl_Rti_Access; - Nindent : Natural; - Nctxt : Rti_Context; - begin - Disp_Indent (Indent); - Disp_Kind (Inst.Common.Kind); - Put (": "); - Disp_Name (Inst.Name); - New_Line; - - Inst_Addr := Ctxt.Base + Inst.Loc; - -- Read sub instance. - Inst_Base := To_Addr_Acc (Inst_Addr).all; - - Nindent := Indent + 1; - - case Inst.Instance.Kind is - when Ghdl_Rtik_Component => - declare - Comp : Ghdl_Rtin_Component_Acc; - begin - Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); - Disp_Indent (Nindent); - Disp_Kind (Comp.Common.Kind); - Put (": "); - Disp_Name (Comp.Name); - New_Line; - -- Disp components generics and ports. - -- FIXME: the data to disp are at COMP_BASE. - Nctxt := (Base => Inst_Addr, - Block => Inst.Instance); - Nindent := Nindent + 1; - Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Nctxt, Nindent); - Nindent := Nindent + 1; - end; - when Ghdl_Rtik_Entity => - null; - when others => - null; - end case; - - -- Read instance RTI. - if Inst_Base /= Null_Address then - Inst_Rti := To_Ghdl_Rti_Acc_Acc (Inst_Base).all; - Nctxt := (Base => Inst_Base, - Block => Inst_Rti); - Disp_Block (To_Ghdl_Rtin_Block_Acc (Inst_Rti), - Nctxt, Nindent); - end if; - end Disp_Instance; - - procedure Disp_Type_Enum_Decl (Enum : Ghdl_Rtin_Type_Enum_Acc; - Indent : Natural) - is - begin - Disp_Indent (Indent); - Disp_Kind (Enum.Common.Kind); - Put (": "); - Disp_Name (Enum.Name); - Put (" is ("); - Disp_Name (Enum.Names (0)); - for I in 1 .. Enum.Nbr - 1 loop - Put (", "); - Disp_Name (Enum.Names (I)); - end loop; - Put (")"); - New_Line; - end Disp_Type_Enum_Decl; - - procedure Disp_Subtype_Scalar_Decl (Def : Ghdl_Rtin_Subtype_Scalar_Acc; - Ctxt : Rti_Context; - Indent : Natural) - is - Bt : Ghdl_Rti_Access; - begin - Disp_Indent (Indent); - Disp_Kind (Def.Common.Kind); - Disp_Depth (Def.Common.Depth); - Put (": "); - Disp_Name (Def.Name); - Put (" is "); - Bt := Def.Basetype; - case Bt.Kind is - when Ghdl_Rtik_Type_I32 - | Ghdl_Rtik_Type_F64 => - declare - Bdef : Ghdl_Rtin_Type_Scalar_Acc; - begin - Bdef := To_Ghdl_Rtin_Type_Scalar_Acc (Bt); - if Bdef.Name /= Def.Name then - Disp_Name (Bdef.Name); - Put (" range "); - end if; - -- This is the type definition. - Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); - end; - when Ghdl_Rtik_Type_P64 - | Ghdl_Rtik_Type_P32 => - declare - Bdef : Ghdl_Rtin_Type_Physical_Acc; - Unit : Ghdl_Rti_Access; - begin - Bdef := To_Ghdl_Rtin_Type_Physical_Acc (Bt); - if Bdef.Name /= Def.Name then - Disp_Name (Bdef.Name); - Put (" range "); - end if; - -- This is the type definition. - Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); - if Bdef.Name = Def.Name then - for I in 0 .. Bdef.Nbr - 1 loop - Unit := Bdef.Units (I); - New_Line; - Disp_Indent (Indent + 1); - Disp_Kind (Unit.Kind); - Put (": "); - Disp_Name (Get_Physical_Unit_Name (Unit)); - Put (" = "); - case Unit.Kind is - when Ghdl_Rtik_Unit64 => - Put_I64 (stdout, - To_Ghdl_Rtin_Unit64_Acc (Unit).Value); - when Ghdl_Rtik_Unitptr => - case Bt.Kind is - when Ghdl_Rtik_Type_P64 => - Put_I64 - (stdout, - To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64); - when Ghdl_Rtik_Type_P32 => - Put_I32 - (stdout, - To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32); - when others => - Internal_Error - ("disp_rti.subtype.scalar_decl(P32/P64)"); - end case; - when others => - Internal_Error - ("disp_rti.subtype.scalar_decl(P32/P64)"); - end case; - end loop; - end if; - end; - when others => - Disp_Subtype_Indication - (To_Ghdl_Rti_Access (Def), Ctxt, Null_Address); - end case; - New_Line; - end Disp_Subtype_Scalar_Decl; - - procedure Disp_Type_Array_Decl (Def : Ghdl_Rtin_Type_Array_Acc; - Ctxt : Rti_Context; - Indent : Natural) - is - begin - Disp_Indent (Indent); - Disp_Kind (Def.Common.Kind); - Put (": "); - Disp_Name (Def.Name); - Put (" is array ("); - for I in 0 .. Def.Nbr_Dim - 1 loop - if I /= 0 then - Put (", "); - end if; - Disp_Subtype_Indication (Def.Indexes (I), Ctxt, Null_Address); - Put (" range <>"); - end loop; - Put (") of "); - Disp_Subtype_Indication (Def.Element, Ctxt, Null_Address); - New_Line; - end Disp_Type_Array_Decl; - - procedure Disp_Subtype_Array_Decl (Def : Ghdl_Rtin_Subtype_Array_Acc; - Ctxt : Rti_Context; - Indent : Natural) - is - Basetype : constant Ghdl_Rtin_Type_Array_Acc := Def.Basetype; - begin - Disp_Indent (Indent); - Disp_Kind (Def.Common.Kind); - Put (": "); - Disp_Name (Def.Name); - Put (" is "); - Disp_Type_Array_Name - (Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt)); - if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then - Put (" of "); - Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address); - end if; - New_Line; - end Disp_Subtype_Array_Decl; - - procedure Disp_Type_File_Or_Access (Def : Ghdl_Rtin_Type_Fileacc_Acc; - Ctxt : Rti_Context; - Indent : Natural) - is - begin - Disp_Indent (Indent); - Disp_Kind (Def.Common.Kind); - Put (": "); - Disp_Name (Def.Name); - Put (" is "); - case Def.Common.Kind is - when Ghdl_Rtik_Type_Access => - Put ("access "); - when Ghdl_Rtik_Type_File => - Put ("file "); - when others => - Put ("?? "); - end case; - Disp_Subtype_Indication (Def.Base, Ctxt, Null_Address); - New_Line; - end Disp_Type_File_Or_Access; - - procedure Disp_Type_Record (Def : Ghdl_Rtin_Type_Record_Acc; - Ctxt : Rti_Context; - Indent : Natural) - is - El : Ghdl_Rtin_Element_Acc; - begin - Disp_Indent (Indent); - Disp_Kind (Def.Common.Kind); - Put (": "); - Disp_Name (Def.Name); - Put (" is record"); - New_Line; - for I in 1 .. Def.Nbrel loop - El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1)); - Disp_Indent (Indent + 1); - Disp_Kind (El.Common.Kind); - Put (": "); - Disp_Name (El.Name); - Put (": "); - Disp_Subtype_Indication (El.Eltype, Ctxt, Null_Address); - New_Line; - end loop; - end Disp_Type_Record; - - procedure Disp_Type_Protected (Def : Ghdl_Rtin_Type_Scalar_Acc; - Ctxt : Rti_Context; - Indent : Natural) - is - pragma Unreferenced (Ctxt); - begin - Disp_Indent (Indent); - Disp_Kind (Def.Common.Kind); - Put (": "); - Disp_Name (Def.Name); - Put (" is protected"); - New_Line; - end Disp_Type_Protected; - - procedure Disp_Rti (Rti : Ghdl_Rti_Access; - Ctxt : Rti_Context; - Indent : Natural) - is - begin - if Rti = null then - return; - end if; - - case Rti.Kind is - when Ghdl_Rtik_Entity - | Ghdl_Rtik_Architecture - | Ghdl_Rtik_Package - | Ghdl_Rtik_Process - | Ghdl_Rtik_Block - | Ghdl_Rtik_If_Generate - | Ghdl_Rtik_For_Generate => - Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); - when Ghdl_Rtik_Package_Body => - Disp_Rti (To_Ghdl_Rtin_Block_Acc (Rti).Parent, Ctxt, Indent); - Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); - when Ghdl_Rtik_Port - | Ghdl_Rtik_Signal - | Ghdl_Rtik_Guard - | Ghdl_Rtik_Attribute_Quiet - | Ghdl_Rtik_Attribute_Stable - | Ghdl_Rtik_Attribute_Transaction => - Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), True, Ctxt, Indent); - when Ghdl_Rtik_Generic - | Ghdl_Rtik_Constant - | Ghdl_Rtik_Variable - | Ghdl_Rtik_Iterator - | Ghdl_Rtik_File => - Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), False, Ctxt, Indent); - when Ghdl_Rtik_Component => - Disp_Component (To_Ghdl_Rtin_Component_Acc (Rti), Indent); - when Ghdl_Rtik_Attribute => - Disp_Attribute (To_Ghdl_Rtin_Object_Acc (Rti), Ctxt, Indent); - when Ghdl_Rtik_Instance => - Disp_Instance (To_Ghdl_Rtin_Instance_Acc (Rti), Ctxt, Indent); - when Ghdl_Rtik_Type_B1 - | Ghdl_Rtik_Type_E8 - | Ghdl_Rtik_Type_E32 => - Disp_Type_Enum_Decl (To_Ghdl_Rtin_Type_Enum_Acc (Rti), Indent); - when Ghdl_Rtik_Subtype_Scalar => - Disp_Subtype_Scalar_Decl (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti), - Ctxt, Indent); - when Ghdl_Rtik_Type_Array => - Disp_Type_Array_Decl - (To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, Indent); - when Ghdl_Rtik_Subtype_Array => - Disp_Subtype_Array_Decl - (To_Ghdl_Rtin_Subtype_Array_Acc (Rti), Ctxt, Indent); - when Ghdl_Rtik_Type_Access - | Ghdl_Rtik_Type_File => - Disp_Type_File_Or_Access - (To_Ghdl_Rtin_Type_Fileacc_Acc (Rti), Ctxt, Indent); - when Ghdl_Rtik_Type_Record => - Disp_Type_Record - (To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Indent); - when Ghdl_Rtik_Type_Protected => - Disp_Type_Protected - (To_Ghdl_Rtin_Type_Scalar_Acc (Rti), Ctxt, Indent); - when others => - Disp_Indent (Indent); - Disp_Kind (Rti.Kind); - Put_Line (" ? "); - end case; - end Disp_Rti; - - Disp_Rti_Flag : Boolean := False; - - procedure Disp_All - is - Ctxt : Rti_Context; - begin - if not Disp_Rti_Flag then - return; - end if; - - Put ("DISP_RTI.Disp_All: "); - Disp_Kind (Ghdl_Rti_Top.Common.Kind); - New_Line; - Ctxt := (Base => Ghdl_Rti_Top_Instance, - Block => Ghdl_Rti_Top.Parent); - Disp_Rti_Arr (Ghdl_Rti_Top.Nbr_Child, - Ghdl_Rti_Top.Children, - Ctxt, 0); - Disp_Rti (Ghdl_Rti_Top.Parent, Ctxt, 0); - - --Disp_Hierarchy; - end Disp_All; - - function Disp_Rti_Option (Opt : String) return Boolean - is - begin - if Opt = "--dump-rti" then - Disp_Rti_Flag := True; - return True; - else - return False; - end if; - end Disp_Rti_Option; - - procedure Disp_Rti_Help - is - procedure P (Str : String) renames Put_Line; - begin - P (" --dump-rti dump Run Time Information"); - end Disp_Rti_Help; - - Disp_Rti_Hooks : aliased constant Hooks_Type := - (Option => Disp_Rti_Option'Access, - Help => Disp_Rti_Help'Access, - Init => null, - Start => Disp_All'Access, - Finish => null); - - procedure Register is - begin - Register_Hooks (Disp_Rti_Hooks'Access); - end Register; - -end Grt.Disp_Rti; diff --git a/src/translate/grt/grt-disp_rti.ads b/src/translate/grt/grt-disp_rti.ads deleted file mode 100644 index 6033d2011..000000000 --- a/src/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 . - procedure Disp_Name (Name : Ghdl_C_String); - - -- Disp a value. - procedure Disp_Value (Stream : FILEs; - Rti : Ghdl_Rti_Access; - Ctxt : Rti_Context; - Obj : in out Address; - Is_Sig : Boolean); - - procedure Register; -end Grt.Disp_Rti; diff --git a/src/translate/grt/grt-disp_signals.adb b/src/translate/grt/grt-disp_signals.adb deleted file mode 100644 index 424d20dcf..000000000 --- a/src/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/src/translate/grt/grt-disp_signals.ads b/src/translate/grt/grt-disp_signals.ads deleted file mode 100644 index 73bd60d06..000000000 --- a/src/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/src/translate/grt/grt-disp_tree.adb b/src/translate/grt/grt-disp_tree.adb deleted file mode 100644 index 7d5811960..000000000 --- a/src/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/src/translate/grt/grt-disp_tree.ads b/src/translate/grt/grt-disp_tree.ads deleted file mode 100644 index e3bc983a7..000000000 --- a/src/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/src/translate/grt/grt-errors.adb b/src/translate/grt/grt-errors.adb deleted file mode 100644 index eddea38c1..000000000 --- a/src/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/src/translate/grt/grt-errors.ads b/src/translate/grt/grt-errors.ads deleted file mode 100644 index c797a71bd..000000000 --- a/src/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/src/translate/grt/grt-files.adb b/src/translate/grt/grt-files.adb deleted file mode 100644 index 30d51cf43..000000000 --- a/src/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/src/translate/grt/grt-files.ads b/src/translate/grt/grt-files.ads deleted file mode 100644 index 14f998468..000000000 --- a/src/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/src/translate/grt/grt-hooks.adb b/src/translate/grt/grt-hooks.adb deleted file mode 100644 index 6a77aaf01..000000000 --- a/src/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/src/translate/grt/grt-hooks.ads b/src/translate/grt/grt-hooks.ads deleted file mode 100644 index 20846c7f8..000000000 --- a/src/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/src/translate/grt/grt-images.adb b/src/translate/grt/grt-images.adb deleted file mode 100644 index 342c98f2a..000000000 --- a/src/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/src/translate/grt/grt-images.ads b/src/translate/grt/grt-images.ads deleted file mode 100644 index cd8911091..000000000 --- a/src/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/src/translate/grt/grt-lib.adb b/src/translate/grt/grt-lib.adb deleted file mode 100644 index d2b095c67..000000000 --- a/src/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/src/translate/grt/grt-lib.ads b/src/translate/grt/grt-lib.ads deleted file mode 100644 index 4dac2c8d2..000000000 --- a/src/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/src/translate/grt/grt-main.adb b/src/translate/grt/grt-main.adb deleted file mode 100644 index 116ea7b2e..000000000 --- a/src/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/src/translate/grt/grt-main.ads b/src/translate/grt/grt-main.ads deleted file mode 100644 index 4f78477f2..000000000 --- a/src/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/src/translate/grt/grt-modules.adb b/src/translate/grt/grt-modules.adb deleted file mode 100644 index e5304f04d..000000000 --- a/src/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/src/translate/grt/grt-modules.ads b/src/translate/grt/grt-modules.ads deleted file mode 100644 index 23c7d6e7a..000000000 --- a/src/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/src/translate/grt/grt-names.adb b/src/translate/grt/grt-names.adb deleted file mode 100644 index e7928f75c..000000000 --- a/src/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/src/translate/grt/grt-names.ads b/src/translate/grt/grt-names.ads deleted file mode 100644 index e0c284231..000000000 --- a/src/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/src/translate/grt/grt-options.adb b/src/translate/grt/grt-options.adb deleted file mode 100644 index df1eb4ec8..000000000 --- a/src/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/src/translate/grt/grt-options.ads b/src/translate/grt/grt-options.ads deleted file mode 100644 index 88b1f5084..000000000 --- a/src/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/src/translate/grt/grt-processes.adb b/src/translate/grt/grt-processes.adb deleted file mode 100644 index 64db682e2..000000000 --- a/src/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/src/translate/grt/grt-processes.ads b/src/translate/grt/grt-processes.ads deleted file mode 100644 index 22326eb5e..000000000 --- a/src/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/src/translate/grt/grt-readline.ads b/src/translate/grt/grt-readline.ads deleted file mode 100644 index 1a3083981..000000000 --- a/src/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/src/translate/grt/grt-rtis.adb b/src/translate/grt/grt-rtis.adb deleted file mode 100644 index 26d976459..000000000 --- a/src/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/src/translate/grt/grt-rtis.ads b/src/translate/grt/grt-rtis.ads deleted file mode 100644 index 6bb76597e..000000000 --- a/src/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/src/translate/grt/grt-rtis_addr.adb b/src/translate/grt/grt-rtis_addr.adb deleted file mode 100644 index 70a0e2118..000000000 --- a/src/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/src/translate/grt/grt-rtis_addr.ads b/src/translate/grt/grt-rtis_addr.ads deleted file mode 100644 index 3fa2792af..000000000 --- a/src/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/src/translate/grt/grt-rtis_binding.ads b/src/translate/grt/grt-rtis_binding.ads deleted file mode 100644 index 7e90eeafc..000000000 --- a/src/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/src/translate/grt/grt-rtis_types.adb b/src/translate/grt/grt-rtis_types.adb deleted file mode 100644 index f22a309bc..000000000 --- a/src/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/src/translate/grt/grt-rtis_types.ads b/src/translate/grt/grt-rtis_types.ads deleted file mode 100644 index f64b17324..000000000 --- a/src/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/src/translate/grt/grt-rtis_utils.adb b/src/translate/grt/grt-rtis_utils.adb deleted file mode 100644 index 0d4328e7e..000000000 --- a/src/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/src/translate/grt/grt-rtis_utils.ads b/src/translate/grt/grt-rtis_utils.ads deleted file mode 100644 index 10c1a0f28..000000000 --- a/src/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/src/translate/grt/grt-sdf.adb b/src/translate/grt/grt-sdf.adb deleted file mode 100644 index 73534e3eb..000000000 --- a/src/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/src/translate/grt/grt-sdf.ads b/src/translate/grt/grt-sdf.ads deleted file mode 100644 index fd05b9e20..000000000 --- a/src/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/src/translate/grt/grt-shadow_ieee.adb b/src/translate/grt/grt-shadow_ieee.adb deleted file mode 100644 index 32af4be5d..000000000 --- a/src/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/src/translate/grt/grt-shadow_ieee.ads b/src/translate/grt/grt-shadow_ieee.ads deleted file mode 100644 index f12b4792f..000000000 --- a/src/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/src/translate/grt/grt-signals.adb b/src/translate/grt/grt-signals.adb deleted file mode 100644 index 9698d8178..000000000 --- a/src/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/src/translate/grt/grt-signals.ads b/src/translate/grt/grt-signals.ads deleted file mode 100644 index d792f1634..000000000 --- a/src/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/src/translate/grt/grt-stack2.adb b/src/translate/grt/grt-stack2.adb deleted file mode 100644 index 82341d072..000000000 --- a/src/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/src/translate/grt/grt-stack2.ads b/src/translate/grt/grt-stack2.ads deleted file mode 100644 index b3de6b76d..000000000 --- a/src/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/src/translate/grt/grt-stacks.adb b/src/translate/grt/grt-stacks.adb deleted file mode 100644 index adb008d02..000000000 --- a/src/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/src/translate/grt/grt-stacks.ads b/src/translate/grt/grt-stacks.ads deleted file mode 100644 index dd9434080..000000000 --- a/src/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/src/translate/grt/grt-stats.adb b/src/translate/grt/grt-stats.adb deleted file mode 100644 index 5bc046d00..000000000 --- a/src/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/src/translate/grt/grt-stats.ads b/src/translate/grt/grt-stats.ads deleted file mode 100644 index 6f60261af..000000000 --- a/src/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/src/translate/grt/grt-std_logic_1164.adb b/src/translate/grt/grt-std_logic_1164.adb deleted file mode 100644 index 5be308bd6..000000000 --- a/src/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/src/translate/grt/grt-std_logic_1164.ads b/src/translate/grt/grt-std_logic_1164.ads deleted file mode 100644 index 4d1569553..000000000 --- a/src/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/src/translate/grt/grt-stdio.ads b/src/translate/grt/grt-stdio.ads deleted file mode 100644 index 229249ac9..000000000 --- a/src/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/src/translate/grt/grt-table.adb b/src/translate/grt/grt-table.adb deleted file mode 100644 index 36aa99982..000000000 --- a/src/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/src/translate/grt/grt-table.ads b/src/translate/grt/grt-table.ads deleted file mode 100644 index f814eff5c..000000000 --- a/src/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/src/translate/grt/grt-threads.ads b/src/translate/grt/grt-threads.ads deleted file mode 100644 index 248f2c41b..000000000 --- a/src/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/src/translate/grt/grt-types.ads b/src/translate/grt/grt-types.ads deleted file mode 100644 index fed822554..000000000 --- a/src/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/src/translate/grt/grt-unithread.adb b/src/translate/grt/grt-unithread.adb deleted file mode 100644 index 6acb52169..000000000 --- a/src/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/src/translate/grt/grt-unithread.ads b/src/translate/grt/grt-unithread.ads deleted file mode 100644 index b35b7be33..000000000 --- a/src/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/src/translate/grt/grt-values.adb b/src/translate/grt/grt-values.adb deleted file mode 100644 index 3d703bc85..000000000 --- a/src/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/src/translate/grt/grt-values.ads b/src/translate/grt/grt-values.ads deleted file mode 100644 index 8df8c3f63..000000000 --- a/src/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/src/translate/grt/grt-vcd.adb b/src/translate/grt/grt-vcd.adb deleted file mode 100644 index d4a9ea066..000000000 --- a/src/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/src/translate/grt/grt-vcd.ads b/src/translate/grt/grt-vcd.ads deleted file mode 100644 index ed015af80..000000000 --- a/src/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/src/translate/grt/grt-vcdz.adb b/src/translate/grt/grt-vcdz.adb deleted file mode 100644 index 8e1ceb6f1..000000000 --- a/src/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/src/translate/grt/grt-vcdz.ads b/src/translate/grt/grt-vcdz.ads deleted file mode 100644 index aba61c222..000000000 --- a/src/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/src/translate/grt/grt-vital_annotate.adb b/src/translate/grt/grt-vital_annotate.adb deleted file mode 100644 index 93ecb8119..000000000 --- a/src/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/src/translate/grt/grt-vital_annotate.ads b/src/translate/grt/grt-vital_annotate.ads deleted file mode 100644 index acf82bba2..000000000 --- a/src/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/src/translate/grt/grt-vpi.adb b/src/translate/grt/grt-vpi.adb deleted file mode 100644 index 9b77319f1..000000000 --- a/src/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/src/translate/grt/grt-vpi.ads b/src/translate/grt/grt-vpi.ads deleted file mode 100644 index 86fb07374..000000000 --- a/src/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/src/translate/grt/grt-vstrings.adb b/src/translate/grt/grt-vstrings.adb deleted file mode 100644 index 30c58ab41..000000000 --- a/src/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/src/translate/grt/grt-vstrings.ads b/src/translate/grt/grt-vstrings.ads deleted file mode 100644 index 94967bb0f..000000000 --- a/src/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/src/translate/grt/grt-waves.adb b/src/translate/grt/grt-waves.adb deleted file mode 100644 index 63bdb9a54..000000000 --- a/src/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/src/translate/grt/grt-waves.ads b/src/translate/grt/grt-waves.ads deleted file mode 100644 index 72d7ea6e1..000000000 --- a/src/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/src/translate/grt/grt-zlib.ads b/src/translate/grt/grt-zlib.ads deleted file mode 100644 index 9dfee3665..000000000 --- a/src/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/src/translate/grt/grt.adc b/src/translate/grt/grt.adc deleted file mode 100644 index f2284997d..000000000 --- a/src/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/src/translate/grt/grt.ads b/src/translate/grt/grt.ads deleted file mode 100644 index 9727d0430..000000000 --- a/src/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/src/translate/grt/grt.ver b/src/translate/grt/grt.ver deleted file mode 100644 index 031c20761..000000000 --- a/src/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/src/translate/grt/main.adb b/src/translate/grt/main.adb deleted file mode 100644 index 5de379449..000000000 --- a/src/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/src/translate/grt/main.ads b/src/translate/grt/main.ads deleted file mode 100644 index f7c414274..000000000 --- a/src/translate/grt/main.ads +++ /dev/null @@ -1,34 +0,0 @@ --- GHDL Run Time (GRT) - C-like entry point. --- Copyright (C) 2002 - 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. --- --- As a special exception, if other files instantiate generics from this --- unit, or you link this unit with other files to produce an executable, --- this unit does not by itself cause the resulting executable to be --- covered by the GNU General Public License. This exception does not --- however invalidate any other reasons why the executable file might be --- covered by the GNU Public License. - --- In the usual case of a standalone executable, this file defines the --- standard entry point, ie the main() function. --- --- However, as explained in the manual, the user can use its own main() --- function, and calls the ghdl entry point ghdl_main. -with System; - -function Main (Argc : Integer; Argv : System.Address) return Integer; -pragma Export (C, Main, "main"); diff --git a/src/translate/mcode/Makefile.in b/src/translate/mcode/Makefile.in deleted file mode 100644 index beb450a08..000000000 --- a/src/translate/mcode/Makefile.in +++ /dev/null @@ -1,54 +0,0 @@ -PREFIX=/usr/local -target=i686-pc-linux-gnu - -CFLAGS=-O -GNATFLAGS=$(CFLAGS) -gnatn - -GRT_FLAGS=$(CFLAGS) - -all: ghdl_mcode std.v93 std.v87 ieee.v93 ieee.v87 synopsys.v93 synopsys.v87 mentor.v93 - - -GRTSRCDIR=grt - -####grt Makefile.inc - -ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) mmap_binding.o force - gnatmake -aIghdldrv -aIghdl -aIortho -aIgrt $(GNATFLAGS) ghdl_mcode $(GNAT_BARGS) -largs mmap_binding.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(GRT_EXTRA_LIB) -Wl,--version-script=$(GRTSRCDIR)/grt.ver -Wl,--export-dynamic - -mmap_binding.o: ortho/mmap_binding.c - $(CC) -c -g -o $@ $< - -default_pathes.ads: Makefile - echo "-- DO NOT EDIT" > tmp-dpathes.ads - echo "-- This file is created by Makefile" >> tmp-dpathes.ads - echo "package Default_Pathes is" >> tmp-dpathes.ads - echo " Prefix : constant String :=">> tmp-dpathes.ads - echo " \"$(PREFIX)/lib/ghdl/\";" >> tmp-dpathes.ads - echo "end Default_Pathes;" >> tmp-dpathes.ads - if test -r $@ && cmp tmp-dpathes.ads $@; then \ - echo "$@ unchanged"; \ - else \ - mv tmp-dpathes.ads $@; \ - fi - $(RM) tmp-dpathes.ads - -force: - -LIB93_DIR:=./lib/v93 -LIB87_DIR:=./lib/v87 -LIBSRC_DIR:=./libraries -ANALYZE=../../../ghdl_mcode -a --ieee=none -REL_DIR=../../.. -VHDLLIBS_COPY_OBJS:=no -CP=cp -LN=ln -s - -./lib: - mkdir $@ - -$(LIB93_DIR) $(LIB87_DIR): ./lib - mkdir $@ - - -####libraries Makefile.inc diff --git a/src/translate/mcode/README b/src/translate/mcode/README deleted file mode 100644 index a10cd6efc..000000000 --- a/src/translate/mcode/README +++ /dev/null @@ -1,47 +0,0 @@ -This is the README from the source distribution of GHDL. - -To get the binary distribution or more information, go to http://ghdl.free.fr - -Copyright: -********** -GHDL is copyright (c) 2002, 2003, 2004, 2005 Tristan Gingold. -See the GHDL manual for more details. - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. - - -Building GHDL from sources for Windows: -*************************************** - -Note: this was tested with Windows XP SP2 familly edition. - -Note: If you want to create the installer, GHDL should be built on a -FAT partition. NSIS rounds files date to be FAT compliant (seconds are always -even) and because GHDL stores dates, the files date must not be modified. - -Required: -* the Ada95 GNAT compiler (GNAT GPL 2005 is known to work). -* NSIS to create the installer. - -Unzip, -edit winbuild to use correct path for makensis, -run winbuild. - -The installer is in the windows directory. - -Send bugs and comments on http://gna.org/project/ghdl - -Tristan Gingold. diff --git a/src/translate/mcode/dist.sh b/src/translate/mcode/dist.sh deleted file mode 100755 index cf24141de..000000000 --- a/src/translate/mcode/dist.sh +++ /dev/null @@ -1,506 +0,0 @@ -#!/bin/sh - -# Script used to create tar balls. -# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold -# -# GHDL is free software; you can redistribute it and/or modify it under -# the terms of the GNU General Public License as published by the Free -# Software Foundation; either version 2, or (at your option) any later -# version. -# -# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or -# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -# for more details. -# -# You should have received a copy of the GNU General Public License -# along with GCC; see the file COPYING. If not, write to the Free -# Software Foundation, 59 Temple Place - Suite 330, Boston, MA -# 02111-1307, USA. - -# Building a distribution: -# * update the 'version' variable in ../../Makefile -# * Regenerate version.ads: make -f ../../Makefile version.ads -# * Check NEWS, README and INSTALL files. -# * Check version and copyright years in doc/ghdl.texi, ghdlmain.adb -# * Check GCCVERSION below. -# * Check lists of exported files in this file. -# * Create source tar and build binaries: ./dist.sh dist_phase1 -# * su root -# * Build binary tar: ./dist.sh dist_phase2 -# * Run the testsuites: GHDL=ghdl ./testsuite.sh -# * Update website/index.html (./dist.sh website helps, rename .new) -# * upload (./dist upload) -# * CVS commit, tag + cd image. -# * remove previous version in /usr/local - -## DO NOT MODIFY this file while it is running... - -set -e - -# GTKWave version. -GTKWAVE_VERSION=1.3.72 - -# GHDL version (extracted from version.ads) -VERSION=`sed -n -e 's/.*GHDL \([0-9.a-z]*\) (.*/\1/p' ../../version.ads` - -CWD=`pwd` - -distdir=ghdl-$VERSION -tarfile=$distdir.tar -zipfile=$distdir.zip - -PREFIX=/usr/local -bindirname=ghdl-$VERSION-i686-pc-linux -TARINSTALL=$DISTDIR/$bindirname.tar.bz2 -VHDLDIR=$distdir/vhdl -DOWNLOAD_HTML=../../website/download.html -DESTDIR=$CWD/ -UNSTRIPDIR=${distdir}-unstripped - -PATH=/usr/gnat/bin:$PATH - -do_clean () -{ - rm -rf $distdir - mkdir $distdir - mkdir $distdir/ghdl - mkdir $distdir/ghdldrv - mkdir $distdir/libraries - mkdir $distdir/libraries/std $distdir/libraries/ieee - mkdir $distdir/libraries/vital95 $distdir/libraries/vital2000 - mkdir $distdir/libraries/synopsys $distdir/libraries/mentor - mkdir $distdir/grt - mkdir $distdir/grt/config - mkdir $distdir/ortho - mkdir $distdir/windows -} - -# Build Makefile -do_Makefile () -{ - sed -e "/^####libraries Makefile.inc/r ../../libraries/Makefile.inc" \ - -e "/^####grt Makefile.inc/r ../grt/Makefile.inc" \ - < Makefile.in > $distdir/Makefile -} - -# Copy (or link) sources files into $distdir -do_files () -{ -. ../gcc/dist-common.sh - -ortho_mcode_files=" -binary_file-elf.adb -binary_file-elf.ads -binary_file-memory.adb -binary_file-memory.ads -binary_file.adb -binary_file.ads -disa_x86.adb -disa_x86.ads -disassemble.ads -dwarf.ads -elf32.adb -elf32.ads -elf64.ads -elf_common.adb -elf_common.ads -elf_arch32.ads -elf_arch.ads -hex_images.adb -hex_images.ads -memsegs.ads -memsegs_mmap.ads -memsegs_mmap.adb -memsegs_c.c -ortho_code-abi.ads -ortho_code-binary.adb -ortho_code-binary.ads -ortho_code-consts.adb -ortho_code-consts.ads -ortho_code-debug.adb -ortho_code-debug.ads -ortho_code-decls.adb -ortho_code-decls.ads -ortho_code-disps.adb -ortho_code-disps.ads -ortho_code-dwarf.adb -ortho_code-dwarf.ads -ortho_code-exprs.adb -ortho_code-exprs.ads -ortho_code-flags.ads -ortho_code-opts.adb -ortho_code-opts.ads -ortho_code-types.adb -ortho_code-types.ads -ortho_code-sysdeps.adb -ortho_code-sysdeps.ads -ortho_code-x86-emits.adb -ortho_code-x86-emits.ads -ortho_code-x86-insns.adb -ortho_code-x86-insns.ads -ortho_code-x86-abi.adb -ortho_code-x86-abi.ads -ortho_code-x86-flags.ads -ortho_code-x86.adb -ortho_code-x86.ads -ortho_code.ads -ortho_code_main.adb -ortho_ident.adb -ortho_ident.ads -ortho_mcode.adb -ortho_mcode.ads -ortho_nodes.ads -" - -windows_files=" -compile.bat -complib.bat -default_pathes.ads -ghdl.nsi -windows_default_path.adb -windows_default_path.ads -ghdlfilter.adb -ortho_code-sysdeps.adb -grt-modules.adb -" - -drv_files=" -ghdlcomp.ads -ghdlcomp.adb -foreigns.ads -foreigns.adb -ghdlrun.adb -ghdlrun.ads -ghdl_mcode.adb -" - -for i in $cfiles; do ln -sf $CWD/../../$i $distdir/ghdl/$i; done -for i in $tfiles; do ln -sf $CWD/../$i $distdir/ghdl/$i; done - -ln -sf $CWD/../../doc/ghdl.texi $distdir/ghdl.texi - -for i in $ortho_files; do ln -sf $CWD/../../ortho/$i $distdir/ortho/$i; done - -for i in $ortho_mcode_files; do - ln -sf $CWD/../../ortho/mcode/$i $distdir/ortho/$i -done - -for i in $ghdl_files $drv_files; do - ln -sf $CWD/../ghdldrv/$i $distdir/ghdldrv/$i -done - -for i in $libraries_files; do - ln -sf $CWD/../../libraries/$i $distdir/libraries/$i -done - -for i in $grt_files; do - ln -sf $CWD/../grt/$i $distdir/grt/$i -done - -for i in $grt_config_files; do - ln -sf $CWD/../grt/config/$i $distdir/grt/config/$i -done - -for i in $windows_files; do - ln -sf $CWD/windows/$i $distdir/windows/$i -done - echo "!define VERSION \"$VERSION\"" > $distdir/windows/version.nsi - - - ln -sf $CWD/winbuild.bat $distdir/winbuild.bat - -makeinfo --html --no-split -o $distdir/windows/ghdl.htm $CWD/../../doc/ghdl.texi -} - -do_sources_dir () -{ - \rm -rf $distdir - mkdir $distdir - do_clean - do_Makefile - do_files - ln -sf ../../../COPYING $distdir -} - -# Create the tar of sources. -do_tar () -{ - do_sources_dir - tar cvhf $tarfile $distdir - bzip2 -f $tarfile - rm -rf $distdir -} - -# Create the zip of sources. -do_zip () -{ - do_sources_dir - zip -r $zipfile $distdir - rm -rf $distdir -} - -# Extract the source, configure and make. -do_compile () -{ - set -x - - do_update_gcc_sources; - - rm -rf $GCCDISTOBJ - mkdir $GCCDISTOBJ - cd $GCCDISTOBJ - ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX - make CFLAGS="-O -g" - make -C gcc vhdl.info - cd $CWD -} - -check_root () -{ - if [ $UID -ne 0 ]; then - echo "$0: you must be root"; - exit 1; - fi -} - -# Do a make install -do_compile2 () -{ - set -x - cd $GCCDISTOBJ - # Check the info file is not empty. - if [ -s gcc/doc/ghdl.info ]; then - echo "info file found" - else - echo "Error: ghdl.info not found". - exit 1; - fi - mkdir -p $DESTDIR/usr/local || true - make DESTDIR=$DESTDIR install - cd $CWD - if [ -d $UNSTRIPDIR ]; then - rm -rf $UNSTRIPDIR - fi - mkdir $UNSTRIPDIR - cp ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl $UNSTRIPDIR - chmod -w $UNSTRIPDIR/* - strip ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl -} - -# Create the tar file from the current installation. -do_tar_install () -{ - tar -C $DESTDIR -jcvf $TARINSTALL \ - ./$PREFIX/bin/ghdl ./$PREFIX/info/ghdl.info \ - ./$GCCLIBDIR/vhdl \ - ./$GCCLIBEXECDIR/ghdl1 -} - -do_extract_tar_install () -{ - check_root; - cd / - tar jxvf $TARINSTALL - cd $CWD -} - -# Create the tar file to be distributed. -do_tar_dist () -{ - rm -rf $bindirname - mkdir $bindirname - sed -e "s/@TARFILE@/$dir.tar/" < INSTALL > $bindirname/INSTALL - ln ../../COPYING $bindirname - ln $TARINSTALL $bindirname - tar cvf $bindirname.tar $bindirname -} - -# Remove the non-ghdl files of gcc in the current installation. -do_distclean_gcc () -{ - set -x - rm -f ${DESTDIR}${PREFIX}/bin/cpp ${DESTDIR}${PREFIX}/bin/gcc - rm -f ${DESTDIR}${PREFIX}/bin/gccbug ${DESTDIR}${PREFIX}/bin/gcov - rm -f ${DESTDIR}${PREFIX}/bin/${MACHINE}-gcc* - rm -f ${DESTDIR}${PREFIX}/info/cpp.info* - rm -f ${DESTDIR}${PREFIX}/info/cppinternals.info* - rm -f ${DESTDIR}${PREFIX}/info/gcc.info* - rm -f ${DESTDIR}${PREFIX}/info/gccinstall.info* - rm -f ${DESTDIR}${PREFIX}/info/gccint.info* - rm -f ${DESTDIR}${PREFIX}/lib/*.a ${DESTDIR}${PREFIX}/lib/*.so* - rm -rf ${DESTDIR}${PREFIX}/share - rm -rf ${DESTDIR}${PREFIX}/man - rm -rf ${DESTDIR}${PREFIX}/include - rm -f ${DESTDIR}${GCCLIBEXECDIR}/cc1 ${DESTDIR}${GCCLIBEXECDIR}/collect2 - rm -f ${DESTDIR}${GCCLIBEXECDIR}/cpp0 ${DESTDIR}${GCCLIBEXECDIR}/tradcpp0 - rm -f ${DESTDIR}${GCCLIBDIR}/*.o ${DESTDIR}$GCCLIBDIR/*.a - rm -f ${DESTDIR}${GCCLIBDIR}/specs - rm -rf ${DESTDIR}${GCCLIBDIR}/include - rm -rf ${DESTDIR}${GCCLIBDIR}/install-tools - rm -rf ${DESTDIR}${GCCLIBEXECDIR}/install-tools -} - -# Remove ghdl files in the current installation. -do_distclean_ghdl () -{ - check_root; - set -x - rm -f $PREFIX/bin/ghdl - rm -f $PREFIX/info/ghdl.info* - rm -f $GCCLIBEXECDIR/ghdl1 - rm -rf $GCCLIBDIR/vhdl -} - -# Build the source tar, and build the binaries. -do_dist_phase1 () -{ - do_sources; - do_compile; - do_compile2; - do_distclean_gcc; - do_tar_install; - do_tar_dist; - rm -rf ./$PREFIX -} - -# Install the binaries and create the binary tar. -do_dist_phase2 () -{ - check_root; - do_distclean_ghdl; - do_extract_tar_install; - echo "dist_phase2 success" -} - -# Create gtkwave patch -do_gtkwave_patch () -{ -# rm -rf gtkwave-patch - mkdir gtkwave-patch - diff -rc -x Makefile.in $GTKWAVE_BASE.orig $GTKWAVE_BASE | \ - sed -e "/^Only in/d" \ - > gtkwave-patch/gtkwave-$GTKWAVE_VERSION.diffs - cp ../grt/ghwlib.c ../grt/ghwlib.h $GTKWAVE_BASE/src/ghw.c gtkwave-patch - sed -e "s/VERSION/$GTKWAVE_VERSION/g" < README.gtkwave > gtkwave-patch/README - tar zcvf ../../website/gtkwave-patch.tgz gtkwave-patch - rm -rf gtkwave-patch -} - -# Update the index.html -# Update the doc -do_website () -{ - sed -e " -/SRC-HREF/ s/href=\".*\"/href=\"$tarfile.bz2\"/ -/BIN-HREF/ s/href=\".*\"/href=\"$bindirname.tar\"/ -/HISTORY/ a \\ - \\ - $VERSION\\ - `date +'%b %e %Y'`\\ - $GCCVERSION\\ - $tarfile.bz2\\ - \\ - $bindirname.tar\\ - -" < $DOWNLOAD_HTML > "$DOWNLOAD_HTML".new - dir=../../website/ghdl - echo "Updating $dir" - rm -rf $dir - makeinfo --html -o $dir ../../doc/ghdl.texi -} - -# Do ftp commands to upload -do_upload () -{ -if tty -s; then - echo -n "Please, enter password: " - stty -echo - read pass - stty echo - echo -else - echo "$0: upload must be done from a tty" - exit 1; -fi -ftp -n < windows/version.nsi - -"c:\Program Files\NSIS\makensis" windows\ghdl.nsi -if errorlevel 1 goto end - -exit /b 0 - -:end -echo "Error during compilation" -exit /b 1 - diff --git a/src/translate/mcode/windows/compile.bat b/src/translate/mcode/windows/compile.bat deleted file mode 100644 index c668ef0e2..000000000 --- a/src/translate/mcode/windows/compile.bat +++ /dev/null @@ -1,24 +0,0 @@ -mkdir build -cd build - -rem Do the compilation -set CFLAGS=-O -g -gcc -c %CFLAGS% ../../grt/grt-cbinding.c -gcc -c %CFLAGS% ../../grt/grt-cvpi.c -gcc -c %CFLAGS% ../../grt/config/clock.c -gcc -c %CFLAGS% ../../../ortho/mcode/memsegs_c.c -gcc -c %CFLAGS% -DWITH_GNAT_RUN_TIME ../../grt/config/win32.c -gnatmake %CFLAGS% -gnatn -aI../windows -aI../../.. -aI../.. -aI../../ghdldrv -aI../../../psl -aI../../grt -aI../../../ortho/mcode ghdl_mcode -aI../../../ortho -o ghdl.exe -largs grt-cbinding.o clock.o grt-cvpi.o memsegs_c.o win32.o -largs -Wl,--stack,8404992 - -if errorlevel 1 goto failed - -strip ghdl.exe - -cd .. -exit /b 0 - -:failed -echo "Compilation failed" -cd .. -exit /b 1 - diff --git a/src/translate/mcode/windows/complib.bat b/src/translate/mcode/windows/complib.bat deleted file mode 100644 index 88a43ce60..000000000 --- a/src/translate/mcode/windows/complib.bat +++ /dev/null @@ -1,68 +0,0 @@ -set GHDL=ghdl - -cd build -gnatmake -aI..\windows ghdlfilter -cd .. - -set REL=..\..\.. -set LIBSRC=%REL%\..\..\libraries -set STD_SRCS=textio textio_body -set IEEE_SRCS=std_logic_1164 std_logic_1164_body numeric_std numeric_std-body numeric_bit numeric_bit-body -set VITAL95_SRCS=vital_timing vital_timing_body vital_primitives vital_primitives_body -set VITAL2000_SRCS=timing_p timing_b prmtvs_p prmtvs_b memory_p memory_b - -set SYNOPSYS_SRCS=std_logic_arith std_logic_textio std_logic_unsigned std_logic_signed std_logic_misc std_logic_misc-body - -mkdir lib -cd lib - -mkdir v87 -cd v87 - -mkdir std -cd std -for %%F in (%STD_SRCS%) do %REL%\build\ghdlfilter -v87 < %LIBSRC%\std\%%F.vhdl > %%F.v87 && %REL%\build\%GHDL% -a --std=87 --bootstrap --work=std %%F.v87 -cd .. - -mkdir ieee -cd ieee -rem Base ieee -for %%F in (%IEEE_SRCS%) do %REL%\build\ghdlfilter -v87 < %LIBSRC%\ieee\%%F.vhdl > %%F.v87 && %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee %%F.v87 -rem Vital 95 -for %%F in (%VITAL95_SRCS%) do copy %LIBSRC%\vital95\%%F.vhdl %%F.vhd && %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee %%F.vhd -cd .. - -mkdir synopsys -cd synopsys -for %%F in (%IEEE_SRCS%) do %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee ..\ieee\%%F.v87 -for %%F in (%VITAL95_SRCS%) do %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee ..\ieee\%%F.vhd -for %%F in (%SYNOPSYS_SRCS%) do copy %LIBSRC%\synopsys\%%F.vhdl %%F.vhd && %REL%\build\%GHDL% -a --std=87 -P..\std --work=ieee %%F.vhd -cd .. - -cd .. -mkdir v93 -cd v93 - -mkdir std -cd std -for %%F in (%STD_SRCS%) do %REL%\build\ghdlfilter -v93 < %LIBSRC%\std\%%F.vhdl > %%F.v93 && %REL%\build\%GHDL% -a --std=93 --bootstrap --work=std %%F.v93 -cd .. - -mkdir ieee -cd ieee -echo Base ieee -for %%F in (%IEEE_SRCS%) do %REL%\build\ghdlfilter -v93 < %LIBSRC%\ieee\%%F.vhdl > %%F.v93 && %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee %%F.v93 -echo Vital 2000 -for %%F in (%VITAL2000_SRCS%) do copy %LIBSRC%\vital2000\%%F.vhdl %%F.vhd && %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee %%F.vhd -cd .. - -mkdir synopsys -cd synopsys -for %%F in (%IEEE_SRCS%) do %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee ..\ieee\%%F.v93 -for %%F in (%VITAL2000_SRCS%) do %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee ..\ieee\%%F.vhd -for %%F in (%SYNOPSYS_SRCS%) do %REL%\build\%GHDL% -a --std=93 -P..\std --work=ieee ..\..\v87\synopsys\%%F.vhd -cd .. - -cd .. - -cd .. diff --git a/src/translate/mcode/windows/default_pathes.ads b/src/translate/mcode/windows/default_pathes.ads deleted file mode 100644 index 51b350f4e..000000000 --- a/src/translate/mcode/windows/default_pathes.ads +++ /dev/null @@ -1,8 +0,0 @@ -with Windows_Default_Path; -pragma Elaborate_All (Windows_Default_Path); - -package Default_Pathes is - Install_Prefix : constant String := - Windows_Default_Path.Get_Windows_Exec_Path; - Lib_Prefix : constant String := "lib"; -end Default_Pathes; diff --git a/src/translate/mcode/windows/ghdl.nsi b/src/translate/mcode/windows/ghdl.nsi deleted file mode 100644 index aa4d559aa..000000000 --- a/src/translate/mcode/windows/ghdl.nsi +++ /dev/null @@ -1,455 +0,0 @@ -; ghdl.nsi -; -; This script is based on example2.nsi. -; remember the directory, -; Check if administrator -; uninstall support -; TODO: -; * allow multiple version -; * command line installation -; * Allow user install - -;-------------------------------- -!include version.nsi -;-------------------------------- - -; The name of the installer -Name "Ghdl" - -; The file to write -OutFile "ghdl-installer-${VERSION}.exe" - -SetDateSave on - -; The default installation directory -InstallDir $PROGRAMFILES\Ghdl - -; Registry key to check for directory (so if you install again, it will -; overwrite the old one automatically) -InstallDirRegKey HKLM "Software\Ghdl" "Install_Dir" - -LicenseData ..\..\..\COPYING -; LicenseForceSelection - -;-------------------------------- - -; Pages - -Page license -Page components -Page directory -Page instfiles - -UninstPage uninstConfirm -UninstPage instfiles - -;-------------------------------- -Function .onInit - Call IsNT - pop $R0 - StrCmp $R0 1 nt_ok - MessageBox MB_OK|MB_ICONEXCLAMATION "You must use Windows NT (XP/2000/Me...)" - Quit - -nt_ok: - Call IsUserAdmin - Pop $R0 - StrCmp $R0 "true" Admin - MessageBox MB_OK|MB_ICONEXCLAMATION "You must have Admin rights" - Quit - -Admin: - - ;;; Check if already installed. - ReadRegStr $0 HKLM "Software\Ghdl" "Install_Dir" - IfErrors not_installed - ReadRegStr $0 HKLM "Software\Ghdl" "Version" - IfErrors unknown_prev_version - Goto known_version -unknown_prev_version: - StrCpy $0 "(unknown)" -known_version: - MessageBox MB_OKCANCEL|MB_ICONEXCLAMATION "You already have GHDL version $0 installed. Deinstall ?" IDCANCEL install_abort IDOK deinstall -install_abort: - Abort "Installation aborted" -deinstall: - ReadRegStr $0 HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "UninstallString" - IfErrors deinstall_failed - - ; First version of the GHDL installer adds quotes - StrCpy $1 $0 1 - StrCmp $1 '"' 0 str_ok - StrCpy $1 $0 "" 1 - StrCpy $0 $1 -1 -str_ok: - - ; Read install dir - ReadRegStr $1 HKLM "Software\Ghdl" "Install_Dir" - IfErrors deinstall_failed - -; MessageBox MB_OK 'copy $0 to $TEMP' - - ClearErrors -; MessageBox MB_OK 'copy $0 to $TEMP' - CopyFiles $0 $TEMP - IfErrors deinstall_failed - ExecWait '"$TEMP\uninst-ghdl.exe" /S _?=$1' - IfErrors deinstall_failed - Delete "$TEMP\uninst-ghdl.exe" - Return -deinstall_failed: - Delete $TEMP\uninst-ghdl.exe - MessageBox MB_YESNO|MB_ICONSTOP "Can't deinstall GHDL: de-installer not found or failed. Continue installation ?" IDNO install_abort -not_installed: - Return -FunctionEnd - -;-------------------------------- - -; The stuff to install -Section "Ghdl Compiler (required)" - - SectionIn RO - - ; Set output path to the installation directory. - SetOutPath $INSTDIR\bin - File /oname=ghdl.exe ..\build\ghdl.exe - - SetOutPath $INSTDIR - File /oname=COPYING.txt ..\..\..\COPYING - - ; Write the installation path into the registry - WriteRegStr HKLM "Software\Ghdl" "Install_Dir" $INSTDIR - ; Write te version - WriteRegStr HKLM "Software\Ghdl" "Version" ${VERSION} - - ; Write the uninstall keys for Windows - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "DisplayName" "Ghdl" - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "UninstallString" $INSTDIR\uninst-ghdl.exe - WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "NoModify" 1 - WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" "NoRepair" 1 - WriteUninstaller $INSTDIR\uninst-ghdl.exe" - -SectionEnd - -Section "VHDL standard and ieee libraries" - SectionIn RO - SetOutPath $INSTDIR\lib\v87 - File /r ..\lib\v87\std ..\lib\v87\ieee - SetOutPath $INSTDIR\lib\v93 - File /r ..\lib\v93\std ..\lib\v93\ieee -SectionEnd - -Section "Synopsys libraries (Recommended)" - SetOutPath $INSTDIR\lib\v87 - File /r ..\lib\v87\synopsys - SetOutPath $INSTDIR\lib\v93 - File /r ..\lib\v93\synopsys -SectionEnd - -Section "Documentation (Recommended)" - SetOutPath $INSTDIR - File /oname=ghdl.htm ..\..\..\doc\ghdl.html -SectionEnd - -Section "Add in PATH (Recommended)" - WriteRegDWORD HKLM "Software\Ghdl" "PathSet" 1 - Push $INSTDIR\Bin - Call AddToPath -SectionEnd - -; Optional section (can be disabled by the user) -;Section "Start Menu Shortcuts" -; -; CreateDirectory "$SMPROGRAMS\Ghdl" -; CreateShortCut "$SMPROGRAMS\Ghdl\Uninstall.lnk" "$INSTDIR\uninstall.exe" "" "$INSTDIR\uninstall.exe" 0 -; CreateShortCut "$SMPROGRAMS\Ghdl\Ghdl.lnk" "$INSTDIR\example2.nsi" "" "$INSTDIR\example2.nsi" 0 -; -;SectionEnd -; - -;-------------------------------- - -; Uninstaller - -Section "Uninstall" - - ReadRegDWORD $0 HKLM "Software\Ghdl" "PathSet" - StrCmp $0 "1" "" path_not_set - Push $INSTDIR\Bin - Call un.RemoveFromPath - -path_not_set: - - ; Remove registry keys - DeleteRegKey HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\Ghdl" - DeleteRegKey HKLM Software\Ghdl - - ; Remove files and uninstaller - Delete $INSTDIR\bin\ghdl.exe - Delete $INSTDIR\uninst-ghdl.exe - Delete $INSTDIR\COPYING.txt - RMDir $INSTDIR\bin - RMDir /r $INSTDIR\lib - - - ; Remove shortcuts, if any - ; Delete "$SMPROGRAMS\Ghdl\*.*" - - ; Remove directories used - ; RMDir "$SMPROGRAMS\Ghdl" - RMDir "$INSTDIR" - -SectionEnd - -;;;;;;;; Misc functions - -; Author: Lilla (lilla@earthlink.net) 2003-06-13 -; function IsUserAdmin uses plugin \NSIS\PlusgIns\UserInfo.dll -; This function is based upon code in \NSIS\Contrib\UserInfo\UserInfo.nsi -; This function was tested under NSIS 2 beta 4 (latest CVS as of this writing). -; -; Usage: -; Call IsUserAdmin -; Pop $R0 ; at this point $R0 is "true" or "false" -; -Function IsUserAdmin -Push $R0 -Push $R1 -Push $R2 - -ClearErrors -UserInfo::GetName -IfErrors Win9x -Pop $R1 -UserInfo::GetAccountType -Pop $R2 - -StrCmp $R2 "Admin" 0 Continue -; Observation: I get here when running Win98SE. (Lilla) -; The functions UserInfo.dll looks for are there on Win98 too, -; but just don't work. So UserInfo.dll, knowing that admin isn't required -; on Win98, returns admin anyway. (per kichik) -; MessageBox MB_OK 'User "$R1" is in the Administrators group' -StrCpy $R0 "true" -Goto Done - -Continue: -; You should still check for an empty string because the functions -; UserInfo.dll looks for may not be present on Windows 95. (per kichik) -StrCmp $R2 "" Win9x -StrCpy $R0 "false" -;MessageBox MB_OK 'User "$R1" is in the "$R2" group' -Goto Done - -Win9x: -; comment/message below is by UserInfo.nsi author: -; This one means you don't need to care about admin or -; not admin because Windows 9x doesn't either -;MessageBox MB_OK "Error! This DLL can't run under Windows 9x!" -StrCpy $R0 "true" - -Done: -;MessageBox MB_OK 'User= "$R1" AccountType= "$R2" IsUserAdmin= "$R0"' - -Pop $R2 -Pop $R1 -Exch $R0 -FunctionEnd - - -!define ALL_USERS - -!ifndef WriteEnvStr_RegKey - !ifdef ALL_USERS - !define WriteEnvStr_RegKey \ - 'HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment"' - !else - !define WriteEnvStr_RegKey 'HKCU "Environment"' - !endif -!endif - -!verbose 3 -!include "WinMessages.NSH" -!verbose 4 - -; AddToPath - Adds the given dir to the search path. -; Input - head of the stack -; Note - Win9x systems requires reboot - -Function AddToPath - Exch $0 - Push $1 - Push $2 - Push $3 - - # don't add if the path doesn't exist - IfFileExists "$0\*.*" "" AddToPath_done - - ReadEnvStr $1 PATH - Push "$1;" - Push "$0;" - Call StrStr - Pop $2 - StrCmp $2 "" "" AddToPath_done - Push "$1;" - Push "$0\;" - Call StrStr - Pop $2 - StrCmp $2 "" "" AddToPath_done - GetFullPathName /SHORT $3 $0 - Push "$1;" - Push "$3;" - Call StrStr - Pop $2 - StrCmp $2 "" "" AddToPath_done - Push "$1;" - Push "$3\;" - Call StrStr - Pop $2 - StrCmp $2 "" "" AddToPath_done - - ReadRegStr $1 ${WriteEnvStr_RegKey} "PATH" - StrCpy $2 $1 1 -1 # copy last char - StrCmp $2 ";" 0 +2 # if last char == ; - StrCpy $1 $1 -1 # remove last char - StrCmp $1 "" AddToPath_NTdoIt - StrCpy $0 "$1;$0" - AddToPath_NTdoIt: - WriteRegExpandStr ${WriteEnvStr_RegKey} "PATH" $0 - SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000 - - AddToPath_done: - Pop $3 - Pop $2 - Pop $1 - Pop $0 -FunctionEnd - -; RemoveFromPath - Remove a given dir from the path -; Input: head of the stack - -Function un.RemoveFromPath - Exch $0 - Push $1 - Push $2 - Push $3 - Push $4 - Push $5 - Push $6 - - IntFmt $6 "%c" 26 # DOS EOF - - ReadRegStr $1 ${WriteEnvStr_RegKey} "PATH" - StrCpy $5 $1 1 -1 # copy last char - StrCmp $5 ";" +2 # if last char != ; - StrCpy $1 "$1;" # append ; - Push $1 - Push "$0;" - Call un.StrStr ; Find `$0;` in $1 - Pop $2 ; pos of our dir - StrCmp $2 "" unRemoveFromPath_done - ; else, it is in path - # $0 - path to add - # $1 - path var - StrLen $3 "$0;" - StrLen $4 $2 - StrCpy $5 $1 -$4 # $5 is now the part before the path to remove - StrCpy $6 $2 "" $3 # $6 is now the part after the path to remove - StrCpy $3 $5$6 - - StrCpy $5 $3 1 -1 # copy last char - StrCmp $5 ";" 0 +2 # if last char == ; - StrCpy $3 $3 -1 # remove last char - - WriteRegExpandStr ${WriteEnvStr_RegKey} "PATH" $3 - SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000 - - unRemoveFromPath_done: - Pop $6 - Pop $5 - Pop $4 - Pop $3 - Pop $2 - Pop $1 - Pop $0 -FunctionEnd - -########################################### -# Utility Functions # -########################################### - -; IsNT -; no input -; output, top of the stack = 1 if NT or 0 if not -; -; Usage: -; Call IsNT -; Pop $R0 -; ($R0 at this point is 1 or 0) - -!macro IsNT un -Function ${un}IsNT - Push $0 - ReadRegStr $0 HKLM "SOFTWARE\Microsoft\Windows NT\CurrentVersion" CurrentVersion - StrCmp $0 "" 0 IsNT_yes - ; we are not NT. - Pop $0 - Push 0 - Return - - IsNT_yes: - ; NT!!! - Pop $0 - Push 1 -FunctionEnd -!macroend -!insertmacro IsNT "" -;!insertmacro IsNT "un." - -; StrStr -; input, top of stack = string to search for -; top of stack-1 = string to search in -; output, top of stack (replaces with the portion of the string remaining) -; modifies no other variables. -; -; Usage: -; Push "this is a long ass string" -; Push "ass" -; Call StrStr -; Pop $R0 -; ($R0 at this point is "ass string") - -!macro StrStr un -Function ${un}StrStr -Exch $R1 ; st=haystack,old$R1, $R1=needle - Exch ; st=old$R1,haystack - Exch $R2 ; st=old$R1,old$R2, $R2=haystack - Push $R3 - Push $R4 - Push $R5 - StrLen $R3 $R1 - StrCpy $R4 0 - ; $R1=needle - ; $R2=haystack - ; $R3=len(needle) - ; $R4=cnt - ; $R5=tmp - loop: - StrCpy $R5 $R2 $R3 $R4 - StrCmp $R5 $R1 done - StrCmp $R5 "" done - IntOp $R4 $R4 + 1 - Goto loop -done: - StrCpy $R1 $R2 "" $R4 - Pop $R5 - Pop $R4 - Pop $R3 - Pop $R2 - Exch $R1 -FunctionEnd -!macroend -!insertmacro StrStr "" -!insertmacro StrStr "un." - diff --git a/src/translate/mcode/windows/ghdlfilter.adb b/src/translate/mcode/windows/ghdlfilter.adb deleted file mode 100644 index d37c2db23..000000000 --- a/src/translate/mcode/windows/ghdlfilter.adb +++ /dev/null @@ -1,58 +0,0 @@ -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Text_IO; use Ada.Text_IO; - -procedure Ghdlfilter is - type Mode_Kind is (Mode_93, Mode_87); - Mode : Mode_Kind; - - Line : String (1 .. 128); - Len : Natural; - - Comment : Boolean; - Block_Comment : Boolean; -begin - if Argument_Count /= 1 then - Put_Line (Standard_Error, "usage: " & Command_Name & " -v93|-v87"); - return; - end if; - - if Argument (1) = "-v93" then - Mode := Mode_93; - elsif Argument (1) = "-v87" then - Mode := Mode_87; - else - Put_Line (Standard_Error, "bad mode"); - return; - end if; - - Block_Comment := False; - - loop - exit when End_Of_File; - Get_Line (Line, Len); - - Comment := Block_Comment; - - if Len > 5 then - if Mode = Mode_87 and Line (Len - 4 .. Len) = "--V93" then - Comment := True; - elsif Mode = Mode_93 and Line (Len - 4 .. Len) = "--V87" then - Comment := True; - end if; - end if; - if Len = 11 - and then Mode = Mode_87 - and then Line (1 .. 11) = "--START-V93" then - Block_Comment := True; - end if; - - if Len = 9 and then Line (1 .. 9) = "--END-V93" then - Block_Comment := False; - end if; - - if Comment then - Put ("-- "); - end if; - Put_Line (Line (1 .. Len)); - end loop; -end Ghdlfilter; diff --git a/src/translate/mcode/windows/ghdlversion.adb b/src/translate/mcode/windows/ghdlversion.adb deleted file mode 100755 index d2f1c28be..000000000 --- a/src/translate/mcode/windows/ghdlversion.adb +++ /dev/null @@ -1,30 +0,0 @@ -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Strings.Fixed; use Ada.Strings.Fixed; - -procedure Ghdlversion is - Line : String (1 .. 128); - Len : Natural; - Pos : Natural; - E : Natural; -begin - loop - exit when End_Of_File; - Get_Line (Line, Len); - - -- Search GHDL - Pos := Index (Line (1 .. Len), "GHDL "); - if Pos /= 0 then - Pos := Pos + 5; - E := Pos; - while Line (E) in '0' .. '9' - or Line (E) in 'a' .. 'z' - or Line (E) = '.' - loop - exit when E = Len; - E := E + 1; - end loop; - Put_Line ("!define VERSION """ & Line (Pos .. E - 1) & """"); - return; - end if; - end loop; -end Ghdlversion; diff --git a/src/translate/mcode/windows/grt-modules.adb b/src/translate/mcode/windows/grt-modules.adb deleted file mode 100644 index 35b27c345..000000000 --- a/src/translate/mcode/windows/grt-modules.adb +++ /dev/null @@ -1,37 +0,0 @@ --- GHDL Run Time (GRT) - Modules. --- Copyright (C) 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with System.Storage_Elements; -- Work around GNAT bug. -with Grt.Vcd; -with Grt.Vpi; -with Grt.Waves; -with Grt.Vital_Annotate; -with Grt.Disp_Tree; -with Grt.Disp_Rti; - -package body Grt.Modules is - procedure Register_Modules is - begin - -- List of modules to be registered. - Grt.Disp_Tree.Register; - Grt.Vcd.Register; - Grt.Waves.Register; - Grt.Vpi.Register; - Grt.Vital_Annotate.Register; - Grt.Disp_Rti.Register; - end Register_Modules; -end Grt.Modules; diff --git a/src/translate/mcode/windows/ortho_code-x86-flags.ads b/src/translate/mcode/windows/ortho_code-x86-flags.ads deleted file mode 100644 index 8915f3122..000000000 --- a/src/translate/mcode/windows/ortho_code-x86-flags.ads +++ /dev/null @@ -1,2 +0,0 @@ -with Ortho_Code.X86.Flags_Windows; -package Ortho_Code.X86.Flags renames Ortho_Code.X86.Flags_Windows; diff --git a/src/translate/mcode/windows/windows_default_path.adb b/src/translate/mcode/windows/windows_default_path.adb deleted file mode 100644 index 23aa2f6e0..000000000 --- a/src/translate/mcode/windows/windows_default_path.adb +++ /dev/null @@ -1,45 +0,0 @@ -with Interfaces.C; use Interfaces.C; -with System; use System; - -package body Windows_Default_Path is - - subtype DWORD is Interfaces.C.Unsigned_Long; - subtype LPWSTR is String; - subtype HINSTANCE is Address; - function GetModuleFileName (Inst : HINSTANCE; Buf : Address; Size : DWORD) - return DWORD; - pragma Import (Stdcall, GetModuleFileName, "GetModuleFileNameA"); - - function Get_Windows_Exec_Path return String - is - File : String (1 .. 256); - Size : DWORD; - P : Natural; - begin - -- Get exe file path. - Size := GetModuleFileName (Null_Address, File'Address, File'Length); - if Size = 0 or Size = File'Length then - return "{cannot find install path}\lib"; - end if; - - -- Remove Program file. - P := Natural (Size); - while P > 0 loop - exit when File (P) = '\'; - exit when File (P) = ':' and P = 2; - P := P - 1; - end loop; - if File (P) = '\' and P > 1 then - -- Remove directory - P := P - 1; - while P > 0 loop - exit when File (P) = '\'; - exit when File (P) = ':' and P = 2; - P := P - 1; - end loop; - end if; - - return File (1 .. P); - end Get_Windows_Exec_Path; -end Windows_Default_Path; - diff --git a/src/translate/mcode/windows/windows_default_path.ads b/src/translate/mcode/windows/windows_default_path.ads deleted file mode 100644 index 8e6303446..000000000 --- a/src/translate/mcode/windows/windows_default_path.ads +++ /dev/null @@ -1,5 +0,0 @@ -package Windows_Default_Path is - -- Get the default path from executable name. - -- This function is called during elaboration! - function Get_Windows_Exec_Path return String; -end Windows_Default_Path; -- cgit v1.2.3