From 9c195bf5d86d67ea5eb419ccf6e48dc153e57c68 Mon Sep 17 00:00:00 2001
From: Tristan Gingold
Date: Tue, 4 Nov 2014 20:14:19 +0100
Subject: Move sources to src/ subdirectory.
---
src/back_end.adb | 38 +
src/back_end.ads | 57 +
src/bug.adb | 104 +
src/bug.ads | 26 +
src/canon.adb | 2735 ++
src/canon.ads | 70 +
src/canon_psl.adb | 43 +
src/canon_psl.ads | 26 +
src/configuration.adb | 614 +
src/configuration.ads | 55 +
src/disp_tree.adb | 511 +
src/disp_tree.ads | 27 +
src/disp_vhdl.adb | 3247 ++
src/disp_vhdl.ads | 38 +
src/errorout.adb | 1113 +
src/errorout.ads | 128 +
src/evaluation.adb | 3047 ++
src/evaluation.ads | 161 +
src/files_map.adb | 857 +
src/files_map.ads | 152 +
src/flags.adb | 53 +
src/flags.ads | 190 +
src/ieee-std_logic_1164.adb | 170 +
src/ieee-std_logic_1164.ads | 35 +
src/ieee-vital_timing.adb | 1377 +
src/ieee-vital_timing.ads | 41 +
src/ieee.ads | 5 +
src/iir_chain_handling.adb | 68 +
src/iir_chain_handling.ads | 47 +
src/iir_chains.adb | 64 +
src/iir_chains.ads | 113 +
src/iirs.adb | 4515 +++
src/iirs.adb.in | 229 +
src/iirs.ads | 6445 ++++
src/iirs_utils.adb | 1131 +
src/iirs_utils.ads | 250 +
src/iirs_walk.adb | 115 +
src/iirs_walk.ads | 45 +
src/libraries.adb | 1714 +
src/libraries.ads | 188 +
src/lists.adb | 257 +
src/lists.ads | 123 +
src/name_table.adb | 359 +
src/name_table.ads | 98 +
src/nodes.adb | 467 +
src/nodes.ads | 335 +
src/nodes_gc.adb | 206 +
src/nodes_gc.adb.in | 159 +
src/nodes_gc.ads | 24 +
src/nodes_meta.adb | 9409 ++++++
src/nodes_meta.adb.in | 76 +
src/nodes_meta.ads | 823 +
src/nodes_meta.ads.in | 66 +
src/options.adb | 242 +
src/options.ads | 30 +
src/ortho/Makefile.inc | 38 +
src/ortho/debug/Makefile | 47 +
src/ortho/debug/ortho_debug-disp.adb | 1064 +
src/ortho/debug/ortho_debug-disp.ads | 29 +
src/ortho/debug/ortho_debug-main.adb | 151 +
src/ortho/debug/ortho_debug.adb | 1931 ++
src/ortho/debug/ortho_debug.private.ads | 467 +
src/ortho/debug/ortho_debug_front.ads | 20 +
src/ortho/debug/ortho_ident.ads | 20 +
src/ortho/debug/ortho_ident_hash.adb | 72 +
src/ortho/debug/ortho_ident_hash.ads | 46 +
src/ortho/debug/ortho_ident_simple.adb | 44 +
src/ortho/debug/ortho_ident_simple.ads | 31 +
src/ortho/debug/ortho_nodes.ads | 21 +
src/ortho/gcc/Makefile | 86 +
src/ortho/gcc/Makefile.conf.linux | 4 +
src/ortho/gcc/lang.opt | 96 +
src/ortho/gcc/ortho-lang.c | 2191 ++
src/ortho/gcc/ortho_gcc-main.adb | 42 +
src/ortho/gcc/ortho_gcc-main.ads | 1 +
src/ortho/gcc/ortho_gcc.adb | 121 +
src/ortho/gcc/ortho_gcc.ads | 701 +
src/ortho/gcc/ortho_gcc.private.ads | 269 +
src/ortho/gcc/ortho_gcc_front.ads | 2 +
src/ortho/gcc/ortho_ident.adb | 56 +
src/ortho/gcc/ortho_ident.ads | 30 +
src/ortho/gcc/ortho_nodes.ads | 3 +
src/ortho/llvm/Makefile | 30 +
src/ortho/llvm/llvm-analysis.ads | 53 +
src/ortho/llvm/llvm-bitwriter.ads | 34 +
src/ortho/llvm/llvm-cbindings.cpp | 61 +
src/ortho/llvm/llvm-core.ads | 1279 +
src/ortho/llvm/llvm-executionengine.ads | 163 +
src/ortho/llvm/llvm-target.ads | 84 +
src/ortho/llvm/llvm-targetmachine.ads | 122 +
src/ortho/llvm/llvm-transforms-scalar.ads | 169 +
src/ortho/llvm/llvm-transforms.ads | 21 +
src/ortho/llvm/llvm.ads | 21 +
src/ortho/llvm/ortho_code_main.adb | 391 +
src/ortho/llvm/ortho_ident.adb | 134 +
src/ortho/llvm/ortho_ident.ads | 42 +
src/ortho/llvm/ortho_jit.adb | 151 +
src/ortho/llvm/ortho_llvm-jit.adb | 55 +
src/ortho/llvm/ortho_llvm-jit.ads | 31 +
src/ortho/llvm/ortho_llvm.adb | 2881 ++
src/ortho/llvm/ortho_llvm.ads | 737 +
src/ortho/llvm/ortho_llvm.private.ads | 305 +
src/ortho/llvm/ortho_nodes.ads | 20 +
src/ortho/mcode/Makefile | 37 +
src/ortho/mcode/binary_file-coff.adb | 407 +
src/ortho/mcode/binary_file-coff.ads | 23 +
src/ortho/mcode/binary_file-elf.adb | 679 +
src/ortho/mcode/binary_file-elf.ads | 22 +
src/ortho/mcode/binary_file-memory.adb | 101 +
src/ortho/mcode/binary_file-memory.ads | 25 +
src/ortho/mcode/binary_file.adb | 977 +
src/ortho/mcode/binary_file.ads | 305 +
src/ortho/mcode/coff.ads | 208 +
src/ortho/mcode/coffdump.adb | 274 +
src/ortho/mcode/disa_sparc.adb | 274 +
src/ortho/mcode/disa_sparc.ads | 15 +
src/ortho/mcode/disa_x86.adb | 997 +
src/ortho/mcode/disa_x86.ads | 34 +
src/ortho/mcode/disassemble.ads | 3 +
src/ortho/mcode/dwarf.ads | 446 +
src/ortho/mcode/elf32.adb | 48 +
src/ortho/mcode/elf32.ads | 124 +
src/ortho/mcode/elf64.ads | 105 +
src/ortho/mcode/elf_arch.ads | 2 +
src/ortho/mcode/elf_arch32.ads | 37 +
src/ortho/mcode/elf_arch64.ads | 37 +
src/ortho/mcode/elf_common.adb | 48 +
src/ortho/mcode/elf_common.ads | 250 +
src/ortho/mcode/elfdump.adb | 267 +
src/ortho/mcode/elfdumper.adb | 2818 ++
src/ortho/mcode/elfdumper.ads | 164 +
src/ortho/mcode/hex_images.adb | 71 +
src/ortho/mcode/hex_images.ads | 26 +
src/ortho/mcode/memsegs.ads | 3 +
src/ortho/mcode/memsegs_c.c | 133 +
src/ortho/mcode/memsegs_mmap.adb | 64 +
src/ortho/mcode/memsegs_mmap.ads | 49 +
src/ortho/mcode/ortho_code-abi.ads | 3 +
src/ortho/mcode/ortho_code-binary.adb | 37 +
src/ortho/mcode/ortho_code-binary.ads | 31 +
src/ortho/mcode/ortho_code-consts.adb | 559 +
src/ortho/mcode/ortho_code-consts.ads | 158 +
src/ortho/mcode/ortho_code-debug.adb | 143 +
src/ortho/mcode/ortho_code-debug.ads | 70 +
src/ortho/mcode/ortho_code-decls.adb | 783 +
src/ortho/mcode/ortho_code-decls.ads | 209 +
src/ortho/mcode/ortho_code-disps.adb | 790 +
src/ortho/mcode/ortho_code-disps.ads | 25 +
src/ortho/mcode/ortho_code-dwarf.adb | 1351 +
src/ortho/mcode/ortho_code-dwarf.ads | 41 +
src/ortho/mcode/ortho_code-exprs.adb | 1663 +
src/ortho/mcode/ortho_code-exprs.ads | 600 +
src/ortho/mcode/ortho_code-flags.ads | 35 +
src/ortho/mcode/ortho_code-opts.adb | 214 +
src/ortho/mcode/ortho_code-opts.ads | 22 +
src/ortho/mcode/ortho_code-types.adb | 820 +
src/ortho/mcode/ortho_code-types.ads | 240 +
src/ortho/mcode/ortho_code-x86-abi.adb | 762 +
src/ortho/mcode/ortho_code-x86-abi.ads | 76 +
src/ortho/mcode/ortho_code-x86-emits.adb | 2322 ++
src/ortho/mcode/ortho_code-x86-emits.ads | 36 +
src/ortho/mcode/ortho_code-x86-flags_linux.ads | 31 +
src/ortho/mcode/ortho_code-x86-flags_macosx.ads | 31 +
src/ortho/mcode/ortho_code-x86-flags_windows.ads | 31 +
src/ortho/mcode/ortho_code-x86-insns.adb | 2068 ++
src/ortho/mcode/ortho_code-x86-insns.ads | 25 +
src/ortho/mcode/ortho_code-x86.adb | 109 +
src/ortho/mcode/ortho_code-x86.ads | 160 +
src/ortho/mcode/ortho_code.ads | 150 +
src/ortho/mcode/ortho_code_main.adb | 198 +
src/ortho/mcode/ortho_ident.adb | 117 +
src/ortho/mcode/ortho_ident.ads | 38 +
src/ortho/mcode/ortho_jit.adb | 125 +
src/ortho/mcode/ortho_mcode-jit.adb | 28 +
src/ortho/mcode/ortho_mcode-jit.ads | 9 +
src/ortho/mcode/ortho_mcode.adb | 738 +
src/ortho/mcode/ortho_mcode.ads | 583 +
src/ortho/mcode/ortho_mcode.private.ads | 151 +
src/ortho/mcode/ortho_nodes.ads | 2 +
src/ortho/oread/Makefile | 43 +
src/ortho/oread/ortho_front.adb | 2677 ++
src/ortho/ortho_front.ads | 41 +
src/ortho/ortho_jit.ads | 43 +
src/ortho/ortho_nodes.common.ads | 453 +
src/parse.adb | 7143 +++++
src/parse.ads | 44 +
src/parse_psl.adb | 667 +
src/parse_psl.ads | 26 +
src/post_sems.adb | 71 +
src/post_sems.ads | 25 +
src/psl-errors.ads | 3 +
src/psl/psl-build.adb | 1009 +
src/psl/psl-build.ads | 7 +
src/psl/psl-cse.adb | 201 +
src/psl/psl-cse.ads | 10 +
src/psl/psl-disp_nfas.adb | 111 +
src/psl/psl-disp_nfas.ads | 12 +
src/psl/psl-dump_tree.adb | 867 +
src/psl/psl-dump_tree.ads | 9 +
src/psl/psl-hash.adb | 60 +
src/psl/psl-hash.ads | 11 +
src/psl/psl-nfas-utils.adb | 330 +
src/psl/psl-nfas-utils.ads | 21 +
src/psl/psl-nfas.adb | 529 +
src/psl/psl-nfas.ads | 108 +
src/psl/psl-nodes.adb | 1231 +
src/psl/psl-nodes.ads | 563 +
src/psl/psl-optimize.adb | 460 +
src/psl/psl-optimize.ads | 24 +
src/psl/psl-prints.adb | 433 +
src/psl/psl-prints.ads | 20 +
src/psl/psl-priorities.ads | 63 +
src/psl/psl-qm.adb | 318 +
src/psl/psl-qm.ads | 49 +
src/psl/psl-rewrites.adb | 604 +
src/psl/psl-rewrites.ads | 7 +
src/psl/psl-subsets.adb | 177 +
src/psl/psl-subsets.ads | 23 +
src/psl/psl-tprint.adb | 255 +
src/psl/psl-tprint.ads | 6 +
src/psl/psl.ads | 3 +
src/scanner-scan_literal.adb | 651 +
src/scanner.adb | 1621 +
src/scanner.ads | 120 +
src/sem.adb | 2749 ++
src/sem.ads | 82 +
src/sem_assocs.adb | 1903 ++
src/sem_assocs.ads | 60 +
src/sem_decls.adb | 3018 ++
src/sem_decls.ads | 52 +
src/sem_expr.adb | 4262 +++
src/sem_expr.ads | 178 +
src/sem_inst.adb | 639 +
src/sem_inst.ads | 26 +
src/sem_names.adb | 3788 +++
src/sem_names.ads | 159 +
src/sem_psl.adb | 617 +
src/sem_psl.ads | 26 +
src/sem_scopes.adb | 1412 +
src/sem_scopes.ads | 217 +
src/sem_specs.adb | 1731 +
src/sem_specs.ads | 88 +
src/sem_stmts.adb | 2007 ++
src/sem_stmts.ads | 87 +
src/sem_types.adb | 2210 ++
src/sem_types.ads | 57 +
src/simulate/annotations.adb | 1236 +
src/simulate/annotations.ads | 120 +
src/simulate/areapools.adb | 147 +
src/simulate/areapools.ads | 87 +
src/simulate/debugger.adb | 1845 ++
src/simulate/debugger.ads | 90 +
src/simulate/elaboration.adb | 2582 ++
src/simulate/elaboration.ads | 209 +
src/simulate/execution.adb | 4837 +++
src/simulate/execution.ads | 185 +
src/simulate/file_operation.adb | 341 +
src/simulate/file_operation.ads | 81 +
src/simulate/grt_interface.adb | 44 +
src/simulate/grt_interface.ads | 27 +
src/simulate/iir_values.adb | 1066 +
src/simulate/iir_values.ads | 355 +
src/simulate/sim_be.adb | 117 +
src/simulate/sim_be.ads | 25 +
src/simulate/simulation-ams-debugger.adb | 87 +
src/simulate/simulation-ams-debugger.ads | 27 +
src/simulate/simulation-ams.adb | 201 +
src/simulate/simulation-ams.ads | 165 +
src/simulate/simulation.adb | 1669 +
src/simulate/simulation.ads | 128 +
src/std_names.adb | 482 +
src/std_names.ads | 727 +
src/std_package.adb | 1200 +
src/std_package.ads | 182 +
src/str_table.adb | 92 +
src/str_table.ads | 44 +
src/tokens.adb | 443 +
src/tokens.ads | 279 +
src/translate/Makefile | 45 +
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 +
src/translate/ortho_front.adb | 445 +
src/translate/trans_analyzes.adb | 182 +
src/translate/trans_analyzes.ads | 31 +
src/translate/trans_be.adb | 182 +
src/translate/trans_be.ads | 21 +
src/translate/trans_decls.ads | 257 +
src/translate/translation.adb | 31355 +++++++++++++++++++
src/translate/translation.ads | 120 +
src/types.ads | 127 +
src/version.ads | 5 +
src/xrefs.adb | 279 +
src/xrefs.ads | 108 +
src/xtools/Makefile | 35 +
src/xtools/pnodes.py | 716 +
451 files changed, 222443 insertions(+)
create mode 100644 src/back_end.adb
create mode 100644 src/back_end.ads
create mode 100644 src/bug.adb
create mode 100644 src/bug.ads
create mode 100644 src/canon.adb
create mode 100644 src/canon.ads
create mode 100644 src/canon_psl.adb
create mode 100644 src/canon_psl.ads
create mode 100644 src/configuration.adb
create mode 100644 src/configuration.ads
create mode 100644 src/disp_tree.adb
create mode 100644 src/disp_tree.ads
create mode 100644 src/disp_vhdl.adb
create mode 100644 src/disp_vhdl.ads
create mode 100644 src/errorout.adb
create mode 100644 src/errorout.ads
create mode 100644 src/evaluation.adb
create mode 100644 src/evaluation.ads
create mode 100644 src/files_map.adb
create mode 100644 src/files_map.ads
create mode 100644 src/flags.adb
create mode 100644 src/flags.ads
create mode 100644 src/ieee-std_logic_1164.adb
create mode 100644 src/ieee-std_logic_1164.ads
create mode 100644 src/ieee-vital_timing.adb
create mode 100644 src/ieee-vital_timing.ads
create mode 100644 src/ieee.ads
create mode 100644 src/iir_chain_handling.adb
create mode 100644 src/iir_chain_handling.ads
create mode 100644 src/iir_chains.adb
create mode 100644 src/iir_chains.ads
create mode 100644 src/iirs.adb
create mode 100644 src/iirs.adb.in
create mode 100644 src/iirs.ads
create mode 100644 src/iirs_utils.adb
create mode 100644 src/iirs_utils.ads
create mode 100644 src/iirs_walk.adb
create mode 100644 src/iirs_walk.ads
create mode 100644 src/libraries.adb
create mode 100644 src/libraries.ads
create mode 100644 src/lists.adb
create mode 100644 src/lists.ads
create mode 100644 src/name_table.adb
create mode 100644 src/name_table.ads
create mode 100644 src/nodes.adb
create mode 100644 src/nodes.ads
create mode 100644 src/nodes_gc.adb
create mode 100644 src/nodes_gc.adb.in
create mode 100644 src/nodes_gc.ads
create mode 100644 src/nodes_meta.adb
create mode 100644 src/nodes_meta.adb.in
create mode 100644 src/nodes_meta.ads
create mode 100644 src/nodes_meta.ads.in
create mode 100644 src/options.adb
create mode 100644 src/options.ads
create mode 100644 src/ortho/Makefile.inc
create mode 100644 src/ortho/debug/Makefile
create mode 100644 src/ortho/debug/ortho_debug-disp.adb
create mode 100644 src/ortho/debug/ortho_debug-disp.ads
create mode 100644 src/ortho/debug/ortho_debug-main.adb
create mode 100644 src/ortho/debug/ortho_debug.adb
create mode 100644 src/ortho/debug/ortho_debug.private.ads
create mode 100644 src/ortho/debug/ortho_debug_front.ads
create mode 100644 src/ortho/debug/ortho_ident.ads
create mode 100644 src/ortho/debug/ortho_ident_hash.adb
create mode 100644 src/ortho/debug/ortho_ident_hash.ads
create mode 100644 src/ortho/debug/ortho_ident_simple.adb
create mode 100644 src/ortho/debug/ortho_ident_simple.ads
create mode 100644 src/ortho/debug/ortho_nodes.ads
create mode 100644 src/ortho/gcc/Makefile
create mode 100644 src/ortho/gcc/Makefile.conf.linux
create mode 100644 src/ortho/gcc/lang.opt
create mode 100644 src/ortho/gcc/ortho-lang.c
create mode 100644 src/ortho/gcc/ortho_gcc-main.adb
create mode 100644 src/ortho/gcc/ortho_gcc-main.ads
create mode 100644 src/ortho/gcc/ortho_gcc.adb
create mode 100644 src/ortho/gcc/ortho_gcc.ads
create mode 100644 src/ortho/gcc/ortho_gcc.private.ads
create mode 100644 src/ortho/gcc/ortho_gcc_front.ads
create mode 100644 src/ortho/gcc/ortho_ident.adb
create mode 100644 src/ortho/gcc/ortho_ident.ads
create mode 100644 src/ortho/gcc/ortho_nodes.ads
create mode 100644 src/ortho/llvm/Makefile
create mode 100644 src/ortho/llvm/llvm-analysis.ads
create mode 100644 src/ortho/llvm/llvm-bitwriter.ads
create mode 100644 src/ortho/llvm/llvm-cbindings.cpp
create mode 100644 src/ortho/llvm/llvm-core.ads
create mode 100644 src/ortho/llvm/llvm-executionengine.ads
create mode 100644 src/ortho/llvm/llvm-target.ads
create mode 100644 src/ortho/llvm/llvm-targetmachine.ads
create mode 100644 src/ortho/llvm/llvm-transforms-scalar.ads
create mode 100644 src/ortho/llvm/llvm-transforms.ads
create mode 100644 src/ortho/llvm/llvm.ads
create mode 100644 src/ortho/llvm/ortho_code_main.adb
create mode 100644 src/ortho/llvm/ortho_ident.adb
create mode 100644 src/ortho/llvm/ortho_ident.ads
create mode 100644 src/ortho/llvm/ortho_jit.adb
create mode 100644 src/ortho/llvm/ortho_llvm-jit.adb
create mode 100644 src/ortho/llvm/ortho_llvm-jit.ads
create mode 100644 src/ortho/llvm/ortho_llvm.adb
create mode 100644 src/ortho/llvm/ortho_llvm.ads
create mode 100644 src/ortho/llvm/ortho_llvm.private.ads
create mode 100644 src/ortho/llvm/ortho_nodes.ads
create mode 100644 src/ortho/mcode/Makefile
create mode 100644 src/ortho/mcode/binary_file-coff.adb
create mode 100644 src/ortho/mcode/binary_file-coff.ads
create mode 100644 src/ortho/mcode/binary_file-elf.adb
create mode 100644 src/ortho/mcode/binary_file-elf.ads
create mode 100644 src/ortho/mcode/binary_file-memory.adb
create mode 100644 src/ortho/mcode/binary_file-memory.ads
create mode 100644 src/ortho/mcode/binary_file.adb
create mode 100644 src/ortho/mcode/binary_file.ads
create mode 100644 src/ortho/mcode/coff.ads
create mode 100644 src/ortho/mcode/coffdump.adb
create mode 100644 src/ortho/mcode/disa_sparc.adb
create mode 100644 src/ortho/mcode/disa_sparc.ads
create mode 100644 src/ortho/mcode/disa_x86.adb
create mode 100644 src/ortho/mcode/disa_x86.ads
create mode 100644 src/ortho/mcode/disassemble.ads
create mode 100644 src/ortho/mcode/dwarf.ads
create mode 100644 src/ortho/mcode/elf32.adb
create mode 100644 src/ortho/mcode/elf32.ads
create mode 100644 src/ortho/mcode/elf64.ads
create mode 100644 src/ortho/mcode/elf_arch.ads
create mode 100644 src/ortho/mcode/elf_arch32.ads
create mode 100644 src/ortho/mcode/elf_arch64.ads
create mode 100644 src/ortho/mcode/elf_common.adb
create mode 100644 src/ortho/mcode/elf_common.ads
create mode 100644 src/ortho/mcode/elfdump.adb
create mode 100644 src/ortho/mcode/elfdumper.adb
create mode 100644 src/ortho/mcode/elfdumper.ads
create mode 100644 src/ortho/mcode/hex_images.adb
create mode 100644 src/ortho/mcode/hex_images.ads
create mode 100644 src/ortho/mcode/memsegs.ads
create mode 100644 src/ortho/mcode/memsegs_c.c
create mode 100644 src/ortho/mcode/memsegs_mmap.adb
create mode 100644 src/ortho/mcode/memsegs_mmap.ads
create mode 100644 src/ortho/mcode/ortho_code-abi.ads
create mode 100644 src/ortho/mcode/ortho_code-binary.adb
create mode 100644 src/ortho/mcode/ortho_code-binary.ads
create mode 100644 src/ortho/mcode/ortho_code-consts.adb
create mode 100644 src/ortho/mcode/ortho_code-consts.ads
create mode 100644 src/ortho/mcode/ortho_code-debug.adb
create mode 100644 src/ortho/mcode/ortho_code-debug.ads
create mode 100644 src/ortho/mcode/ortho_code-decls.adb
create mode 100644 src/ortho/mcode/ortho_code-decls.ads
create mode 100644 src/ortho/mcode/ortho_code-disps.adb
create mode 100644 src/ortho/mcode/ortho_code-disps.ads
create mode 100644 src/ortho/mcode/ortho_code-dwarf.adb
create mode 100644 src/ortho/mcode/ortho_code-dwarf.ads
create mode 100644 src/ortho/mcode/ortho_code-exprs.adb
create mode 100644 src/ortho/mcode/ortho_code-exprs.ads
create mode 100644 src/ortho/mcode/ortho_code-flags.ads
create mode 100644 src/ortho/mcode/ortho_code-opts.adb
create mode 100644 src/ortho/mcode/ortho_code-opts.ads
create mode 100644 src/ortho/mcode/ortho_code-types.adb
create mode 100644 src/ortho/mcode/ortho_code-types.ads
create mode 100644 src/ortho/mcode/ortho_code-x86-abi.adb
create mode 100644 src/ortho/mcode/ortho_code-x86-abi.ads
create mode 100644 src/ortho/mcode/ortho_code-x86-emits.adb
create mode 100644 src/ortho/mcode/ortho_code-x86-emits.ads
create mode 100644 src/ortho/mcode/ortho_code-x86-flags_linux.ads
create mode 100644 src/ortho/mcode/ortho_code-x86-flags_macosx.ads
create mode 100644 src/ortho/mcode/ortho_code-x86-flags_windows.ads
create mode 100644 src/ortho/mcode/ortho_code-x86-insns.adb
create mode 100644 src/ortho/mcode/ortho_code-x86-insns.ads
create mode 100644 src/ortho/mcode/ortho_code-x86.adb
create mode 100644 src/ortho/mcode/ortho_code-x86.ads
create mode 100644 src/ortho/mcode/ortho_code.ads
create mode 100644 src/ortho/mcode/ortho_code_main.adb
create mode 100644 src/ortho/mcode/ortho_ident.adb
create mode 100644 src/ortho/mcode/ortho_ident.ads
create mode 100644 src/ortho/mcode/ortho_jit.adb
create mode 100644 src/ortho/mcode/ortho_mcode-jit.adb
create mode 100644 src/ortho/mcode/ortho_mcode-jit.ads
create mode 100644 src/ortho/mcode/ortho_mcode.adb
create mode 100644 src/ortho/mcode/ortho_mcode.ads
create mode 100644 src/ortho/mcode/ortho_mcode.private.ads
create mode 100644 src/ortho/mcode/ortho_nodes.ads
create mode 100644 src/ortho/oread/Makefile
create mode 100644 src/ortho/oread/ortho_front.adb
create mode 100644 src/ortho/ortho_front.ads
create mode 100644 src/ortho/ortho_jit.ads
create mode 100644 src/ortho/ortho_nodes.common.ads
create mode 100644 src/parse.adb
create mode 100644 src/parse.ads
create mode 100644 src/parse_psl.adb
create mode 100644 src/parse_psl.ads
create mode 100644 src/post_sems.adb
create mode 100644 src/post_sems.ads
create mode 100644 src/psl-errors.ads
create mode 100644 src/psl/psl-build.adb
create mode 100644 src/psl/psl-build.ads
create mode 100644 src/psl/psl-cse.adb
create mode 100644 src/psl/psl-cse.ads
create mode 100644 src/psl/psl-disp_nfas.adb
create mode 100644 src/psl/psl-disp_nfas.ads
create mode 100644 src/psl/psl-dump_tree.adb
create mode 100644 src/psl/psl-dump_tree.ads
create mode 100644 src/psl/psl-hash.adb
create mode 100644 src/psl/psl-hash.ads
create mode 100644 src/psl/psl-nfas-utils.adb
create mode 100644 src/psl/psl-nfas-utils.ads
create mode 100644 src/psl/psl-nfas.adb
create mode 100644 src/psl/psl-nfas.ads
create mode 100644 src/psl/psl-nodes.adb
create mode 100644 src/psl/psl-nodes.ads
create mode 100644 src/psl/psl-optimize.adb
create mode 100644 src/psl/psl-optimize.ads
create mode 100644 src/psl/psl-prints.adb
create mode 100644 src/psl/psl-prints.ads
create mode 100644 src/psl/psl-priorities.ads
create mode 100644 src/psl/psl-qm.adb
create mode 100644 src/psl/psl-qm.ads
create mode 100644 src/psl/psl-rewrites.adb
create mode 100644 src/psl/psl-rewrites.ads
create mode 100644 src/psl/psl-subsets.adb
create mode 100644 src/psl/psl-subsets.ads
create mode 100644 src/psl/psl-tprint.adb
create mode 100644 src/psl/psl-tprint.ads
create mode 100644 src/psl/psl.ads
create mode 100644 src/scanner-scan_literal.adb
create mode 100644 src/scanner.adb
create mode 100644 src/scanner.ads
create mode 100644 src/sem.adb
create mode 100644 src/sem.ads
create mode 100644 src/sem_assocs.adb
create mode 100644 src/sem_assocs.ads
create mode 100644 src/sem_decls.adb
create mode 100644 src/sem_decls.ads
create mode 100644 src/sem_expr.adb
create mode 100644 src/sem_expr.ads
create mode 100644 src/sem_inst.adb
create mode 100644 src/sem_inst.ads
create mode 100644 src/sem_names.adb
create mode 100644 src/sem_names.ads
create mode 100644 src/sem_psl.adb
create mode 100644 src/sem_psl.ads
create mode 100644 src/sem_scopes.adb
create mode 100644 src/sem_scopes.ads
create mode 100644 src/sem_specs.adb
create mode 100644 src/sem_specs.ads
create mode 100644 src/sem_stmts.adb
create mode 100644 src/sem_stmts.ads
create mode 100644 src/sem_types.adb
create mode 100644 src/sem_types.ads
create mode 100644 src/simulate/annotations.adb
create mode 100644 src/simulate/annotations.ads
create mode 100644 src/simulate/areapools.adb
create mode 100644 src/simulate/areapools.ads
create mode 100644 src/simulate/debugger.adb
create mode 100644 src/simulate/debugger.ads
create mode 100644 src/simulate/elaboration.adb
create mode 100644 src/simulate/elaboration.ads
create mode 100644 src/simulate/execution.adb
create mode 100644 src/simulate/execution.ads
create mode 100644 src/simulate/file_operation.adb
create mode 100644 src/simulate/file_operation.ads
create mode 100644 src/simulate/grt_interface.adb
create mode 100644 src/simulate/grt_interface.ads
create mode 100644 src/simulate/iir_values.adb
create mode 100644 src/simulate/iir_values.ads
create mode 100644 src/simulate/sim_be.adb
create mode 100644 src/simulate/sim_be.ads
create mode 100644 src/simulate/simulation-ams-debugger.adb
create mode 100644 src/simulate/simulation-ams-debugger.ads
create mode 100644 src/simulate/simulation-ams.adb
create mode 100644 src/simulate/simulation-ams.ads
create mode 100644 src/simulate/simulation.adb
create mode 100644 src/simulate/simulation.ads
create mode 100644 src/std_names.adb
create mode 100644 src/std_names.ads
create mode 100644 src/std_package.adb
create mode 100644 src/std_package.ads
create mode 100644 src/str_table.adb
create mode 100644 src/str_table.ads
create mode 100644 src/tokens.adb
create mode 100644 src/tokens.ads
create mode 100644 src/translate/Makefile
create mode 100644 src/translate/gcc/ANNOUNCE
create mode 100644 src/translate/gcc/INSTALL
create mode 100644 src/translate/gcc/Make-lang.in
create mode 100644 src/translate/gcc/Makefile.in
create mode 100644 src/translate/gcc/README
create mode 100644 src/translate/gcc/config-lang.in
create mode 100644 src/translate/gcc/dist-common.sh
create mode 100755 src/translate/gcc/dist.sh
create mode 100644 src/translate/gcc/lang-options.h
create mode 100644 src/translate/gcc/lang-specs.h
create mode 100644 src/translate/ghdldrv/Makefile
create mode 100644 src/translate/ghdldrv/default_pathes.ads.in
create mode 100644 src/translate/ghdldrv/foreigns.adb
create mode 100644 src/translate/ghdldrv/foreigns.ads
create mode 100644 src/translate/ghdldrv/ghdl_gcc.adb
create mode 100644 src/translate/ghdldrv/ghdl_jit.adb
create mode 100644 src/translate/ghdldrv/ghdl_simul.adb
create mode 100644 src/translate/ghdldrv/ghdlcomp.adb
create mode 100644 src/translate/ghdldrv/ghdlcomp.ads
create mode 100644 src/translate/ghdldrv/ghdldrv.adb
create mode 100644 src/translate/ghdldrv/ghdldrv.ads
create mode 100644 src/translate/ghdldrv/ghdllocal.adb
create mode 100644 src/translate/ghdldrv/ghdllocal.ads
create mode 100644 src/translate/ghdldrv/ghdlmain.adb
create mode 100644 src/translate/ghdldrv/ghdlmain.ads
create mode 100644 src/translate/ghdldrv/ghdlprint.adb
create mode 100644 src/translate/ghdldrv/ghdlprint.ads
create mode 100644 src/translate/ghdldrv/ghdlrun.adb
create mode 100644 src/translate/ghdldrv/ghdlrun.ads
create mode 100644 src/translate/ghdldrv/ghdlsimul.adb
create mode 100644 src/translate/ghdldrv/ghdlsimul.ads
create mode 100644 src/translate/ghdldrv/grtlink.ads
create mode 100644 src/translate/grt/Makefile
create mode 100644 src/translate/grt/Makefile.inc
create mode 100644 src/translate/grt/config/Makefile
create mode 100644 src/translate/grt/config/amd64.S
create mode 100644 src/translate/grt/config/chkstk.S
create mode 100644 src/translate/grt/config/clock.c
create mode 100644 src/translate/grt/config/i386.S
create mode 100644 src/translate/grt/config/ia64.S
create mode 100644 src/translate/grt/config/linux.c
create mode 100644 src/translate/grt/config/ppc.S
create mode 100644 src/translate/grt/config/pthread.c
create mode 100644 src/translate/grt/config/sparc.S
create mode 100644 src/translate/grt/config/teststack.c
create mode 100644 src/translate/grt/config/times.c
create mode 100644 src/translate/grt/config/win32.c
create mode 100644 src/translate/grt/config/win32thr.c
create mode 100644 src/translate/grt/ghdl_main.adb
create mode 100644 src/translate/grt/ghdl_main.ads
create mode 100644 src/translate/grt/ghwdump.c
create mode 100644 src/translate/grt/ghwlib.c
create mode 100644 src/translate/grt/ghwlib.h
create mode 100644 src/translate/grt/grt-arch.ads
create mode 100644 src/translate/grt/grt-arch_none.adb
create mode 100644 src/translate/grt/grt-arch_none.ads
create mode 100644 src/translate/grt/grt-astdio.adb
create mode 100644 src/translate/grt/grt-astdio.ads
create mode 100644 src/translate/grt/grt-avhpi.adb
create mode 100644 src/translate/grt/grt-avhpi.ads
create mode 100644 src/translate/grt/grt-avls.adb
create mode 100644 src/translate/grt/grt-avls.ads
create mode 100644 src/translate/grt/grt-c.ads
create mode 100644 src/translate/grt/grt-cbinding.c
create mode 100644 src/translate/grt/grt-cvpi.c
create mode 100644 src/translate/grt/grt-disp.adb
create mode 100644 src/translate/grt/grt-disp.ads
create mode 100644 src/translate/grt/grt-disp_rti.adb
create mode 100644 src/translate/grt/grt-disp_rti.ads
create mode 100644 src/translate/grt/grt-disp_signals.adb
create mode 100644 src/translate/grt/grt-disp_signals.ads
create mode 100644 src/translate/grt/grt-disp_tree.adb
create mode 100644 src/translate/grt/grt-disp_tree.ads
create mode 100644 src/translate/grt/grt-errors.adb
create mode 100644 src/translate/grt/grt-errors.ads
create mode 100644 src/translate/grt/grt-files.adb
create mode 100644 src/translate/grt/grt-files.ads
create mode 100644 src/translate/grt/grt-hooks.adb
create mode 100644 src/translate/grt/grt-hooks.ads
create mode 100644 src/translate/grt/grt-images.adb
create mode 100644 src/translate/grt/grt-images.ads
create mode 100644 src/translate/grt/grt-lib.adb
create mode 100644 src/translate/grt/grt-lib.ads
create mode 100644 src/translate/grt/grt-main.adb
create mode 100644 src/translate/grt/grt-main.ads
create mode 100644 src/translate/grt/grt-modules.adb
create mode 100644 src/translate/grt/grt-modules.ads
create mode 100644 src/translate/grt/grt-names.adb
create mode 100644 src/translate/grt/grt-names.ads
create mode 100644 src/translate/grt/grt-options.adb
create mode 100644 src/translate/grt/grt-options.ads
create mode 100644 src/translate/grt/grt-processes.adb
create mode 100644 src/translate/grt/grt-processes.ads
create mode 100644 src/translate/grt/grt-readline.ads
create mode 100644 src/translate/grt/grt-rtis.adb
create mode 100644 src/translate/grt/grt-rtis.ads
create mode 100644 src/translate/grt/grt-rtis_addr.adb
create mode 100644 src/translate/grt/grt-rtis_addr.ads
create mode 100644 src/translate/grt/grt-rtis_binding.ads
create mode 100644 src/translate/grt/grt-rtis_types.adb
create mode 100644 src/translate/grt/grt-rtis_types.ads
create mode 100644 src/translate/grt/grt-rtis_utils.adb
create mode 100644 src/translate/grt/grt-rtis_utils.ads
create mode 100644 src/translate/grt/grt-sdf.adb
create mode 100644 src/translate/grt/grt-sdf.ads
create mode 100644 src/translate/grt/grt-shadow_ieee.adb
create mode 100644 src/translate/grt/grt-shadow_ieee.ads
create mode 100644 src/translate/grt/grt-signals.adb
create mode 100644 src/translate/grt/grt-signals.ads
create mode 100644 src/translate/grt/grt-stack2.adb
create mode 100644 src/translate/grt/grt-stack2.ads
create mode 100644 src/translate/grt/grt-stacks.adb
create mode 100644 src/translate/grt/grt-stacks.ads
create mode 100644 src/translate/grt/grt-stats.adb
create mode 100644 src/translate/grt/grt-stats.ads
create mode 100644 src/translate/grt/grt-std_logic_1164.adb
create mode 100644 src/translate/grt/grt-std_logic_1164.ads
create mode 100644 src/translate/grt/grt-stdio.ads
create mode 100644 src/translate/grt/grt-table.adb
create mode 100644 src/translate/grt/grt-table.ads
create mode 100644 src/translate/grt/grt-threads.ads
create mode 100644 src/translate/grt/grt-types.ads
create mode 100644 src/translate/grt/grt-unithread.adb
create mode 100644 src/translate/grt/grt-unithread.ads
create mode 100644 src/translate/grt/grt-values.adb
create mode 100644 src/translate/grt/grt-values.ads
create mode 100644 src/translate/grt/grt-vcd.adb
create mode 100644 src/translate/grt/grt-vcd.ads
create mode 100644 src/translate/grt/grt-vcdz.adb
create mode 100644 src/translate/grt/grt-vcdz.ads
create mode 100644 src/translate/grt/grt-vital_annotate.adb
create mode 100644 src/translate/grt/grt-vital_annotate.ads
create mode 100644 src/translate/grt/grt-vpi.adb
create mode 100644 src/translate/grt/grt-vpi.ads
create mode 100644 src/translate/grt/grt-vstrings.adb
create mode 100644 src/translate/grt/grt-vstrings.ads
create mode 100644 src/translate/grt/grt-waves.adb
create mode 100644 src/translate/grt/grt-waves.ads
create mode 100644 src/translate/grt/grt-zlib.ads
create mode 100644 src/translate/grt/grt.adc
create mode 100644 src/translate/grt/grt.ads
create mode 100644 src/translate/grt/grt.ver
create mode 100644 src/translate/grt/main.adb
create mode 100644 src/translate/grt/main.ads
create mode 100644 src/translate/mcode/Makefile.in
create mode 100644 src/translate/mcode/README
create mode 100755 src/translate/mcode/dist.sh
create mode 100644 src/translate/mcode/winbuild.bat
create mode 100644 src/translate/mcode/windows/compile.bat
create mode 100644 src/translate/mcode/windows/complib.bat
create mode 100644 src/translate/mcode/windows/default_pathes.ads
create mode 100644 src/translate/mcode/windows/ghdl.nsi
create mode 100644 src/translate/mcode/windows/ghdlfilter.adb
create mode 100755 src/translate/mcode/windows/ghdlversion.adb
create mode 100644 src/translate/mcode/windows/grt-modules.adb
create mode 100644 src/translate/mcode/windows/ortho_code-x86-flags.ads
create mode 100644 src/translate/mcode/windows/windows_default_path.adb
create mode 100644 src/translate/mcode/windows/windows_default_path.ads
create mode 100644 src/translate/ortho_front.adb
create mode 100644 src/translate/trans_analyzes.adb
create mode 100644 src/translate/trans_analyzes.ads
create mode 100644 src/translate/trans_be.adb
create mode 100644 src/translate/trans_be.ads
create mode 100644 src/translate/trans_decls.ads
create mode 100644 src/translate/translation.adb
create mode 100644 src/translate/translation.ads
create mode 100644 src/types.ads
create mode 100644 src/version.ads
create mode 100644 src/xrefs.adb
create mode 100644 src/xrefs.ads
create mode 100644 src/xtools/Makefile
create mode 100755 src/xtools/pnodes.py
(limited to 'src')
diff --git a/src/back_end.adb b/src/back_end.adb
new file mode 100644
index 000000000..81bc20732
--- /dev/null
+++ b/src/back_end.adb
@@ -0,0 +1,38 @@
+-- Back-end specialization
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Flags; use Flags;
+with Iirs_Utils; use Iirs_Utils;
+
+package body Back_End is
+ -- Transform a library identifier into a file name.
+ -- Very simple mechanism: just add '-simVV.cf' extension, where VV
+ -- is the version.
+ function Default_Library_To_File_Name (Library: Iir_Library_Declaration)
+ return String
+ is
+ begin
+ case Vhdl_Std is
+ when Vhdl_87 =>
+ return Image_Identifier (Library) & "-obj87.cf";
+ when Vhdl_93c | Vhdl_93 | Vhdl_00 | Vhdl_02 =>
+ return Image_Identifier (Library) & "-obj93.cf";
+ when Vhdl_08 =>
+ return Image_Identifier (Library) & "-obj08.cf";
+ end case;
+ end Default_Library_To_File_Name;
+end Back_End;
diff --git a/src/back_end.ads b/src/back_end.ads
new file mode 100644
index 000000000..3ee1e686a
--- /dev/null
+++ b/src/back_end.ads
@@ -0,0 +1,57 @@
+-- Back-end specialization
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Iirs; use Iirs;
+
+package Back_End is
+ -- Return the name of the library file for LIBRARY.
+ -- The library file describe the contents of LIBRARY.
+ function Default_Library_To_File_Name (Library : Iir_Library_Declaration)
+ return String;
+
+ type Library_To_File_Name_Acc is
+ access function (Library : Iir_Library_Declaration) return String;
+
+ Library_To_File_Name : Library_To_File_Name_Acc :=
+ Default_Library_To_File_Name'Access;
+
+ -- Back-end options.
+ type Parse_Option_Acc is access function (Opt : String) return Boolean;
+ Parse_Option : Parse_Option_Acc := null;
+
+ -- Disp back-end option help.
+ type Disp_Option_Acc is access procedure;
+ Disp_Option : Disp_Option_Acc := null;
+
+ -- UNIT is a design unit from parse.
+ -- According to the current back-end, do what is necessary.
+ --
+ -- If MAIN is true, then UNIT is a wanted to be analysed design unit, and
+ -- dump/list options can applied.
+ -- This avoid to dump/list units fetched (through a selected name or a
+ -- use clause) indirectly by the main unit.
+ type Finish_Compilation_Acc is access
+ procedure (Unit : Iir_Design_Unit; Main : Boolean := False);
+
+ Finish_Compilation : Finish_Compilation_Acc := null;
+
+ -- DECL is an architecture (library unit) or a subprogram (specification)
+ -- decorated with a FOREIGN attribute. Do back-end checks.
+ -- May be NULL for no additionnal checks.
+ type Sem_Foreign_Acc is access procedure (Decl : Iir);
+ Sem_Foreign : Sem_Foreign_Acc := null;
+end Back_End;
diff --git a/src/bug.adb b/src/bug.adb
new file mode 100644
index 000000000..0948b97ff
--- /dev/null
+++ b/src/bug.adb
@@ -0,0 +1,104 @@
+-- Bug handling
+-- 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 GHDL; 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; use Ada.Text_IO;
+with Ada.Command_Line; use Ada.Command_Line;
+with GNAT.Directory_Operations;
+with Version; use Version;
+
+package body Bug is
+ -- Declared in the files generated by gnatbind.
+ -- Note: since the string is exported with C convension, there is no way
+ -- to know the length (gnat1 crashes if the string is unconstrained).
+ -- Hopefully, the format of the string seems to be fixed.
+ -- We don't use GNAT.Compiler_Version because it doesn't exist
+ -- in gnat 3.15p
+ GNAT_Version : constant String (1 .. 31 + 15);
+ pragma Import (C, GNAT_Version, "__gnat_version");
+
+ function Get_Gnat_Version return String
+ is
+ C : Character;
+ begin
+ for I in GNAT_Version'Range loop
+ C := GNAT_Version (I);
+ case C is
+ when ' '
+ | 'A' .. 'Z'
+ | 'a' .. 'z'
+ | '0' .. '9'
+ | ':'
+ | '-'
+ | '.'
+ | '(' =>
+ -- Accept only a few printable characters.
+ -- Underscore is excluded since the next bytes after
+ -- GNAT_Version is Ada_Main_Program_Name, which often starts
+ -- with _ada_.
+ null;
+ when ')' =>
+ return GNAT_Version (1 .. I);
+ when others =>
+ return GNAT_Version (1 .. I - 1);
+ end case;
+ end loop;
+ return GNAT_Version;
+ end Get_Gnat_Version;
+
+ procedure Disp_Bug_Box (Except : Exception_Occurrence)
+ is
+ Id : Exception_Id;
+ begin
+ New_Line (Standard_Error);
+ Put_Line
+ (Standard_Error,
+ "******************** GHDL Bug occured ****************************");
+ Put_Line
+ (Standard_Error,
+ "Please report this bug on http://gna.org/projects/ghdl");
+ Put_Line (Standard_Error, "GHDL release: " & Ghdl_Release);
+ Put_Line (Standard_Error, "Compiled with " & Get_Gnat_Version);
+ Put_Line (Standard_Error, "In directory: " &
+ GNAT.Directory_Operations.Get_Current_Dir);
+ --Put_Line
+ -- ("Program name: " & Command_Name);
+ --Put_Line
+ -- ("Program arguments:");
+ --for I in 1 .. Argument_Count loop
+ -- Put_Line (" " & Argument (I));
+ --end loop;
+ Put_Line (Standard_Error, "Command line:");
+ Put (Standard_Error, Command_Name);
+ for I in 1 .. Argument_Count loop
+ Put (Standard_Error, ' ');
+ Put (Standard_Error, Argument (I));
+ end loop;
+ New_Line (Standard_Error);
+ Id := Exception_Identity (Except);
+ if Id /= Null_Id then
+ Put_Line (Standard_Error,
+ "Exception " & Exception_Name (Id) & " raised");
+ --Put_Line ("exception message: " & Exception_Message (Except));
+ Put_Line (Standard_Error,
+ "Exception information:");
+ Put (Standard_Error, Exception_Information (Except));
+ end if;
+ Put_Line
+ (Standard_Error,
+ "******************************************************************");
+ end Disp_Bug_Box;
+end Bug;
diff --git a/src/bug.ads b/src/bug.ads
new file mode 100644
index 000000000..c90ca0976
--- /dev/null
+++ b/src/bug.ads
@@ -0,0 +1,26 @@
+-- Bug handling
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Exceptions; use Ada.Exceptions;
+
+package Bug is
+ -- Display a bug box for EXCEPT.
+ procedure Disp_Bug_Box (Except : Exception_Occurrence);
+
+ -- Get the gnat version used to bind the unit.
+ function Get_Gnat_Version return String;
+end Bug;
diff --git a/src/canon.adb b/src/canon.adb
new file mode 100644
index 000000000..cd2dae0fd
--- /dev/null
+++ b/src/canon.adb
@@ -0,0 +1,2735 @@
+-- Canonicalization pass
+-- Copyright (C) 2002, 2003, 2004, 2005, 2008 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Errorout; use Errorout;
+with Iirs_Utils; use Iirs_Utils;
+with Types; use Types;
+with Name_Table;
+with Sem;
+with Iir_Chains; use Iir_Chains;
+with Flags; use Flags;
+with PSL.Nodes;
+with PSL.Rewrites;
+with PSL.Build;
+
+package body Canon is
+ -- Canonicalize a list of declarations. LIST can be null.
+ -- PARENT must be the parent of the current statements chain for LIST,
+ -- or NULL_IIR if LIST has no corresponding current statments.
+ procedure Canon_Declarations (Top : Iir_Design_Unit;
+ Decl_Parent : Iir;
+ Parent : Iir);
+ procedure Canon_Declaration (Top : Iir_Design_Unit;
+ Decl : Iir;
+ Parent : Iir;
+ Decl_Parent : Iir);
+
+ -- Canon on expressions, mainly for function calls.
+ procedure Canon_Expression (Expr: Iir);
+
+ -- Canonicalize an association list.
+ -- If ASSOCIATION_LIST is not null, then it is re-ordored and returned.
+ -- If ASSOCIATION_LIST is null then:
+ -- if INTERFACE_LIST is null then returns null.
+ -- if INTERFACE_LIST is not null, a default list is created.
+ function Canon_Association_Chain
+ (Interface_Chain: Iir; Association_Chain: Iir; Loc : Iir)
+ return Iir;
+
+ -- Like Canon_Association_Chain but recurse on actuals.
+ function Canon_Association_Chain_And_Actuals
+ (Interface_Chain: Iir; Association_Chain: Iir; Loc : Iir)
+ return Iir;
+
+ -- Like Canon_Subprogram_Call, but recurse on actuals.
+ procedure Canon_Subprogram_Call_And_Actuals (Call : Iir);
+
+ -- Canonicalize block configuration CONF.
+ -- TOP is used to added dependences to the design unit which CONF
+ -- belongs to.
+ procedure Canon_Block_Configuration (Top : Iir_Design_Unit;
+ Conf : Iir_Block_Configuration);
+
+ procedure Canon_Subtype_Indication (Def : Iir);
+ procedure Canon_Subtype_Indication_If_Anonymous (Def : Iir);
+
+ procedure Canon_Extract_Sensitivity_Aggregate
+ (Aggr : Iir;
+ Sensitivity_List : Iir_List;
+ Is_Target : Boolean;
+ Aggr_Type : Iir;
+ Dim : Natural)
+ is
+ Assoc : Iir;
+ begin
+ Assoc := Get_Association_Choices_Chain (Aggr);
+ if Get_Nbr_Elements (Get_Index_Subtype_List (Aggr_Type)) = Dim then
+ while Assoc /= Null_Iir loop
+ Canon_Extract_Sensitivity
+ (Get_Associated_Expr (Assoc), Sensitivity_List, Is_Target);
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ else
+ while Assoc /= Null_Iir loop
+ Canon_Extract_Sensitivity_Aggregate
+ (Get_Associated_Expr (Assoc), Sensitivity_List,
+ Is_Target, Aggr_Type, Dim + 1);
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end if;
+ end Canon_Extract_Sensitivity_Aggregate;
+
+ procedure Canon_Extract_Sensitivity
+ (Expr: Iir; Sensitivity_List: Iir_List; Is_Target: Boolean := False)
+ is
+ El : Iir;
+ List: Iir_List;
+ begin
+ if Get_Expr_Staticness (Expr) /= None then
+ return;
+ end if;
+
+ case Get_Kind (Expr) is
+ when Iir_Kind_Slice_Name =>
+ if not Is_Target and then
+ Get_Name_Staticness (Expr) >= Globally
+ then
+ if Is_Signal_Object (Expr) then
+ Add_Element (Sensitivity_List, Expr);
+ end if;
+ else
+ declare
+ Suff : Iir;
+ begin
+ Canon_Extract_Sensitivity
+ (Get_Prefix (Expr), Sensitivity_List, Is_Target);
+ Suff := Get_Suffix (Expr);
+ if Get_Kind (Suff) not in Iir_Kinds_Scalar_Type_Definition
+ then
+ Canon_Extract_Sensitivity
+ (Suff, Sensitivity_List, False);
+ end if;
+ end;
+ end if;
+
+ when Iir_Kind_Selected_Element =>
+ if not Is_Target and then
+ Get_Name_Staticness (Expr) >= Globally
+ then
+ if Is_Signal_Object (Expr) then
+ Add_Element (Sensitivity_List, Expr);
+ end if;
+ else
+ Canon_Extract_Sensitivity (Get_Prefix (Expr),
+ Sensitivity_List,
+ Is_Target);
+ end if;
+
+ when Iir_Kind_Indexed_Name =>
+ if not Is_Target
+ and then Get_Name_Staticness (Expr) >= Globally
+ then
+ if Is_Signal_Object (Expr) then
+ Add_Element (Sensitivity_List, Expr);
+ end if;
+ else
+ Canon_Extract_Sensitivity (Get_Prefix (Expr),
+ Sensitivity_List,
+ Is_Target);
+ List := Get_Index_List (Expr);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Canon_Extract_Sensitivity (El, Sensitivity_List, False);
+ end loop;
+ end if;
+
+ when Iir_Kind_Function_Call =>
+ El := Get_Parameter_Association_Chain (Expr);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Association_Element_By_Expression =>
+ Canon_Extract_Sensitivity
+ (Get_Actual (El), Sensitivity_List, False);
+ when Iir_Kind_Association_Element_Open =>
+ null;
+ when others =>
+ Error_Kind ("canon_extract_sensitivity(call)", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+
+ when Iir_Kind_Qualified_Expression
+ | Iir_Kind_Type_Conversion
+ | Iir_Kind_Allocator_By_Expression =>
+ Canon_Extract_Sensitivity
+ (Get_Expression (Expr), Sensitivity_List, False);
+
+ when Iir_Kind_Allocator_By_Subtype =>
+ null;
+
+ when Iir_Kinds_Monadic_Operator =>
+ Canon_Extract_Sensitivity
+ (Get_Operand (Expr), Sensitivity_List, False);
+ when Iir_Kinds_Dyadic_Operator =>
+ Canon_Extract_Sensitivity
+ (Get_Left (Expr), Sensitivity_List, False);
+ Canon_Extract_Sensitivity
+ (Get_Right (Expr), Sensitivity_List, False);
+
+ when Iir_Kind_Range_Expression =>
+ Canon_Extract_Sensitivity
+ (Get_Left_Limit (Expr), Sensitivity_List, False);
+ Canon_Extract_Sensitivity
+ (Get_Right_Limit (Expr), Sensitivity_List, False);
+
+ when Iir_Kinds_Type_Attribute =>
+ null;
+ when Iir_Kind_Event_Attribute
+ | Iir_Kind_Active_Attribute =>
+ -- LRM 8.1
+ -- An attribute name: [...]; otherwise, apply this rule to the
+ -- prefix of the attribute name.
+ Canon_Extract_Sensitivity
+ (Get_Prefix (Expr), Sensitivity_List, False);
+
+
+ when Iir_Kind_Last_Value_Attribute =>
+ null;
+
+ when Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute =>
+ -- LRM 8.1
+ -- A simple name that denotes a signal, add the longuest static
+ -- prefix of the name to the sensitivity set;
+ --
+ -- An attribute name: if the designator denotes a signal
+ -- attribute, add the longuest static prefix of the name of the
+ -- implicit signal denoted by the attribute name to the
+ -- sensitivity set; [...]
+ if not Is_Target then
+ Add_Element (Sensitivity_List, Expr);
+ end if;
+
+ when Iir_Kind_Object_Alias_Declaration =>
+ Canon_Extract_Sensitivity
+ (Get_Name (Expr), Sensitivity_List, Is_Target);
+
+ when Iir_Kind_Constant_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_File_Declaration =>
+ null;
+
+ when Iir_Kinds_Array_Attribute =>
+ -- was Iir_Kind_Left_Array_Attribute
+ -- ditto Right, Low, High, Length
+ -- add Ascending, Range and Reverse_Range...
+ null;
+ --Canon_Extract_Sensitivity
+ -- (Get_Prefix (Expr), Sensitivity_List, Is_Target);
+
+ when Iir_Kind_Value_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kinds_Scalar_Type_Attribute =>
+ Canon_Extract_Sensitivity
+ (Get_Parameter (Expr), Sensitivity_List, Is_Target);
+
+ when Iir_Kind_Aggregate =>
+ declare
+ Aggr_Type : Iir;
+ begin
+ Aggr_Type := Get_Base_Type (Get_Type (Expr));
+ case Get_Kind (Aggr_Type) is
+ when Iir_Kind_Array_Type_Definition =>
+ Canon_Extract_Sensitivity_Aggregate
+ (Expr, Sensitivity_List, Is_Target, Aggr_Type, 1);
+ when Iir_Kind_Record_Type_Definition =>
+ El := Get_Association_Choices_Chain (Expr);
+ while El /= Null_Iir loop
+ Canon_Extract_Sensitivity
+ (Get_Associated_Expr (El), Sensitivity_List,
+ Is_Target);
+ El := Get_Chain (El);
+ end loop;
+ when others =>
+ Error_Kind ("canon_extract_sensitivity(aggr)", Aggr_Type);
+ end case;
+ end;
+
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ Canon_Extract_Sensitivity
+ (Get_Named_Entity (Expr), Sensitivity_List, Is_Target);
+
+ when others =>
+ Error_Kind ("canon_extract_sensitivity", Expr);
+ end case;
+ end Canon_Extract_Sensitivity;
+
+ procedure Canon_Extract_Sensitivity_If_Not_Null
+ (Expr: Iir; Sensitivity_List: Iir_List; Is_Target: Boolean := False) is
+ begin
+ if Expr /= Null_Iir then
+ Canon_Extract_Sensitivity (Expr, Sensitivity_List, Is_Target);
+ end if;
+ end Canon_Extract_Sensitivity_If_Not_Null;
+
+ procedure Canon_Extract_Sequential_Statement_Chain_Sensitivity
+ (Chain : Iir; List : Iir_List)
+ is
+ Stmt : Iir;
+ begin
+ Stmt := Chain;
+ while Stmt /= Null_Iir loop
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Assertion_Statement =>
+ -- LRM08 11.3
+ -- * For each assertion, report, next, exit or return
+ -- statement, apply the rule of 10.2 to each expression
+ -- in the statement, and construct the union of the
+ -- resulting sets.
+ Canon_Extract_Sensitivity
+ (Get_Assertion_Condition (Stmt), List);
+ Canon_Extract_Sensitivity
+ (Get_Severity_Expression (Stmt), List);
+ Canon_Extract_Sensitivity
+ (Get_Report_Expression (Stmt), List);
+ when Iir_Kind_Report_Statement =>
+ -- LRM08 11.3
+ -- See assertion_statement case.
+ Canon_Extract_Sensitivity
+ (Get_Severity_Expression (Stmt), List);
+ Canon_Extract_Sensitivity
+ (Get_Report_Expression (Stmt), List);
+ when Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement =>
+ -- LRM08 11.3
+ -- See assertion_statement case.
+ Canon_Extract_Sensitivity
+ (Get_Condition (Stmt), List);
+ when Iir_Kind_Return_Statement =>
+ -- LRM08 11.3
+ -- See assertion_statement case.
+ Canon_Extract_Sensitivity_If_Not_Null
+ (Get_Expression (Stmt), List);
+ when Iir_Kind_Variable_Assignment_Statement =>
+ -- LRM08 11.3
+ -- * For each assignment statement, apply the rule of 10.2 to
+ -- each expression occuring in the assignment, including any
+ -- expressions occuring in the index names or slice names in
+ -- the target, and construct the union of the resulting sets.
+ Canon_Extract_Sensitivity (Get_Target (Stmt), List, True);
+ Canon_Extract_Sensitivity (Get_Expression (Stmt), List, False);
+ when Iir_Kind_Signal_Assignment_Statement =>
+ -- LRM08 11.3
+ -- See variable assignment statement case.
+ Canon_Extract_Sensitivity (Get_Target (Stmt), List, True);
+ Canon_Extract_Sensitivity_If_Not_Null
+ (Get_Reject_Time_Expression (Stmt), List);
+ declare
+ We: Iir_Waveform_Element;
+ begin
+ We := Get_Waveform_Chain (Stmt);
+ while We /= Null_Iir loop
+ Canon_Extract_Sensitivity (Get_We_Value (We), List);
+ We := Get_Chain (We);
+ end loop;
+ end;
+ when Iir_Kind_If_Statement =>
+ -- LRM08 11.3
+ -- * For each if statement, apply the rule of 10.2 to the
+ -- condition and apply this rule recursively to each
+ -- sequence of statements within the if statement, and
+ -- construct the union of the resuling sets.
+ declare
+ El1 : Iir := Stmt;
+ Cond : Iir;
+ begin
+ loop
+ Cond := Get_Condition (El1);
+ if Cond /= Null_Iir then
+ Canon_Extract_Sensitivity (Cond, List);
+ end if;
+ Canon_Extract_Sequential_Statement_Chain_Sensitivity
+ (Get_Sequential_Statement_Chain (El1), List);
+ El1 := Get_Else_Clause (El1);
+ exit when El1 = Null_Iir;
+ end loop;
+ end;
+ when Iir_Kind_Case_Statement =>
+ -- LRM08 11.3
+ -- * For each case statement, apply the rule of 10.2 to the
+ -- expression and apply this rule recursively to each
+ -- sequence of statements within the case statement, and
+ -- construct the union of the resulting sets.
+ Canon_Extract_Sensitivity (Get_Expression (Stmt), List);
+ declare
+ Choice: Iir;
+ begin
+ Choice := Get_Case_Statement_Alternative_Chain (Stmt);
+ while Choice /= Null_Iir loop
+ Canon_Extract_Sequential_Statement_Chain_Sensitivity
+ (Get_Associated_Chain (Choice), List);
+ Choice := Get_Chain (Choice);
+ end loop;
+ end;
+ when Iir_Kind_While_Loop_Statement =>
+ -- LRM08 11.3
+ -- * For each loop statement, apply the rule of 10.2 to each
+ -- expression in the iteration scheme, if present, and apply
+ -- this rule recursively to the sequence of statements within
+ -- the loop statement, and construct the union of the
+ -- resulting sets.
+ Canon_Extract_Sensitivity_If_Not_Null
+ (Get_Condition (Stmt), List);
+ Canon_Extract_Sequential_Statement_Chain_Sensitivity
+ (Get_Sequential_Statement_Chain (Stmt), List);
+ when Iir_Kind_For_Loop_Statement =>
+ -- LRM08 11.3
+ -- See loop statement case.
+ declare
+ It : constant Iir := Get_Parameter_Specification (Stmt);
+ It_Type : constant Iir := Get_Type (It);
+ Rng : constant Iir := Get_Range_Constraint (It_Type);
+ begin
+ if Get_Kind (Rng) = Iir_Kind_Range_Expression then
+ Canon_Extract_Sensitivity (Rng, List);
+ end if;
+ end;
+ Canon_Extract_Sequential_Statement_Chain_Sensitivity
+ (Get_Sequential_Statement_Chain (Stmt), List);
+ when Iir_Kind_Null_Statement =>
+ -- LRM08 11.3
+ -- ?
+ null;
+ when Iir_Kind_Procedure_Call_Statement =>
+ -- LRM08 11.3
+ -- * For each procedure call statement, apply the rule of 10.2
+ -- to each actual designator (other than OPEN) associated
+ -- with each formal parameter of mode IN or INOUT, and
+ -- construct the union of the resulting sets.
+ declare
+ Param : Iir;
+ begin
+ Param := Get_Parameter_Association_Chain
+ (Get_Procedure_Call (Stmt));
+ while Param /= Null_Iir loop
+ if (Get_Kind (Param)
+ = Iir_Kind_Association_Element_By_Expression)
+ and then (Get_Mode (Get_Association_Interface (Param))
+ /= Iir_Out_Mode)
+ then
+ Canon_Extract_Sensitivity (Get_Actual (Param), List);
+ end if;
+ Param := Get_Chain (Param);
+ end loop;
+ end;
+ when others =>
+ Error_Kind
+ ("canon_extract_sequential_statement_chain_sensitivity",
+ Stmt);
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Canon_Extract_Sequential_Statement_Chain_Sensitivity;
+
+ procedure Canon_Extract_Sensitivity_From_Callees
+ (Callees_List : Iir_List; Sensitivity_List : Iir_List)
+ is
+ Callee : Iir;
+ Bod : Iir;
+ begin
+ -- LRM08 11.3
+ -- Moreover, for each subprogram for which the process is a parent
+ -- (see 4.3), the sensitivity list includes members of the set
+ -- constructed by apply the preceding rule to the statements of the
+ -- subprogram, but excluding the members that denote formal signal
+ -- parameters or members of formal signal parameters of the subprogram
+ -- or any of its parents.
+ if Callees_List = Null_Iir_List then
+ return;
+ end if;
+ for I in Natural loop
+ Callee := Get_Nth_Element (Callees_List, I);
+ exit when Callee = Null_Iir;
+ if not Get_Seen_Flag (Callee) then
+ Set_Seen_Flag (Callee, True);
+ case Get_All_Sensitized_State (Callee) is
+ when Read_Signal =>
+ Bod := Get_Subprogram_Body (Callee);
+
+ -- Extract sensitivity from signals read in the body.
+ -- FIXME: what about signals read during in declarations ?
+ Canon_Extract_Sequential_Statement_Chain_Sensitivity
+ (Get_Sequential_Statement_Chain (Bod), Sensitivity_List);
+
+ -- Extract sensitivity from subprograms called.
+ Canon_Extract_Sensitivity_From_Callees
+ (Get_Callees_List (Bod), Sensitivity_List);
+
+ when No_Signal =>
+ null;
+
+ when Unknown | Invalid_Signal =>
+ raise Internal_Error;
+ end case;
+ end if;
+ end loop;
+ end Canon_Extract_Sensitivity_From_Callees;
+
+ function Canon_Extract_Process_Sensitivity
+ (Proc : Iir_Sensitized_Process_Statement)
+ return Iir_List
+ is
+ Res : Iir_List;
+ begin
+ Res := Create_Iir_List;
+
+ -- Signals read by statements.
+ -- FIXME: justify why signals read in declarations don't care.
+ Canon_Extract_Sequential_Statement_Chain_Sensitivity
+ (Get_Sequential_Statement_Chain (Proc), Res);
+
+ -- Signals read indirectly by subprograms called.
+ Canon_Extract_Sensitivity_From_Callees (Get_Callees_List (Proc), Res);
+
+ Set_Seen_Flag (Proc, True);
+ Clear_Seen_Flag (Proc);
+ return Res;
+ end Canon_Extract_Process_Sensitivity;
+
+-- function Make_Aggregate (Array_Type : Iir_Array_Type_Definition; El : Iir)
+-- return Iir_Aggregate
+-- is
+-- Res : Iir_Aggregate;
+-- Choice : Iir;
+-- begin
+-- Res := Create_Iir (Iir_Kind_Aggregate);
+-- Location_Copy (Res, El);
+-- Choice := Create_Iir (Iir_Kind_Association_Choice_By_None);
+-- Set_Associated (Choice, El);
+-- Append_Element (Get_Association_Choices_List (Res), Choice);
+
+-- -- will call sem_aggregate
+-- return Sem_Expr.Sem_Expression (Res, Array_Type);
+-- end Make_Aggregate;
+
+-- procedure Canon_Concatenation_Operator (Expr : Iir)
+-- is
+-- Array_Type : Iir_Array_Type_Definition;
+-- El_Type : Iir;
+-- Left, Right : Iir;
+-- Func_List : Iir_Implicit_Functions_List;
+-- Func : Iir_Implicit_Function_Declaration;
+-- begin
+-- Array_Type := Get_Type (Expr);
+-- El_Type := Get_Base_Type (Get_Element_Subtype (Array_Type));
+-- Left := Get_Left (Expr);
+-- if Get_Type (Left) = El_Type then
+-- Set_Left (Expr, Make_Aggregate (Array_Type, Left));
+-- end if;
+-- Right := Get_Right (Expr);
+-- if Get_Type (Right) = El_Type then
+-- Set_Right (Expr, Make_Aggregate (Array_Type, Right));
+-- end if;
+
+-- -- FIXME: must convert the implementation.
+-- -- Use implicit declaration list from the array_type ?
+-- Func_List := Get_Implicit_Functions_List
+-- (Get_Type_Declarator (Array_Type));
+-- for I in Natural loop
+-- Func := Get_Nth_Element (Func_List, I);
+-- if Get_Implicit_Definition (Func)
+-- = Iir_Predefined_Array_Array_Concat
+-- then
+-- Set_Implementation (Expr, Func);
+-- exit;
+-- end if;
+-- end loop;
+-- end Canon_Concatenation_Operator;
+
+ procedure Canon_Aggregate_Expression (Expr: Iir)
+ is
+ Assoc : Iir;
+ begin
+ Assoc := Get_Association_Choices_Chain (Expr);
+ while Assoc /= Null_Iir loop
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Choice_By_Others
+ | Iir_Kind_Choice_By_None
+ | Iir_Kind_Choice_By_Name =>
+ null;
+ when Iir_Kind_Choice_By_Expression =>
+ Canon_Expression (Get_Choice_Expression (Assoc));
+ when Iir_Kind_Choice_By_Range =>
+ declare
+ Choice : constant Iir := Get_Choice_Range (Assoc);
+ begin
+ if Get_Kind (Choice) = Iir_Kind_Range_Expression then
+ Canon_Expression (Choice);
+ end if;
+ end;
+ when others =>
+ Error_Kind ("canon_aggregate_expression", Assoc);
+ end case;
+ Canon_Expression (Get_Associated_Expr (Assoc));
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end Canon_Aggregate_Expression;
+
+ -- canon on expressions, mainly for function calls.
+ procedure Canon_Expression (Expr: Iir)
+ is
+ El : Iir;
+ List: Iir_List;
+ begin
+ if Expr = Null_Iir then
+ return;
+ end if;
+ case Get_Kind (Expr) is
+ when Iir_Kind_Range_Expression =>
+ Canon_Expression (Get_Left_Limit (Expr));
+ Canon_Expression (Get_Right_Limit (Expr));
+
+ when Iir_Kind_Slice_Name =>
+ declare
+ Suffix : Iir;
+ begin
+ Suffix := Get_Suffix (Expr);
+ if Get_Kind (Suffix) not in Iir_Kinds_Discrete_Type_Definition
+ then
+ Canon_Expression (Suffix);
+ end if;
+ Canon_Expression (Get_Prefix (Expr));
+ end;
+
+ when Iir_Kind_Indexed_Name =>
+ Canon_Expression (Get_Prefix (Expr));
+ List := Get_Index_List (Expr);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Canon_Expression (El);
+ end loop;
+
+ when Iir_Kind_Selected_Element =>
+ Canon_Expression (Get_Prefix (Expr));
+ when Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference =>
+ Canon_Expression (Get_Prefix (Expr));
+
+ when Iir_Kinds_Denoting_Name =>
+ Canon_Expression (Get_Named_Entity (Expr));
+
+ when Iir_Kinds_Monadic_Operator =>
+ Canon_Expression (Get_Operand (Expr));
+ when Iir_Kinds_Dyadic_Operator =>
+ Canon_Expression (Get_Left (Expr));
+ Canon_Expression (Get_Right (Expr));
+ if Get_Kind (Expr) = Iir_Kind_Concatenation_Operator
+ and then Canon_Concatenation
+ and then Get_Kind (Get_Implementation (Expr)) =
+ Iir_Kind_Implicit_Function_Declaration
+ then
+ --Canon_Concatenation_Operator (Expr);
+ raise Internal_Error;
+ end if;
+
+ when Iir_Kind_Function_Call =>
+ Canon_Subprogram_Call_And_Actuals (Expr);
+ -- FIXME:
+ -- should canon concatenation.
+
+ when Iir_Kind_Parenthesis_Expression =>
+ Canon_Expression (Get_Expression (Expr));
+ when Iir_Kind_Type_Conversion
+ | Iir_Kind_Qualified_Expression =>
+ Canon_Expression (Get_Expression (Expr));
+ when Iir_Kind_Aggregate =>
+ Canon_Aggregate_Expression (Expr);
+ when Iir_Kind_Allocator_By_Expression =>
+ Canon_Expression (Get_Expression (Expr));
+ when Iir_Kind_Allocator_By_Subtype =>
+ declare
+ Ind : constant Iir := Get_Subtype_Indication (Expr);
+ begin
+ if Get_Kind (Ind) = Iir_Kind_Array_Subtype_Definition then
+ Canon_Subtype_Indication (Ind);
+ end if;
+ end;
+
+ when Iir_Kinds_Literal
+ | Iir_Kind_Simple_Aggregate
+ | Iir_Kind_Unit_Declaration =>
+ null;
+
+ when Iir_Kinds_Array_Attribute =>
+ -- No need to canon parameter, since it is a locally static
+ -- expression.
+ declare
+ Prefix : constant Iir := Get_Prefix (Expr);
+ begin
+ if Get_Kind (Prefix) in Iir_Kinds_Denoting_Name
+ and then (Get_Kind (Get_Named_Entity (Prefix))
+ in Iir_Kinds_Type_Declaration)
+ then
+ -- No canon for types.
+ null;
+ else
+ Canon_Expression (Prefix);
+ end if;
+ end;
+
+ when Iir_Kinds_Type_Attribute =>
+ null;
+ when Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Transaction_Attribute =>
+ -- FIXME: add the default parameter ?
+ Canon_Expression (Get_Prefix (Expr));
+ when Iir_Kind_Event_Attribute
+ | Iir_Kind_Last_Value_Attribute
+ | Iir_Kind_Active_Attribute
+ | Iir_Kind_Last_Event_Attribute
+ | Iir_Kind_Last_Active_Attribute
+ | Iir_Kind_Driving_Attribute
+ | Iir_Kind_Driving_Value_Attribute =>
+ Canon_Expression (Get_Prefix (Expr));
+
+ when Iir_Kinds_Scalar_Type_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute =>
+ Canon_Expression (Get_Parameter (Expr));
+
+ when Iir_Kind_Simple_Name_Attribute
+ | Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute =>
+ null;
+
+ when Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Object_Alias_Declaration =>
+ null;
+
+ when Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Overflow_Literal =>
+ null;
+
+ when Iir_Kind_Element_Declaration =>
+ null;
+
+ when Iir_Kind_Attribute_Value
+ | Iir_Kind_Attribute_Name =>
+ null;
+
+ when others =>
+ Error_Kind ("canon_expression", Expr);
+ null;
+ end case;
+ end Canon_Expression;
+
+ procedure Canon_Discrete_Range (Rng : Iir) is
+ begin
+ case Get_Kind (Rng) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ Canon_Expression (Get_Range_Constraint (Rng));
+ when Iir_Kind_Enumeration_Type_Definition =>
+ null;
+ when others =>
+ Error_Kind ("canon_discrete_range", Rng);
+ end case;
+ end Canon_Discrete_Range;
+
+ procedure Canon_Waveform_Chain
+ (Chain : Iir_Waveform_Element; Sensitivity_List: Iir_List)
+ is
+ We: Iir_Waveform_Element;
+ begin
+ We := Chain;
+ while We /= Null_Iir loop
+ if Sensitivity_List /= Null_Iir_List then
+ Canon_Extract_Sensitivity
+ (Get_We_Value (We), Sensitivity_List, False);
+ end if;
+ if Canon_Flag_Expressions then
+ Canon_Expression (Get_We_Value (We));
+ if Get_Time (We) /= Null_Iir then
+ Canon_Expression (Get_Time (We));
+ end if;
+ end if;
+ We := Get_Chain (We);
+ end loop;
+ end Canon_Waveform_Chain;
+
+ -- Names associations by position,
+ -- reorder associations by name,
+ -- create omitted association,
+ function Canon_Association_Chain
+ (Interface_Chain : Iir; Association_Chain : Iir; Loc : Iir)
+ return Iir
+ is
+ -- The canon list of association.
+ N_Chain, Last : Iir;
+ Inter : Iir;
+ Assoc_El, Prev_Assoc_El, Next_Assoc_El : Iir;
+ Assoc_Chain : Iir;
+
+ Found : Boolean;
+ begin
+ -- No argument, so return now.
+ if Interface_Chain = Null_Iir then
+ pragma Assert (Association_Chain = Null_Iir);
+ return Null_Iir;
+ end if;
+
+ Sub_Chain_Init (N_Chain, Last);
+ Assoc_Chain := Association_Chain;
+
+ -- Reorder the list of association in the interface order.
+ -- Add missing associations.
+ Inter := Interface_Chain;
+ while Inter /= Null_Iir loop
+ -- Search associations with INTERFACE.
+ Found := False;
+ Assoc_El := Assoc_Chain;
+ Prev_Assoc_El := Null_Iir;
+ while Assoc_El /= Null_Iir loop
+ Next_Assoc_El := Get_Chain (Assoc_El);
+ if Get_Formal (Assoc_El) = Null_Iir then
+ Set_Formal (Assoc_El, Inter);
+ end if;
+ if Get_Association_Interface (Assoc_El) = Inter then
+
+ -- Remove ASSOC_EL from ASSOC_CHAIN
+ if Prev_Assoc_El /= Null_Iir then
+ Set_Chain (Prev_Assoc_El, Next_Assoc_El);
+ else
+ Assoc_Chain := Next_Assoc_El;
+ end if;
+
+ -- Append ASSOC_EL in N_CHAIN.
+ Set_Chain (Assoc_El, Null_Iir);
+ Sub_Chain_Append (N_Chain, Last, Assoc_El);
+
+ case Get_Kind (Assoc_El) is
+ when Iir_Kind_Association_Element_Open =>
+ goto Done;
+ when Iir_Kind_Association_Element_By_Expression =>
+ if Get_Whole_Association_Flag (Assoc_El) then
+ goto Done;
+ end if;
+ when Iir_Kind_Association_Element_By_Individual =>
+ Found := True;
+ when Iir_Kind_Association_Element_Package =>
+ goto Done;
+ when others =>
+ Error_Kind ("canon_association_chain", Assoc_El);
+ end case;
+ elsif Found then
+ -- No more associations.
+ goto Done;
+ else
+ Prev_Assoc_El := Assoc_El;
+ end if;
+ Assoc_El := Next_Assoc_El;
+ end loop;
+ if Found then
+ goto Done;
+ end if;
+
+ -- No association, use default expr.
+ Assoc_El := Create_Iir (Iir_Kind_Association_Element_Open);
+ Set_Artificial_Flag (Assoc_El, True);
+ Set_Whole_Association_Flag (Assoc_El, True);
+ Location_Copy (Assoc_El, Loc);
+ Set_Formal (Assoc_El, Inter);
+ Sub_Chain_Append (N_Chain, Last, Assoc_El);
+
+ << Done >> null;
+ Inter := Get_Chain (Inter);
+ end loop;
+ pragma Assert (Assoc_Chain = Null_Iir);
+
+ return N_Chain;
+ end Canon_Association_Chain;
+
+ procedure Canon_Association_Chain_Actuals (Association_Chain : Iir)
+ is
+ Assoc_El : Iir;
+ begin
+ -- Canon actuals.
+ Assoc_El := Association_Chain;
+ while Assoc_El /= Null_Iir loop
+ if Get_Kind (Assoc_El) = Iir_Kind_Association_Element_By_Expression
+ then
+ Canon_Expression (Get_Actual (Assoc_El));
+ end if;
+ Assoc_El := Get_Chain (Assoc_El);
+ end loop;
+ end Canon_Association_Chain_Actuals;
+
+ function Canon_Association_Chain_And_Actuals
+ (Interface_Chain: Iir; Association_Chain: Iir; Loc : Iir)
+ return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Canon_Association_Chain (Interface_Chain, Association_Chain, Loc);
+ if Canon_Flag_Expressions then
+ Canon_Association_Chain_Actuals (Res);
+ end if;
+ return Res;
+ end Canon_Association_Chain_And_Actuals;
+
+ procedure Canon_Subprogram_Call (Call : Iir)
+ is
+ Imp : constant Iir := Get_Implementation (Call);
+ Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp);
+ Assoc_Chain : Iir;
+ begin
+ Assoc_Chain := Get_Parameter_Association_Chain (Call);
+ Assoc_Chain := Canon_Association_Chain (Inter_Chain, Assoc_Chain, Call);
+ Set_Parameter_Association_Chain (Call, Assoc_Chain);
+ end Canon_Subprogram_Call;
+
+ procedure Canon_Subprogram_Call_And_Actuals (Call : Iir) is
+ begin
+ Canon_Subprogram_Call (Call);
+ if Canon_Flag_Expressions then
+ Canon_Association_Chain_Actuals
+ (Get_Parameter_Association_Chain (Call));
+ end if;
+ end Canon_Subprogram_Call_And_Actuals;
+
+ -- Create a default association list for INTERFACE_LIST.
+ -- The default is a list of interfaces associated with open.
+ function Canon_Default_Association_Chain (Interface_Chain : Iir)
+ return Iir
+ is
+ Res : Iir;
+ Last : Iir;
+ Assoc, El : Iir;
+ begin
+ El := Interface_Chain;
+ Sub_Chain_Init (Res, Last);
+ while El /= Null_Iir loop
+ Assoc := Create_Iir (Iir_Kind_Association_Element_Open);
+ Set_Whole_Association_Flag (Assoc, True);
+ Set_Artificial_Flag (Assoc, True);
+ Set_Formal (Assoc, El);
+ Location_Copy (Assoc, El);
+ Sub_Chain_Append (Res, Last, Assoc);
+ El := Get_Chain (El);
+ end loop;
+ return Res;
+ end Canon_Default_Association_Chain;
+
+-- function Canon_Default_Map_Association_List
+-- (Formal_List, Actual_List : Iir_List; Loc : Location_Type)
+-- return Iir_Association_List
+-- is
+-- Res : Iir_Association_List;
+-- Formal, Actual : Iir;
+-- Assoc : Iir;
+-- Nbr_Assoc : Natural;
+-- begin
+-- -- formal is the entity port/generic.
+-- if Formal_List = Null_Iir_List then
+-- if Actual_List /= Null_Iir_List then
+-- raise Internal_Error;
+-- end if;
+-- return Null_Iir_List;
+-- end if;
+
+-- Res := Create_Iir (Iir_Kind_Association_List);
+-- Set_Location (Res, Loc);
+-- Nbr_Assoc := 0;
+-- for I in Natural loop
+-- Formal := Get_Nth_Element (Formal_List, I);
+-- exit when Formal = Null_Iir;
+-- Actual := Find_Name_In_List (Actual_List, Get_Identifier (Formal));
+-- if Actual /= Null_Iir then
+-- Assoc := Create_Iir (Iir_Kind_Association_Element_By_Expression);
+-- Set_Whole_Association_Flag (Assoc, True);
+-- Set_Actual (Assoc, Actual);
+-- Nbr_Assoc := Nbr_Assoc + 1;
+-- else
+-- Assoc := Create_Iir (Iir_Kind_Association_Element_Open);
+-- end if;
+-- Set_Location (Assoc, Loc);
+-- Set_Formal (Assoc, Formal);
+-- Set_Associated_Formal (Assoc, Formal);
+-- Append_Element (Res, Assoc);
+-- end loop;
+-- if Nbr_Assoc /= Get_Nbr_Elements (Actual_List) then
+-- -- There is non-associated actuals.
+-- raise Internal_Error;
+-- end if;
+-- return Res;
+-- end Canon_Default_Map_Association_List;
+
+ -- Inner loop if any; used to canonicalize exit/next statement.
+ Cur_Loop : Iir;
+
+ procedure Canon_Sequential_Stmts (First : Iir)
+ is
+ Stmt: Iir;
+ Expr: Iir;
+ Prev_Loop : Iir;
+ begin
+ Stmt := First;
+ while Stmt /= Null_Iir loop
+ case Get_Kind (Stmt) is
+ when Iir_Kind_If_Statement =>
+ declare
+ Cond: Iir;
+ Clause: Iir := Stmt;
+ begin
+ while Clause /= Null_Iir loop
+ Cond := Get_Condition (Clause);
+ if Cond /= Null_Iir then
+ Canon_Expression (Cond);
+ end if;
+ Canon_Sequential_Stmts
+ (Get_Sequential_Statement_Chain (Clause));
+ Clause := Get_Else_Clause (Clause);
+ end loop;
+ end;
+
+ when Iir_Kind_Signal_Assignment_Statement =>
+ Canon_Expression (Get_Target (Stmt));
+ Canon_Waveform_Chain (Get_Waveform_Chain (Stmt), Null_Iir_List);
+
+ when Iir_Kind_Variable_Assignment_Statement =>
+ Canon_Expression (Get_Target (Stmt));
+ Canon_Expression (Get_Expression (Stmt));
+
+ when Iir_Kind_Wait_Statement =>
+ declare
+ Expr: Iir;
+ List: Iir_List;
+ begin
+ Expr := Get_Timeout_Clause (Stmt);
+ if Expr /= Null_Iir then
+ Canon_Expression (Expr);
+ end if;
+ Expr := Get_Condition_Clause (Stmt);
+ if Expr /= Null_Iir then
+ Canon_Expression (Expr);
+ end if;
+ List := Get_Sensitivity_List (Stmt);
+ if List = Null_Iir_List and then Expr /= Null_Iir then
+ List := Create_Iir_List;
+ Canon_Extract_Sensitivity (Expr, List, False);
+ Set_Sensitivity_List (Stmt, List);
+ end if;
+ end;
+
+ when Iir_Kind_Case_Statement =>
+ Canon_Expression (Get_Expression (Stmt));
+ declare
+ Choice: Iir;
+ begin
+ Choice := Get_Case_Statement_Alternative_Chain (Stmt);
+ while Choice /= Null_Iir loop
+ -- FIXME: canon choice expr.
+ Canon_Sequential_Stmts (Get_Associated_Chain (Choice));
+ Choice := Get_Chain (Choice);
+ end loop;
+ end;
+
+ when Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement =>
+ if Get_Kind (Stmt) = Iir_Kind_Assertion_Statement then
+ Canon_Expression (Get_Assertion_Condition (Stmt));
+ end if;
+ Expr := Get_Report_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Canon_Expression (Expr);
+ end if;
+ Expr := Get_Severity_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Canon_Expression (Expr);
+ end if;
+
+ when Iir_Kind_For_Loop_Statement =>
+ -- FIXME: decl.
+ Prev_Loop := Cur_Loop;
+ Cur_Loop := Stmt;
+ if Canon_Flag_Expressions then
+ Canon_Discrete_Range
+ (Get_Type (Get_Parameter_Specification (Stmt)));
+ end if;
+ Canon_Sequential_Stmts (Get_Sequential_Statement_Chain (Stmt));
+ Cur_Loop := Prev_Loop;
+
+ when Iir_Kind_While_Loop_Statement =>
+ Expr := Get_Condition (Stmt);
+ if Expr /= Null_Iir then
+ Canon_Expression (Expr);
+ end if;
+ Prev_Loop := Cur_Loop;
+ Cur_Loop := Stmt;
+ Canon_Sequential_Stmts (Get_Sequential_Statement_Chain (Stmt));
+ Cur_Loop := Prev_Loop;
+
+ when Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement =>
+ declare
+ Loop_Label : Iir;
+ begin
+ Expr := Get_Condition (Stmt);
+ if Expr /= Null_Iir then
+ Canon_Expression (Expr);
+ end if;
+ Loop_Label := Get_Loop_Label (Stmt);
+ if Loop_Label = Null_Iir then
+ Set_Loop_Label (Stmt, Build_Simple_Name (Cur_Loop, Stmt));
+ end if;
+ end;
+
+ when Iir_Kind_Procedure_Call_Statement =>
+ Canon_Subprogram_Call_And_Actuals (Get_Procedure_Call (Stmt));
+
+ when Iir_Kind_Null_Statement =>
+ null;
+
+ when Iir_Kind_Return_Statement =>
+ Canon_Expression (Get_Expression (Stmt));
+
+ when others =>
+ Error_Kind ("canon_sequential_stmts", Stmt);
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Canon_Sequential_Stmts;
+
+ -- Create a statement transform from concurrent_signal_assignment
+ -- statement STMT (either selected or conditional).
+ -- waveform transformation is not done.
+ -- PROC is the process created.
+ -- PARENT is the place where signal assignment must be placed. This may
+ -- be PROC, or an 'if' statement if the assignment is guarded.
+ -- See LRM93 9.5
+ procedure Canon_Concurrent_Signal_Assignment
+ (Stmt: Iir;
+ Proc: out Iir_Sensitized_Process_Statement;
+ Chain : out Iir)
+ is
+ If_Stmt: Iir;
+ Sensitivity_List : Iir_List;
+ begin
+ Proc := Create_Iir (Iir_Kind_Sensitized_Process_Statement);
+ Location_Copy (Proc, Stmt);
+ Set_Parent (Proc, Get_Parent (Stmt));
+ Sensitivity_List := Create_Iir_List;
+ Set_Sensitivity_List (Proc, Sensitivity_List);
+ Set_Process_Origin (Proc, Stmt);
+
+ -- LRM93 9.5
+ -- 1. If a label appears on the concurrent signal assignment, then the
+ -- same label appears on the process statement.
+ Set_Label (Proc, Get_Label (Stmt));
+
+ -- LRM93 9.5
+ -- 2. The equivalent process statement is a postponed process if and
+ -- only if the current signal assignment statement includes the
+ -- reserved word POSTPONED.
+ Set_Postponed_Flag (Proc, Get_Postponed_Flag (Proc));
+
+ Canon_Extract_Sensitivity (Get_Target (Stmt), Sensitivity_List, True);
+
+ if Canon_Flag_Expressions then
+ Canon_Expression (Get_Target (Stmt));
+ end if;
+
+ if Get_Guard (Stmt) /= Null_Iir then
+ -- LRM93 9.1
+ -- If the option guarded appears in the concurrent signal assignment
+ -- statement, then the concurrent signal assignment is called a
+ -- guarded assignment.
+ -- If the concurrent signal assignement statement is a guarded
+ -- assignment and the target of the concurrent signal assignment is
+ -- a guarded target, then the statement transform is as follow:
+ -- if GUARD then signal_transform else disconnect_statements end if;
+ -- Otherwise, if the concurrent signal assignment statement is a
+ -- guarded assignement, but the target if the concurrent signal
+ -- assignment is not a guarded target, the then statement transform
+ -- is as follows:
+ -- if GUARD then signal_transform end if;
+ If_Stmt := Create_Iir (Iir_Kind_If_Statement);
+ Set_Parent (If_Stmt, Proc);
+ Set_Sequential_Statement_Chain (Proc, If_Stmt);
+ Location_Copy (If_Stmt, Stmt);
+ Canon_Extract_Sensitivity (Get_Guard (Stmt), Sensitivity_List, False);
+ Set_Condition (If_Stmt, Get_Guard (Stmt));
+ Chain := If_Stmt;
+
+ declare
+ Target : Iir;
+ Else_Clause : Iir_Elsif;
+ Dis_Stmt : Iir_Signal_Assignment_Statement;
+ begin
+ Target := Get_Target (Stmt);
+ if Get_Guarded_Target_State (Stmt) = True then
+ -- The target is a guarded target.
+ -- create the disconnection statement.
+ Else_Clause := Create_Iir (Iir_Kind_Elsif);
+ Location_Copy (Else_Clause, Stmt);
+ Set_Else_Clause (If_Stmt, Else_Clause);
+ Dis_Stmt := Create_Iir (Iir_Kind_Signal_Assignment_Statement);
+ Location_Copy (Dis_Stmt, Stmt);
+ Set_Parent (Dis_Stmt, If_Stmt);
+ Set_Target (Dis_Stmt, Target);
+ Set_Sequential_Statement_Chain (Else_Clause, Dis_Stmt);
+ -- XX
+ Set_Waveform_Chain (Dis_Stmt, Null_Iir);
+ end if;
+ end;
+ else
+ -- LRM93 9.1
+ -- Finally, if the concurrent signal assignment statement is not a
+ -- guarded assignment, and the traget of the concurrent signal
+ -- assignment is not a guarded target, then the statement transform
+ -- is as follows:
+ -- signal_transform
+ Chain := Proc;
+ end if;
+ end Canon_Concurrent_Signal_Assignment;
+
+ function Canon_Concurrent_Procedure_Call (El : Iir)
+ return Iir_Sensitized_Process_Statement
+ is
+ Proc : Iir_Sensitized_Process_Statement;
+ Call_Stmt : Iir_Procedure_Call_Statement;
+ Wait_Stmt : Iir_Wait_Statement;
+ Call : constant Iir_Procedure_Call := Get_Procedure_Call (El);
+ Imp : constant Iir := Get_Implementation (Call);
+ Assoc_Chain : Iir;
+ Assoc : Iir;
+ Inter : Iir;
+ Sensitivity_List : Iir_List;
+ Is_Sensitized : Boolean;
+ begin
+ -- Optimization: the process is a sensitized process only if the
+ -- procedure is known not to have wait statement.
+ Is_Sensitized := Get_Wait_State (Imp) = False;
+
+ -- LRM93 9.3
+ -- The equivalent process statement has also no sensitivity list, an
+ -- empty declarative part, and a statement part that consists of a
+ -- procedure call statement followed by a wait statement.
+ if Is_Sensitized then
+ Proc := Create_Iir (Iir_Kind_Sensitized_Process_Statement);
+ else
+ Proc := Create_Iir (Iir_Kind_Process_Statement);
+ end if;
+ Location_Copy (Proc, El);
+ Set_Parent (Proc, Get_Parent (El));
+ Set_Process_Origin (Proc, El);
+
+ -- LRM93 9.3
+ -- The equivalent process statement has a label if and only if the
+ -- concurrent procedure call statement has a label; if the equivalent
+ -- process statement has a label, it is the same as that of the
+ -- concurrent procedure call statement.
+ Set_Label (Proc, Get_Label (El));
+
+ -- LRM93 9.3
+ -- The equivalent process statement is a postponed process if and only
+ -- if the concurrent procedure call statement includes the reserved
+ -- word POSTPONED.
+ Set_Postponed_Flag (Proc, Get_Postponed_Flag (El));
+
+ Set_Attribute_Value_Chain (Proc, Get_Attribute_Value_Chain (El));
+
+ Call_Stmt := Create_Iir (Iir_Kind_Procedure_Call_Statement);
+ Set_Sequential_Statement_Chain (Proc, Call_Stmt);
+ Location_Copy (Call_Stmt, El);
+ Set_Parent (Call_Stmt, Proc);
+ Set_Procedure_Call (Call_Stmt, Call);
+ Assoc_Chain := Canon_Association_Chain_And_Actuals
+ (Get_Interface_Declaration_Chain (Imp),
+ Get_Parameter_Association_Chain (Call),
+ Call);
+ Set_Parameter_Association_Chain (Call, Assoc_Chain);
+ Assoc := Assoc_Chain;
+
+ -- LRM93 9.3
+ -- If there exists a name that denotes a signal in the actual part of
+ -- any association element in the concurrent procedure call statement,
+ -- and that actual is associated with a formal parameter of mode IN or
+ -- INOUT, then the equivalent process statement includes a final wait
+ -- statement with a sensitivity clause that is constructed by taking
+ -- the union of the sets constructed by applying th rule of Section 8.1
+ -- to each actual part associated with a formal parameter.
+ Sensitivity_List := Create_Iir_List;
+ while Assoc /= Null_Iir loop
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_By_Expression =>
+ Inter := Get_Association_Interface (Assoc);
+ if Get_Mode (Inter) in Iir_In_Modes then
+ Canon_Extract_Sensitivity
+ (Get_Actual (Assoc), Sensitivity_List, False);
+ end if;
+ when Iir_Kind_Association_Element_Open
+ | Iir_Kind_Association_Element_By_Individual =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ if Is_Sensitized then
+ Set_Sensitivity_List (Proc, Sensitivity_List);
+ else
+ Wait_Stmt := Create_Iir (Iir_Kind_Wait_Statement);
+ Location_Copy (Wait_Stmt, El);
+ Set_Parent (Wait_Stmt, Proc);
+ Set_Sensitivity_List (Wait_Stmt, Sensitivity_List);
+ Set_Chain (Call_Stmt, Wait_Stmt);
+ end if;
+ return Proc;
+ end Canon_Concurrent_Procedure_Call;
+
+ -- Return a statement from a waveform.
+ function Canon_Wave_Transform
+ (Orig_Stmt : Iir; Waveform_Chain : Iir_Waveform_Element; Proc : Iir)
+ return Iir
+ is
+ Stmt : Iir;
+ begin
+ if Waveform_Chain = Null_Iir then
+ -- LRM 9.5.1 Conditionnal Signal Assignment
+ -- If the waveform is of the form:
+ -- UNAFFECTED
+ -- then the wave transform in the corresponding process statement
+ -- is of the form:
+ -- NULL;
+ -- In this example, the final NULL causes the driver to be unchanged,
+ -- rather than disconnected.
+ -- (This is the null statement not a null waveform element).
+ Stmt := Create_Iir (Iir_Kind_Null_Statement);
+ else
+ -- LRM 9.5.1 Conditionnal Signal Assignment
+ -- If the waveform is of the form:
+ -- waveform_element1, waveform_element1, ..., waveform_elementN
+ -- then the wave transform in the corresponding process statement is
+ -- of the form:
+ -- target <= [ delay_mechanism ] waveform_element1,
+ -- waveform_element2, ..., waveform_elementN;
+ Stmt := Create_Iir (Iir_Kind_Signal_Assignment_Statement);
+ Set_Target (Stmt, Get_Target (Orig_Stmt));
+ Canon_Waveform_Chain (Waveform_Chain, Get_Sensitivity_List (Proc));
+ Set_Waveform_Chain (Stmt, Waveform_Chain);
+ Set_Delay_Mechanism (Stmt, Get_Delay_Mechanism (Orig_Stmt));
+ Set_Reject_Time_Expression
+ (Stmt, Get_Reject_Time_Expression (Orig_Stmt));
+ end if;
+ Location_Copy (Stmt, Orig_Stmt);
+ return Stmt;
+ end Canon_Wave_Transform;
+
+ -- Create signal_transform for a conditional concurrent signal assignment.
+ procedure Canon_Conditional_Concurrent_Signal_Assigment
+ (Conc_Stmt : Iir; Proc : Iir; Parent : Iir)
+ is
+ Expr : Iir;
+ Stmt : Iir;
+ Res1 : Iir;
+ Last_Res : Iir;
+ Wf : Iir;
+ Cond_Wf : Iir_Conditional_Waveform;
+ Cond_Wf_Chain : Iir_Conditional_Waveform;
+ begin
+ Cond_Wf_Chain := Get_Conditional_Waveform_Chain (Conc_Stmt);
+ Stmt := Null_Iir;
+ Cond_Wf := Cond_Wf_Chain;
+ Last_Res := Null_Iir;
+
+ while Cond_Wf /= Null_Iir loop
+ Expr := Get_Condition (Cond_Wf);
+ Wf := Canon_Wave_Transform
+ (Conc_Stmt, Get_Waveform_Chain (Cond_Wf), Proc);
+ Set_Parent (Wf, Parent);
+ if Expr = Null_Iir and Cond_Wf = Cond_Wf_Chain then
+ Res1 := Wf;
+ else
+ if Expr /= Null_Iir then
+ if Canon_Flag_Expressions then
+ Canon_Expression (Expr);
+ end if;
+ Canon_Extract_Sensitivity
+ (Expr, Get_Sensitivity_List (Proc), False);
+ end if;
+ if Stmt = Null_Iir then
+ Res1 := Create_Iir (Iir_Kind_If_Statement);
+ Set_Parent (Res1, Parent);
+ else
+ Res1 := Create_Iir (Iir_Kind_Elsif);
+ end if;
+ Location_Copy (Res1, Cond_Wf);
+ Set_Condition (Res1, Expr);
+ Set_Sequential_Statement_Chain (Res1, Wf);
+ end if;
+ if Stmt = Null_Iir then
+ Stmt := Res1;
+ else
+ Set_Else_Clause (Last_Res, Res1);
+ end if;
+ Last_Res := Res1;
+ Cond_Wf := Get_Chain (Cond_Wf);
+ end loop;
+ Set_Sequential_Statement_Chain (Parent, Stmt);
+ end Canon_Conditional_Concurrent_Signal_Assigment;
+
+ procedure Canon_Selected_Concurrent_Signal_Assignment
+ (Conc_Stmt : Iir; Proc : Iir; Parent : Iir)
+ is
+ Selected_Waveform : Iir;
+ Case_Stmt: Iir_Case_Statement;
+ Expr : Iir;
+ Stmt : Iir;
+ Assoc : Iir;
+ begin
+ Case_Stmt := Create_Iir (Iir_Kind_Case_Statement);
+ Set_Parent (Case_Stmt, Parent);
+ Set_Sequential_Statement_Chain (Parent, Case_Stmt);
+ Location_Copy (Case_Stmt, Conc_Stmt);
+ Expr := Get_Expression (Conc_Stmt);
+ if Canon_Flag_Expressions then
+ Canon_Expression (Expr);
+ end if;
+ Set_Expression (Case_Stmt, Expr);
+ Canon_Extract_Sensitivity
+ (Expr, Get_Sensitivity_List (Proc), False);
+
+ Selected_Waveform := Get_Selected_Waveform_Chain (Conc_Stmt);
+ Set_Case_Statement_Alternative_Chain (Case_Stmt, Selected_Waveform);
+ while Selected_Waveform /= Null_Iir loop
+ Assoc := Get_Associated_Chain (Selected_Waveform);
+ if Assoc /= Null_Iir then
+ Stmt := Canon_Wave_Transform (Conc_Stmt, Assoc, Proc);
+ Set_Parent (Stmt, Case_Stmt);
+ Set_Associated_Chain (Selected_Waveform, Stmt);
+ end if;
+ Selected_Waveform := Get_Chain (Selected_Waveform);
+ end loop;
+ end Canon_Selected_Concurrent_Signal_Assignment;
+
+ procedure Canon_Concurrent_Stmts (Top : Iir_Design_Unit; Parent : Iir)
+ is
+ -- Current element in the chain of concurrent statements.
+ El: Iir;
+ -- Previous element or NULL_IIR if EL is the first element.
+ -- This is used to make Replace_Stmt efficient.
+ Prev_El : Iir;
+
+ -- Replace in the chain EL by N_STMT.
+ procedure Replace_Stmt (N_Stmt : Iir) is
+ begin
+ if Prev_El = Null_Iir then
+ Set_Concurrent_Statement_Chain (Parent, N_Stmt);
+ else
+ Set_Chain (Prev_El, N_Stmt);
+ end if;
+ Set_Chain (N_Stmt, Get_Chain (El));
+ end Replace_Stmt;
+
+ Proc: Iir;
+ Stmt: Iir;
+ Sub_Chain : Iir;
+ Expr: Iir;
+ Proc_Num : Natural := 0;
+ Sensitivity_List : Iir_List;
+ begin
+ Prev_El := Null_Iir;
+ El := Get_Concurrent_Statement_Chain (Parent);
+ while El /= Null_Iir loop
+ -- Add a label if required.
+ if Canon_Flag_Add_Labels then
+ case Get_Kind (El) is
+ when Iir_Kind_Psl_Declaration =>
+ null;
+ when others =>
+ if Get_Label (El) = Null_Identifier then
+ declare
+ Str : String := Natural'Image (Proc_Num);
+ begin
+ -- Note: the label starts with a capitalized letter,
+ -- to avoid any clash with user's identifiers.
+ Str (1) := 'P';
+ Set_Label (El, Name_Table.Get_Identifier (Str));
+ end;
+ Proc_Num := Proc_Num + 1;
+ end if;
+ end case;
+ end if;
+
+ case Get_Kind (El) is
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment =>
+ Canon_Concurrent_Signal_Assignment (El, Proc, Sub_Chain);
+
+ Canon_Conditional_Concurrent_Signal_Assigment
+ (El, Proc, Sub_Chain);
+
+ Replace_Stmt (Proc);
+ Free_Iir (El);
+ El := Proc;
+
+ when Iir_Kind_Concurrent_Selected_Signal_Assignment =>
+ Canon_Concurrent_Signal_Assignment (El, Proc, Sub_Chain);
+
+ Canon_Selected_Concurrent_Signal_Assignment
+ (El, Proc, Sub_Chain);
+
+ Replace_Stmt (Proc);
+ Free_Iir (El);
+ El := Proc;
+
+ when Iir_Kind_Concurrent_Assertion_Statement =>
+ -- Create a new entry.
+ Proc := Create_Iir (Iir_Kind_Sensitized_Process_Statement);
+ Location_Copy (Proc, El);
+ Set_Parent (Proc, Get_Parent (El));
+ Set_Process_Origin (Proc, El);
+
+ -- LRM93 9.4
+ -- The equivalent process statement has a label if and only if
+ -- the current assertion statement has a label; if the
+ -- equivalent process statement has a label; it is the same
+ -- as that of the concurrent assertion statement.
+ Set_Label (Proc, Get_Label (El));
+
+ -- LRM93 9.4
+ -- The equivalent process statement is a postponed process if
+ -- and only if the current assertion statement includes the
+ -- reserved word POSTPONED.
+ Set_Postponed_Flag (Proc, Get_Postponed_Flag (El));
+
+ Stmt := Create_Iir (Iir_Kind_Assertion_Statement);
+ Set_Sequential_Statement_Chain (Proc, Stmt);
+ Set_Parent (Stmt, Proc);
+ Location_Copy (Stmt, El);
+ Sensitivity_List := Create_Iir_List;
+ Set_Sensitivity_List (Proc, Sensitivity_List);
+
+ -- Expand the expression, fill the sensitivity list,
+ Canon_Extract_Sensitivity
+ (Get_Assertion_Condition (El), Sensitivity_List, False);
+ if Canon_Flag_Expressions then
+ Canon_Expression (Get_Assertion_Condition (El));
+ end if;
+ Set_Assertion_Condition
+ (Stmt, Get_Assertion_Condition (El));
+
+ Expr := Get_Report_Expression (El);
+ if Canon_Flag_Expressions and Expr /= Null_Iir then
+ Canon_Expression (Expr);
+ end if;
+ Set_Report_Expression (Stmt, Expr);
+
+ Expr := Get_Severity_Expression (El);
+ if Canon_Flag_Expressions and Expr /= Null_Iir then
+ Canon_Expression (Expr);
+ end if;
+ Set_Severity_Expression (Stmt, Expr);
+
+ Replace_Stmt (Proc);
+ El := Proc;
+
+ when Iir_Kind_Concurrent_Procedure_Call_Statement =>
+ Proc := Canon_Concurrent_Procedure_Call (El);
+ Replace_Stmt (Proc);
+ El := Proc;
+
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ Canon_Declarations (Top, El, Null_Iir);
+ if Canon_Flag_Sequentials_Stmts then
+ Canon_Sequential_Stmts (Get_Sequential_Statement_Chain (El));
+ end if;
+ if Canon_Flag_All_Sensitivity
+ and then Canon_Flag_Sequentials_Stmts
+ and then Get_Kind (El) = Iir_Kind_Sensitized_Process_Statement
+ and then Get_Sensitivity_List (El) = Iir_List_All
+ then
+ Set_Sensitivity_List
+ (El, Canon_Extract_Process_Sensitivity (El));
+ end if;
+
+ when Iir_Kind_Component_Instantiation_Statement =>
+ declare
+ Inst : Iir;
+ Assoc_Chain : Iir;
+ begin
+ Inst := Get_Instantiated_Unit (El);
+ Inst := Get_Entity_From_Entity_Aspect (Inst);
+ Assoc_Chain := Canon_Association_Chain_And_Actuals
+ (Get_Generic_Chain (Inst),
+ Get_Generic_Map_Aspect_Chain (El),
+ El);
+ Set_Generic_Map_Aspect_Chain (El, Assoc_Chain);
+
+ Assoc_Chain := Canon_Association_Chain_And_Actuals
+ (Get_Port_Chain (Inst),
+ Get_Port_Map_Aspect_Chain (El),
+ El);
+ Set_Port_Map_Aspect_Chain (El, Assoc_Chain);
+ end;
+
+ when Iir_Kind_Block_Statement =>
+ declare
+ Header : Iir_Block_Header;
+ Chain : Iir;
+ Guard : Iir_Guard_Signal_Declaration;
+ begin
+ Guard := Get_Guard_Decl (El);
+ if Guard /= Null_Iir then
+ Expr := Get_Guard_Expression (Guard);
+ Set_Guard_Sensitivity_List (Guard, Create_Iir_List);
+ Canon_Extract_Sensitivity
+ (Expr, Get_Guard_Sensitivity_List (Guard), False);
+ if Canon_Flag_Expressions then
+ Canon_Expression (Expr);
+ end if;
+ end if;
+ Header := Get_Block_Header (El);
+ if Header /= Null_Iir then
+ -- Generics.
+ Chain := Get_Generic_Map_Aspect_Chain (Header);
+ if Chain /= Null_Iir then
+ Chain := Canon_Association_Chain_And_Actuals
+ (Get_Generic_Chain (Header), Chain, Chain);
+ else
+ Chain := Canon_Default_Association_Chain
+ (Get_Generic_Chain (Header));
+ end if;
+ Set_Generic_Map_Aspect_Chain (Header, Chain);
+
+ -- Ports.
+ Chain := Get_Port_Map_Aspect_Chain (Header);
+ if Chain /= Null_Iir then
+ Chain := Canon_Association_Chain_And_Actuals
+ (Get_Port_Chain (Header), Chain, Chain);
+ else
+ Chain := Canon_Default_Association_Chain
+ (Get_Port_Chain (Header));
+ end if;
+ Set_Port_Map_Aspect_Chain (Header, Chain);
+ end if;
+ Canon_Declarations (Top, El, El);
+ Canon_Concurrent_Stmts (Top, El);
+ end;
+
+ when Iir_Kind_Generate_Statement =>
+ declare
+ Scheme : Iir;
+ begin
+ Scheme := Get_Generation_Scheme (El);
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Canon_Declaration (Top, Scheme, Null_Iir, Null_Iir);
+ elsif Canon_Flag_Expressions then
+ Canon_Expression (Scheme);
+ end if;
+ Canon_Declarations (Top, El, El);
+ Canon_Concurrent_Stmts (Top, El);
+ end;
+
+ when Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement =>
+ declare
+ use PSL.Nodes;
+ Prop : PSL_Node;
+ Fa : PSL_NFA;
+ begin
+ Prop := Get_Psl_Property (El);
+ Prop := PSL.Rewrites.Rewrite_Property (Prop);
+ Set_Psl_Property (El, Prop);
+ -- Generate the NFA.
+ Fa := PSL.Build.Build_FA (Prop);
+ Set_PSL_NFA (El, Fa);
+
+ -- FIXME: report/severity.
+ end;
+
+ when Iir_Kind_Psl_Default_Clock =>
+ null;
+ when Iir_Kind_Psl_Declaration =>
+ declare
+ use PSL.Nodes;
+ Decl : PSL_Node;
+ Prop : PSL_Node;
+ Fa : PSL_NFA;
+ begin
+ Decl := Get_Psl_Declaration (El);
+ case Get_Kind (Decl) is
+ when N_Property_Declaration =>
+ Prop := Get_Property (Decl);
+ Prop := PSL.Rewrites.Rewrite_Property (Prop);
+ Set_Property (Decl, Prop);
+ if Get_Parameter_List (Decl) = Null_Node then
+ -- Generate the NFA.
+ Fa := PSL.Build.Build_FA (Prop);
+ Set_PSL_NFA (El, Fa);
+ end if;
+ when N_Sequence_Declaration
+ | N_Endpoint_Declaration =>
+ Prop := Get_Sequence (Decl);
+ Prop := PSL.Rewrites.Rewrite_SERE (Prop);
+ Set_Sequence (Decl, Prop);
+ when others =>
+ Error_Kind ("canon psl_declaration", Decl);
+ end case;
+ end;
+
+ when Iir_Kind_Simple_Simultaneous_Statement =>
+ if Canon_Flag_Expressions then
+ Canon_Expression (Get_Simultaneous_Left (El));
+ Canon_Expression (Get_Simultaneous_Right (El));
+ end if;
+
+ when others =>
+ Error_Kind ("canon_concurrent_stmts", El);
+ end case;
+ Prev_El := El;
+ El := Get_Chain (El);
+ end loop;
+ end Canon_Concurrent_Stmts;
+
+-- procedure Canon_Binding_Indication
+-- (Component: Iir; Binding : Iir_Binding_Indication)
+-- is
+-- List : Iir_Association_List;
+-- begin
+-- if Binding = Null_Iir then
+-- return;
+-- end if;
+-- List := Get_Generic_Map_Aspect_List (Binding);
+-- List := Canon_Association_List (Get_Generic_List (Component), List);
+-- Set_Generic_Map_Aspect_List (Binding, List);
+-- List := Get_Port_Map_Aspect_List (Binding);
+-- List := Canon_Association_List (Get_Port_List (Component), List);
+-- Set_Port_Map_Aspect_List (Binding, List);
+-- end Canon_Binding_Indication;
+
+ procedure Add_Binding_Indication_Dependence (Top : Iir_Design_Unit;
+ Binding : Iir)
+ is
+ Aspect : Iir;
+ begin
+ if Binding = Null_Iir then
+ return;
+ end if;
+ Aspect := Get_Entity_Aspect (Binding);
+ if Aspect = Null_Iir then
+ return;
+ end if;
+ case Get_Kind (Aspect) is
+ when Iir_Kind_Entity_Aspect_Entity =>
+ if Get_Architecture (Aspect) /= Null_Iir then
+ Add_Dependence (Top, Aspect);
+ else
+ Add_Dependence (Top, Get_Design_Unit (Get_Entity (Aspect)));
+ end if;
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ Add_Dependence (Top, Get_Design_Unit (Get_Configuration (Aspect)));
+ when Iir_Kind_Entity_Aspect_Open =>
+ null;
+ when others =>
+ Error_Kind ("add_binding_indication_dependence", Aspect);
+ end case;
+ end Add_Binding_Indication_Dependence;
+
+ -- Canon the component_configuration or configuration_specification CFG.
+ procedure Canon_Component_Configuration (Top : Iir_Design_Unit; Cfg : Iir)
+ is
+ -- True iff CFG is a component_configuration.
+ -- False iff CFG is a configuration_specification.
+ Is_Config : constant Boolean :=
+ Get_Kind (Cfg) = Iir_Kind_Component_Configuration;
+
+ Bind : Iir;
+ Instances : Iir_List;
+ Entity_Aspect : Iir;
+ Block : Iir_Block_Configuration;
+ Map_Chain : Iir;
+ Entity : Iir;
+ begin
+ Bind := Get_Binding_Indication (Cfg);
+ if Bind = Null_Iir then
+ -- Add a default binding indication
+ -- Extract a component instantiation
+ Instances := Get_Instantiation_List (Cfg);
+ if Instances = Iir_List_All or Instances = Iir_List_Others then
+ -- designator_all and designator_others must have been replaced
+ -- by a list during canon.
+ raise Internal_Error;
+ else
+ Bind := Get_Default_Binding_Indication
+ (Get_Named_Entity (Get_First_Element (Instances)));
+ end if;
+ if Bind = Null_Iir then
+ -- Component is not bound.
+ return;
+ end if;
+ Set_Binding_Indication (Cfg, Bind);
+ Add_Binding_Indication_Dependence (Top, Bind);
+ return;
+ else
+ Entity_Aspect := Get_Entity_Aspect (Bind);
+ if Entity_Aspect = Null_Iir then
+ Entity_Aspect := Get_Default_Entity_Aspect (Bind);
+ Set_Entity_Aspect (Bind, Entity_Aspect);
+ end if;
+ if Entity_Aspect /= Null_Iir then
+ Add_Binding_Indication_Dependence (Top, Bind);
+ Entity := Get_Entity_From_Entity_Aspect (Entity_Aspect);
+ Map_Chain := Get_Generic_Map_Aspect_Chain (Bind);
+ if Map_Chain = Null_Iir then
+ if Is_Config then
+ Map_Chain := Get_Default_Generic_Map_Aspect_Chain (Bind);
+ end if;
+ else
+ Map_Chain := Canon_Association_Chain
+ (Get_Generic_Chain (Entity), Map_Chain, Map_Chain);
+ end if;
+ Set_Generic_Map_Aspect_Chain (Bind, Map_Chain);
+
+ Map_Chain := Get_Port_Map_Aspect_Chain (Bind);
+ if Map_Chain = Null_Iir then
+ if Is_Config then
+ Map_Chain := Get_Default_Port_Map_Aspect_Chain (Bind);
+ end if;
+ else
+ Map_Chain := Canon_Association_Chain
+ (Get_Port_Chain (Entity), Map_Chain, Map_Chain);
+ end if;
+ Set_Port_Map_Aspect_Chain (Bind, Map_Chain);
+
+ if Get_Kind (Cfg) = Iir_Kind_Component_Configuration then
+ Block := Get_Block_Configuration (Cfg);
+ if Block /= Null_Iir then
+ -- If there is no architecture_identifier in the binding,
+ -- set it from the block_configuration.
+ if Get_Kind (Entity_Aspect) = Iir_Kind_Entity_Aspect_Entity
+ and then Get_Architecture (Entity_Aspect) = Null_Iir
+ then
+ Entity := Get_Entity (Entity_Aspect);
+ if Get_Kind (Entity) /= Iir_Kind_Entity_Declaration then
+ raise Internal_Error;
+ end if;
+ Set_Architecture
+ (Entity_Aspect, Get_Block_Specification (Block));
+ end if;
+ Canon_Block_Configuration (Top, Block);
+ end if;
+ end if;
+ end if;
+ end if;
+ end Canon_Component_Configuration;
+
+ procedure Canon_Incremental_Binding
+ (Conf_Spec : Iir_Configuration_Specification;
+ Comp_Conf : Iir_Component_Configuration;
+ Parent : Iir)
+ is
+ function Merge_Association_Chain
+ (Inter_Chain : Iir; First_Chain : Iir; Sec_Chain : Iir)
+ return Iir
+ is
+ -- Result (chain).
+ First, Last : Iir;
+
+ -- Copy an association and append new elements to FIRST/LAST.
+ procedure Copy_Association (Assoc : in out Iir; Inter : Iir)
+ is
+ El : Iir;
+ begin
+ loop
+ El := Create_Iir (Get_Kind (Assoc));
+ Location_Copy (El, Assoc);
+ Set_Formal (El, Get_Formal (Assoc));
+ Set_Whole_Association_Flag
+ (El, Get_Whole_Association_Flag (Assoc));
+
+ case Get_Kind (Assoc) is
+ when Iir_Kind_Association_Element_Open =>
+ null;
+ when Iir_Kind_Association_Element_By_Expression =>
+ Set_Actual (El, Get_Actual (Assoc));
+ Set_In_Conversion (El, Get_In_Conversion (Assoc));
+ Set_Out_Conversion (El, Get_Out_Conversion (Assoc));
+ Set_Collapse_Signal_Flag
+ (Assoc,
+ Sem.Can_Collapse_Signals (Assoc, Get_Formal (Assoc)));
+ when Iir_Kind_Association_Element_By_Individual =>
+ Set_Actual_Type (El, Get_Actual_Type (Assoc));
+ Set_Individual_Association_Chain
+ (El, Get_Individual_Association_Chain (Assoc));
+ when others =>
+ Error_Kind ("copy_association", Assoc);
+ end case;
+
+ Sub_Chain_Append (First, Last, El);
+ Assoc := Get_Chain (Assoc);
+ exit when Assoc = Null_Iir;
+ exit when Get_Association_Interface (Assoc) /= Inter;
+ end loop;
+ end Copy_Association;
+
+ procedure Advance (Assoc : in out Iir; Inter : Iir)
+ is
+ begin
+ loop
+ Assoc := Get_Chain (Assoc);
+ exit when Assoc = Null_Iir;
+ exit when Get_Association_Interface (Assoc) /= Inter;
+ end loop;
+ end Advance;
+
+ Inter : Iir;
+ F_El : Iir;
+ S_El : Iir;
+ begin
+ if Sec_Chain = Null_Iir then
+ -- Short-cut.
+ return First_Chain;
+ end if;
+ F_El := First_Chain;
+ Sub_Chain_Init (First, Last);
+ Inter := Inter_Chain;
+ while Inter /= Null_Iir loop
+ -- Consistency check.
+ pragma Assert (Get_Association_Interface (F_El) = Inter);
+
+ -- Find the associated in the second chain.
+ S_El := Sec_Chain;
+ while S_El /= Null_Iir loop
+ exit when Get_Association_Interface (S_El) = Inter;
+ S_El := Get_Chain (S_El);
+ end loop;
+ if S_El /= Null_Iir
+ and then Get_Kind (S_El) /= Iir_Kind_Association_Element_Open
+ then
+ Copy_Association (S_El, Inter);
+ Advance (F_El, Inter);
+ else
+ Copy_Association (F_El, Inter);
+ end if;
+ Inter := Get_Chain (Inter);
+ end loop;
+ return First;
+ end Merge_Association_Chain;
+
+ Res : Iir_Component_Configuration;
+ Cs_Binding : Iir_Binding_Indication;
+ Cc_Binding : Iir_Binding_Indication;
+ Cs_Chain : Iir;
+ Res_Binding : Iir_Binding_Indication;
+ Entity : Iir;
+ Instance_List : Iir_List;
+ Conf_Instance_List : Iir_List;
+ Instance : Iir;
+ Instance_Name : Iir;
+ N_Nbr : Natural;
+ begin
+ -- Create the new component configuration
+ Res := Create_Iir (Iir_Kind_Component_Configuration);
+ Location_Copy (Res, Comp_Conf);
+ Set_Parent (Res, Parent);
+ Set_Component_Name (Res, Get_Component_Name (Conf_Spec));
+
+-- -- Keep in the designator list only the non-incrementally
+-- -- bound instances.
+-- Inst_List := Get_Instantiation_List (Comp_Conf);
+-- Designator_List := Create_Iir_List;
+-- for I in 0 .. Get_Nbr_Elements (Inst_List) - 1 loop
+-- Inst := Get_Nth_Element (Inst_List, I);
+-- if Get_Component_Configuration (Inst) = Comp_Conf then
+-- Set_Component_Configuration (Inst, Res);
+-- Append_Element (Designator_List, Inst);
+-- end if;
+-- end loop;
+-- Set_Instantiation_List (Res, Designator_List);
+-- Set_Binding_Indication
+-- (Res, Get_Binding_Indication (Comp_Conf));
+-- Append (Last_Item, Conf, Comp_Conf);
+
+ Cs_Binding := Get_Binding_Indication (Conf_Spec);
+ Cc_Binding := Get_Binding_Indication (Comp_Conf);
+ Res_Binding := Create_Iir (Iir_Kind_Binding_Indication);
+ Location_Copy (Res_Binding, Res);
+ Set_Binding_Indication (Res, Res_Binding);
+
+ Entity := Get_Entity_From_Entity_Aspect (Get_Entity_Aspect (Cs_Binding));
+
+ -- Merge generic map aspect.
+ Cs_Chain := Get_Generic_Map_Aspect_Chain (Cs_Binding);
+ if Cs_Chain = Null_Iir then
+ Cs_Chain := Get_Default_Generic_Map_Aspect_Chain (Cs_Binding);
+ end if;
+ Set_Generic_Map_Aspect_Chain
+ (Res_Binding,
+ Merge_Association_Chain (Get_Generic_Chain (Entity),
+ Cs_Chain,
+ Get_Generic_Map_Aspect_Chain (Cc_Binding)));
+
+ -- merge port map aspect
+ Cs_Chain := Get_Port_Map_Aspect_Chain (Cs_Binding);
+ if Cs_Chain = Null_Iir then
+ Cs_Chain := Get_Default_Port_Map_Aspect_Chain (Cs_Binding);
+ end if;
+ Set_Port_Map_Aspect_Chain
+ (Res_Binding,
+ Merge_Association_Chain (Get_Port_Chain (Entity),
+ Cs_Chain,
+ Get_Port_Map_Aspect_Chain (Cc_Binding)));
+
+ -- set entity aspect
+ Set_Entity_Aspect (Res_Binding, Get_Entity_Aspect (Cs_Binding));
+
+ -- create list of instances:
+ -- * keep common instances
+ -- replace component_configuration of them
+ -- remove them in the instance list of COMP_CONF
+ Instance_List := Create_Iir_List;
+ Set_Instantiation_List (Res, Instance_List);
+ Conf_Instance_List := Get_Instantiation_List (Comp_Conf);
+ N_Nbr := 0;
+ for I in 0 .. Get_Nbr_Elements (Conf_Instance_List) - 1 loop
+ Instance_Name := Get_Nth_Element (Conf_Instance_List, I);
+ Instance := Get_Named_Entity (Instance_Name);
+ if Get_Component_Configuration (Instance) = Conf_Spec then
+ -- The incremental binding applies to this instance.
+ Set_Component_Configuration (Instance, Res);
+ Append_Element (Instance_List, Instance_Name);
+ else
+ Replace_Nth_Element (Conf_Instance_List, N_Nbr, Instance_Name);
+ N_Nbr := N_Nbr + 1;
+ end if;
+ end loop;
+ Set_Nbr_Elements (Conf_Instance_List, N_Nbr);
+
+ -- Insert RES.
+ Set_Chain (Res, Get_Chain (Comp_Conf));
+ Set_Chain (Comp_Conf, Res);
+ end Canon_Incremental_Binding;
+
+ procedure Canon_Component_Specification_All_Others
+ (Conf : Iir; Parent : Iir; Spec : Iir_List; List : Iir_List; Comp : Iir)
+ is
+ El : Iir;
+ Comp_Conf : Iir;
+ begin
+ El := Get_Concurrent_Statement_Chain (Parent);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Component_Instantiation_Statement =>
+ if Is_Component_Instantiation (El)
+ and then Get_Named_Entity (Get_Instantiated_Unit (El)) = Comp
+ then
+ Comp_Conf := Get_Component_Configuration (El);
+ if Comp_Conf = Null_Iir then
+ -- The component is not yet configured.
+ Append_Element (List, Build_Simple_Name (El, El));
+ Set_Component_Configuration (El, Conf);
+ else
+ -- The component is already configured.
+ -- Handle incremental configuration.
+ if (Get_Kind (Comp_Conf)
+ = Iir_Kind_Configuration_Specification)
+ and then Spec = Iir_List_All
+ then
+ -- FIXME: handle incremental configuration.
+ raise Internal_Error;
+ end if;
+ if Spec = Iir_List_All then
+ -- Several component configuration for an instance.
+ -- Must have been caught by sem.
+ raise Internal_Error;
+ elsif Spec = Iir_List_Others then
+ null;
+ else
+ raise Internal_Error;
+ end if;
+ end if;
+ end if;
+ when Iir_Kind_Generate_Statement =>
+ if False
+ and then Vhdl_Std = Vhdl_87
+ and then
+ Get_Kind (Conf) = Iir_Kind_Configuration_Specification
+ then
+ Canon_Component_Specification_All_Others
+ (Conf, El, Spec, List, Comp);
+ end if;
+ when others =>
+ null;
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Canon_Component_Specification_All_Others;
+
+ procedure Canon_Component_Specification_List
+ (Conf : Iir; Parent : Iir; Spec : Iir_List)
+ is
+ El : Iir;
+ Comp_Conf : Iir;
+ begin
+ -- Already has a designator list.
+ for I in Natural loop
+ El := Get_Nth_Element (Spec, I);
+ exit when El = Null_Iir;
+ El := Get_Named_Entity (El);
+ Comp_Conf := Get_Component_Configuration (El);
+ if Comp_Conf /= Null_Iir and then Comp_Conf /= Conf then
+ if Get_Kind (Comp_Conf) /= Iir_Kind_Configuration_Specification
+ or else Get_Kind (Conf) /= Iir_Kind_Component_Configuration
+ then
+ raise Internal_Error;
+ end if;
+ Canon_Incremental_Binding (Comp_Conf, Conf, Parent);
+ else
+ Set_Component_Configuration (El, Conf);
+ end if;
+ end loop;
+ end Canon_Component_Specification_List;
+
+ -- PARENT is the parent for the chain of concurrent statements.
+ procedure Canon_Component_Specification (Conf : Iir; Parent : Iir)
+ is
+ Spec : constant Iir_List := Get_Instantiation_List (Conf);
+ List : Iir_Designator_List;
+ begin
+ if Spec = Iir_List_All or Spec = Iir_List_Others then
+ List := Create_Iir_List;
+ Canon_Component_Specification_All_Others
+ (Conf, Parent, Spec, List,
+ Get_Named_Entity (Get_Component_Name (Conf)));
+ Set_Instantiation_List (Conf, List);
+ else
+ -- Has Already a designator list.
+ Canon_Component_Specification_List (Conf, Parent, Spec);
+ end if;
+ end Canon_Component_Specification;
+
+ -- Replace ALL/OTHERS with the explicit list of signals.
+ procedure Canon_Disconnection_Specification
+ (Dis : Iir_Disconnection_Specification; Decl_Parent : Iir)
+ is
+ Signal_List : Iir_List;
+ Force : Boolean;
+ El : Iir;
+ N_List : Iir_Designator_List;
+ Dis_Type : Iir;
+ begin
+ if Canon_Flag_Expressions then
+ Canon_Expression (Get_Expression (Dis));
+ end if;
+ Signal_List := Get_Signal_List (Dis);
+ if Signal_List = Iir_List_All then
+ Force := True;
+ elsif Signal_List = Iir_List_Others then
+ Force := False;
+ else
+ return;
+ end if;
+ Dis_Type := Get_Type (Get_Type_Mark (Dis));
+ N_List := Create_Iir_List;
+ Set_Signal_List (Dis, N_List);
+ El := Get_Declaration_Chain (Decl_Parent);
+ while El /= Null_Iir loop
+ if Get_Kind (El) = Iir_Kind_Signal_Declaration
+ and then Get_Type (El) = Dis_Type
+ and then Get_Signal_Kind (El) /= Iir_No_Signal_Kind
+ then
+ if not Get_Has_Disconnect_Flag (El) then
+ Set_Has_Disconnect_Flag (El, True);
+ Append_Element (N_List, El);
+ else
+ if Force then
+ raise Internal_Error;
+ end if;
+ end if;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ end Canon_Disconnection_Specification;
+
+ procedure Canon_Subtype_Indication (Def : Iir) is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Array_Subtype_Definition =>
+ declare
+ Indexes : constant Iir_List := Get_Index_Subtype_List (Def);
+ Index : Iir;
+ begin
+ for I in Natural loop
+ Index := Get_Nth_Element (Indexes, I);
+ exit when Index = Null_Iir;
+ Canon_Subtype_Indication_If_Anonymous (Index);
+ end loop;
+ end;
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ declare
+ Rng : constant Iir := Get_Range_Constraint (Def);
+ begin
+ if Get_Kind (Rng) = Iir_Kind_Range_Expression then
+ Canon_Expression (Rng);
+ end if;
+ end;
+ when Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Record_Type_Definition =>
+ null;
+ when Iir_Kind_Access_Subtype_Definition =>
+ null;
+ when others =>
+ Error_Kind ("canon_subtype_indication", Def);
+ end case;
+ end Canon_Subtype_Indication;
+
+ procedure Canon_Subtype_Indication_If_Anonymous (Def : Iir) is
+ begin
+ if Is_Anonymous_Type_Definition (Def) then
+ Canon_Subtype_Indication (Def);
+ end if;
+ end Canon_Subtype_Indication_If_Anonymous;
+
+ procedure Canon_Declaration (Top : Iir_Design_Unit;
+ Decl : Iir;
+ Parent : Iir;
+ Decl_Parent : Iir)
+ is
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Procedure_Body
+ | Iir_Kind_Function_Body =>
+ Canon_Declarations (Top, Decl, Null_Iir);
+ if Canon_Flag_Sequentials_Stmts then
+ Canon_Sequential_Stmts (Get_Sequential_Statement_Chain (Decl));
+ end if;
+
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration =>
+ null;
+
+ when Iir_Kind_Type_Declaration =>
+ declare
+ Def : Iir;
+ begin
+ Def := Get_Type_Definition (Decl);
+ if Get_Kind (Def) = Iir_Kind_Protected_Type_Declaration then
+ Canon_Declarations (Decl, Def, Null_Iir);
+ end if;
+ end;
+
+ when Iir_Kind_Anonymous_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ null;
+
+ when Iir_Kind_Protected_Type_Body =>
+ Canon_Declarations (Top, Decl, Null_Iir);
+
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Constant_Declaration =>
+ if Canon_Flag_Expressions then
+ Canon_Subtype_Indication_If_Anonymous (Get_Type (Decl));
+ Canon_Expression (Get_Default_Value (Decl));
+ end if;
+
+ when Iir_Kind_Iterator_Declaration =>
+ null;
+
+ when Iir_Kind_Object_Alias_Declaration =>
+ null;
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ null;
+
+ when Iir_Kind_File_Declaration =>
+ -- FIXME
+ null;
+
+ when Iir_Kind_Attribute_Declaration =>
+ null;
+ when Iir_Kind_Attribute_Specification =>
+ if Canon_Flag_Expressions then
+ Canon_Expression (Get_Expression (Decl));
+ end if;
+ when Iir_Kind_Disconnection_Specification =>
+ Canon_Disconnection_Specification (Decl, Decl_Parent);
+
+ when Iir_Kind_Group_Template_Declaration =>
+ null;
+ when Iir_Kind_Group_Declaration =>
+ null;
+
+ when Iir_Kind_Use_Clause =>
+ null;
+
+ when Iir_Kind_Component_Declaration =>
+ null;
+
+ when Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Implicit_Function_Declaration =>
+ null;
+
+ when Iir_Kind_Configuration_Specification =>
+ Canon_Component_Specification (Decl, Parent);
+ Canon_Component_Configuration (Top, Decl);
+-- declare
+-- List : Iir_List;
+-- Binding : Iir_Binding_Indication;
+-- Component : Iir_Component_Declaration;
+-- Aspect : Iir;
+-- Entity : Iir;
+-- begin
+-- Binding := Get_Binding_Indication (Decl);
+-- Component := Get_Component_Name (Decl);
+-- Aspect := Get_Entity_Aspect (Binding);
+-- case Get_Kind (Aspect) is
+-- when Iir_Kind_Entity_Aspect_Entity =>
+-- Entity := Get_Entity (Aspect);
+-- when others =>
+-- Error_Kind ("configuration_specification", Aspect);
+-- end case;
+-- Entity := Get_Library_Unit (Entity);
+-- List := Get_Generic_Map_Aspect_List (Binding);
+-- if List = Null_Iir_List then
+-- Set_Generic_Map_Aspect_List
+-- (Binding,
+-- Canon_Default_Map_Association_List
+-- (Get_Generic_List (Entity), Get_Generic_List (Component),
+-- Get_Location (Decl)));
+-- end if;
+-- List := Get_Port_Map_Aspect_List (Binding);
+-- if List = Null_Iir_List then
+-- Set_Port_Map_Aspect_List
+-- (Binding,
+-- Canon_Default_Map_Association_List
+-- (Get_Port_List (Entity), Get_Port_List (Component),
+-- Get_Location (Decl)));
+-- end if;
+-- end;
+
+ when Iir_Kinds_Signal_Attribute =>
+ null;
+
+ when Iir_Kind_Nature_Declaration =>
+ null;
+ when Iir_Kind_Terminal_Declaration =>
+ null;
+ when Iir_Kinds_Quantity_Declaration =>
+ null;
+ when others =>
+ Error_Kind ("canon_declaration", Decl);
+ end case;
+ end Canon_Declaration;
+
+ procedure Canon_Declarations (Top : Iir_Design_Unit;
+ Decl_Parent : Iir;
+ Parent : Iir)
+ is
+ Decl : Iir;
+ begin
+ if Parent /= Null_Iir then
+ Clear_Instantiation_Configuration (Parent, True);
+ end if;
+ Decl := Get_Declaration_Chain (Decl_Parent);
+ while Decl /= Null_Iir loop
+ Canon_Declaration (Top, Decl, Parent, Decl_Parent);
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Canon_Declarations;
+
+ procedure Canon_Block_Configuration (Top : Iir_Design_Unit;
+ Conf : Iir_Block_Configuration)
+ is
+ use Iir_Chains.Configuration_Item_Chain_Handling;
+ Spec : constant Iir := Get_Block_Specification (Conf);
+ Blk : constant Iir := Get_Block_From_Block_Specification (Spec);
+ Stmts : constant Iir := Get_Concurrent_Statement_Chain (Blk);
+ El : Iir;
+ Sub_Blk : Iir;
+ Last_Item : Iir;
+ begin
+ -- Note: the only allowed declarations are use clauses, which are not
+ -- canonicalized.
+
+ -- FIXME: handle indexed/sliced name?
+
+ Clear_Instantiation_Configuration (Blk, False);
+
+ Build_Init (Last_Item, Conf);
+
+ -- 1) Configure instantiations with configuration specifications.
+ -- TODO: merge.
+ El := Get_Declaration_Chain (Blk);
+ while El /= Null_Iir loop
+ if Get_Kind (El) = Iir_Kind_Configuration_Specification then
+ -- Already canoncalized during canon of block declarations.
+ -- But need to set configuration on instantiations.
+ Canon_Component_Specification (El, Blk);
+ end if;
+ El := Get_Chain (El);
+ end loop;
+
+ -- 2) Configure instantations with component configurations,
+ -- and map block configurations with block/generate statements.
+ El := Get_Configuration_Item_Chain (Conf);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Configuration_Specification =>
+ raise Internal_Error;
+ when Iir_Kind_Component_Configuration =>
+ Canon_Component_Specification (El, Blk);
+ when Iir_Kind_Block_Configuration =>
+ Sub_Blk := Strip_Denoting_Name (Get_Block_Specification (El));
+ case Get_Kind (Sub_Blk) is
+ when Iir_Kind_Block_Statement =>
+ Set_Block_Block_Configuration (Sub_Blk, El);
+ when Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name =>
+ Sub_Blk := Strip_Denoting_Name (Get_Prefix (Sub_Blk));
+ Set_Prev_Block_Configuration
+ (El, Get_Generate_Block_Configuration (Sub_Blk));
+ Set_Generate_Block_Configuration (Sub_Blk, El);
+ when Iir_Kind_Generate_Statement =>
+ Set_Generate_Block_Configuration (Sub_Blk, El);
+ when others =>
+ Error_Kind ("canon_block_configuration(0)", Sub_Blk);
+ end case;
+ when others =>
+ Error_Kind ("canon_block_configuration(1)", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+
+ -- 3) Add default component configuration for unspecified component
+ -- instantiation statements,
+ -- Add default block configuration for unconfigured block statements.
+ El := Stmts;
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Component_Instantiation_Statement =>
+ declare
+ Comp_Conf : Iir;
+ Res : Iir_Component_Configuration;
+ Designator_List : Iir_List;
+ Inst_List : Iir_List;
+ Inst : Iir;
+ Inst_Name : Iir;
+ begin
+ Comp_Conf := Get_Component_Configuration (El);
+ if Comp_Conf = Null_Iir then
+ if Is_Component_Instantiation (El) then
+ -- Create a component configuration.
+ -- FIXME: should merge all these default configuration
+ -- of the same component.
+ Res := Create_Iir (Iir_Kind_Component_Configuration);
+ Location_Copy (Res, El);
+ Set_Parent (Res, Conf);
+ Set_Component_Name (Res, Get_Instantiated_Unit (El));
+ Designator_List := Create_Iir_List;
+ Append_Element
+ (Designator_List, Build_Simple_Name (El, El));
+ Set_Instantiation_List (Res, Designator_List);
+ Append (Last_Item, Conf, Res);
+ end if;
+ elsif Get_Kind (Comp_Conf)
+ = Iir_Kind_Configuration_Specification
+ then
+ -- Create component configuration
+ Res := Create_Iir (Iir_Kind_Component_Configuration);
+ Location_Copy (Res, Comp_Conf);
+ Set_Parent (Res, Conf);
+ Set_Component_Name (Res, Get_Component_Name (Comp_Conf));
+ -- Keep in the designator list only the non-incrementally
+ -- bound instances, and only the instances in the current
+ -- statements parts (vhdl-87 generate issue).
+ Inst_List := Get_Instantiation_List (Comp_Conf);
+ Designator_List := Create_Iir_List;
+ for I in 0 .. Get_Nbr_Elements (Inst_List) - 1 loop
+ Inst_Name := Get_Nth_Element (Inst_List, I);
+ Inst := Get_Named_Entity (Inst_Name);
+ if Get_Component_Configuration (Inst) = Comp_Conf
+ and then Get_Parent (Inst) = Blk
+ then
+ Set_Component_Configuration (Inst, Res);
+ Append_Element (Designator_List, Inst_Name);
+ end if;
+ end loop;
+ Set_Instantiation_List (Res, Designator_List);
+ Set_Binding_Indication
+ (Res, Get_Binding_Indication (Comp_Conf));
+ Append (Last_Item, Conf, Res);
+ end if;
+ end;
+ when Iir_Kind_Block_Statement =>
+ declare
+ Res : Iir_Block_Configuration;
+ begin
+ if Get_Block_Block_Configuration (El) = Null_Iir then
+ Res := Create_Iir (Iir_Kind_Block_Configuration);
+ Location_Copy (Res, El);
+ Set_Parent (Res, Conf);
+ Set_Block_Specification (Res, El);
+ Append (Last_Item, Conf, Res);
+ end if;
+ end;
+ when Iir_Kind_Generate_Statement =>
+ declare
+ Res : Iir_Block_Configuration;
+ Scheme : Iir;
+ Blk_Config : Iir_Block_Configuration;
+ Blk_Spec : Iir;
+ begin
+ Scheme := Get_Generation_Scheme (El);
+ Blk_Config := Get_Generate_Block_Configuration (El);
+ if Blk_Config = Null_Iir then
+ -- No block configuration for the (implicit) internal
+ -- block. Create one.
+ Res := Create_Iir (Iir_Kind_Block_Configuration);
+ Location_Copy (Res, El);
+ Set_Parent (Res, Conf);
+ Set_Block_Specification (Res, El);
+ Append (Last_Item, Conf, Res);
+ elsif Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Blk_Spec := Strip_Denoting_Name
+ (Get_Block_Specification (Blk_Config));
+ if Get_Kind (Blk_Spec) /= Iir_Kind_Generate_Statement then
+ -- There are partial configurations.
+ -- Create a default block configuration.
+ Res := Create_Iir (Iir_Kind_Block_Configuration);
+ Location_Copy (Res, El);
+ Set_Parent (Res, Conf);
+ Blk_Spec := Create_Iir (Iir_Kind_Indexed_Name);
+ Location_Copy (Blk_Spec, Res);
+ Set_Index_List (Blk_Spec, Iir_List_Others);
+ Set_Base_Name (Blk_Spec, El);
+ Set_Prefix (Blk_Spec, Build_Simple_Name (El, Res));
+ Set_Block_Specification (Res, Blk_Spec);
+ Append (Last_Item, Conf, Res);
+ end if;
+ end if;
+ end;
+
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement
+ | Iir_Kind_Psl_Default_Clock
+ | Iir_Kind_Psl_Declaration
+ | Iir_Kind_Simple_Simultaneous_Statement =>
+ null;
+
+ when others =>
+ Error_Kind ("canon_block_configuration(3)", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+
+ -- 4) Canon component configuration and block configuration (recursion).
+ El := Get_Configuration_Item_Chain (Conf);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Block_Configuration =>
+ Canon_Block_Configuration (Top, El);
+ when Iir_Kind_Component_Configuration =>
+ Canon_Component_Configuration (Top, El);
+ when others =>
+ Error_Kind ("canon_block_configuration", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Canon_Block_Configuration;
+
+ procedure Canon_Interface_List (Chain : Iir)
+ is
+ Inter : Iir;
+ begin
+ if Canon_Flag_Expressions then
+ Inter := Chain;
+ while Inter /= Null_Iir loop
+ Canon_Expression (Get_Default_Value (Inter));
+ Inter := Get_Chain (Inter);
+ end loop;
+ end if;
+ end Canon_Interface_List;
+
+ procedure Canonicalize (Unit: Iir_Design_Unit)
+ is
+ El: Iir;
+ begin
+ if False then
+ -- Canon context clauses.
+ -- This code is not executed since context clauses are already
+ -- canonicalized.
+ El := Get_Context_Items (Unit);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Use_Clause =>
+ null;
+ when Iir_Kind_Library_Clause =>
+ null;
+ when others =>
+ Error_Kind ("canonicalize1", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end if;
+
+ El := Get_Library_Unit (Unit);
+ case Get_Kind (El) is
+ when Iir_Kind_Entity_Declaration =>
+ Canon_Interface_List (Get_Generic_Chain (El));
+ Canon_Interface_List (Get_Port_Chain (El));
+ Canon_Declarations (Unit, El, El);
+ Canon_Concurrent_Stmts (Unit, El);
+ when Iir_Kind_Architecture_Body =>
+ Canon_Declarations (Unit, El, El);
+ Canon_Concurrent_Stmts (Unit, El);
+ when Iir_Kind_Package_Declaration =>
+ Canon_Declarations (Unit, El, Null_Iir);
+ when Iir_Kind_Package_Body =>
+ Canon_Declarations (Unit, El, Null_Iir);
+ when Iir_Kind_Configuration_Declaration =>
+ Canon_Declarations (Unit, El, Null_Iir);
+ Canon_Block_Configuration (Unit, Get_Block_Configuration (El));
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ declare
+ Pkg : constant Iir :=
+ Get_Named_Entity (Get_Uninstantiated_Package_Name (El));
+ Hdr : constant Iir := Get_Package_Header (Pkg);
+ begin
+ Set_Generic_Map_Aspect_Chain
+ (El,
+ Canon_Association_Chain_And_Actuals
+ (Get_Generic_Chain (Hdr),
+ Get_Generic_Map_Aspect_Chain (El), El));
+ end;
+ when others =>
+ Error_Kind ("canonicalize2", El);
+ end case;
+ end Canonicalize;
+
+-- -- Create a default component configuration for component instantiation
+-- -- statement INST.
+-- function Create_Default_Component_Configuration
+-- (Inst : Iir_Component_Instantiation_Statement;
+-- Parent : Iir;
+-- Config_Unit : Iir_Design_Unit)
+-- return Iir_Component_Configuration
+-- is
+-- Res : Iir_Component_Configuration;
+-- Designator : Iir;
+-- Comp : Iir_Component_Declaration;
+-- Bind : Iir;
+-- Aspect : Iir;
+-- begin
+-- Bind := Get_Default_Binding_Indication (Inst);
+
+-- if Bind = Null_Iir then
+-- -- Component is not bound.
+-- return Null_Iir;
+-- end if;
+
+-- Res := Create_Iir (Iir_Kind_Component_Configuration);
+-- Location_Copy (Res, Inst);
+-- Set_Parent (Res, Parent);
+-- Comp := Get_Instantiated_Unit (Inst);
+
+-- Set_Component_Name (Res, Comp);
+-- -- Create the instantiation list with only one element: INST.
+-- Designator := Create_Iir (Iir_Kind_Designator_List);
+-- Append_Element (Designator, Inst);
+-- Set_Instantiation_List (Res, Designator);
+
+-- Set_Binding_Indication (Res, Bind);
+-- Aspect := Get_Entity_Aspect (Bind);
+-- case Get_Kind (Aspect) is
+-- when Iir_Kind_Entity_Aspect_Entity =>
+-- Add_Dependence (Config_Unit, Get_Entity (Aspect));
+-- if Get_Architecture (Aspect) /= Null_Iir then
+-- raise Internal_Error;
+-- end if;
+-- when others =>
+-- Error_Kind ("Create_Default_Component_Configuration", Aspect);
+-- end case;
+
+-- return Res;
+-- end Create_Default_Component_Configuration;
+
+ -- Create a default configuration declaration for architecture ARCH.
+ function Create_Default_Configuration_Declaration
+ (Arch : Iir_Architecture_Body)
+ return Iir_Design_Unit
+ is
+ Loc : constant Location_Type := Get_Location (Arch);
+ Config : Iir_Configuration_Declaration;
+ Res : Iir_Design_Unit;
+ Blk_Cfg : Iir_Block_Configuration;
+ begin
+ Res := Create_Iir (Iir_Kind_Design_Unit);
+ Set_Location (Res, Loc);
+ Set_Parent (Res, Get_Parent (Get_Design_Unit (Arch)));
+ Set_Date_State (Res, Date_Analyze);
+ Set_Date (Res, Date_Uptodate);
+
+ Config := Create_Iir (Iir_Kind_Configuration_Declaration);
+ Set_Location (Config, Loc);
+ Set_Library_Unit (Res, Config);
+ Set_Design_Unit (Config, Res);
+ Set_Entity_Name (Config, Get_Entity_Name (Arch));
+ Set_Dependence_List (Res, Create_Iir_List);
+ Add_Dependence (Res, Get_Design_Unit (Get_Entity (Config)));
+ Add_Dependence (Res, Get_Design_Unit (Arch));
+
+ Blk_Cfg := Create_Iir (Iir_Kind_Block_Configuration);
+ Set_Location (Blk_Cfg, Loc);
+ Set_Parent (Blk_Cfg, Config);
+ Set_Block_Specification (Blk_Cfg, Arch);
+ Set_Block_Configuration (Config, Blk_Cfg);
+
+ Canon_Block_Configuration (Res, Blk_Cfg);
+
+ return Res;
+ end Create_Default_Configuration_Declaration;
+
+end Canon;
diff --git a/src/canon.ads b/src/canon.ads
new file mode 100644
index 000000000..574a31824
--- /dev/null
+++ b/src/canon.ads
@@ -0,0 +1,70 @@
+-- Canonicalization pass
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Iirs; use Iirs;
+
+package Canon is
+ -- If true, a label will be added for statements which do not have a
+ -- label.
+ Canon_Flag_Add_Labels : Boolean := False;
+
+ -- If true, canon sequentials statements (processes and subprograms).
+ Canon_Flag_Sequentials_Stmts : Boolean := False;
+
+ -- If true, canon expressions.
+ Canon_Flag_Expressions : Boolean := False;
+
+ -- If true, replace 'all' sensitivity list by the explicit list
+ -- (If true, Canon_Flag_Sequentials_Stmts must be true)
+ Canon_Flag_All_Sensitivity : Boolean := False;
+
+ -- If true, operands of type array element of a concatenation operator
+ -- are converted (by an aggregate) into array.
+ Canon_Concatenation : Boolean := False;
+
+ -- Do canonicalization:
+ -- Transforms concurrent statements into sensitized process statements
+ -- (all but component instanciation and block).
+ -- This computes sensivity list.
+ --
+ -- Association list are completed:
+ -- * Formal are added.
+ -- * association are created for formal not associated (actual is open).
+ -- * an association is created (for block header only).
+ procedure Canonicalize (Unit: Iir_Design_Unit);
+
+ -- Create a default configuration declaration for architecture ARCH.
+ function Create_Default_Configuration_Declaration
+ (Arch : Iir_Architecture_Body)
+ return Iir_Design_Unit;
+
+ -- Canonicalize a subprogram call.
+ procedure Canon_Subprogram_Call (Call : Iir);
+
+ -- Compute the sensivity list of EXPR and add it to SENSIVITY_LIST.
+ -- If IS_TARGET is true, the longuest static prefix of the signal name
+ -- is not added to the sensitivity list, but other static prefix (such
+ -- as indexes of an indexed name) are added.
+ procedure Canon_Extract_Sensitivity
+ (Expr: Iir; Sensitivity_List: Iir_List; Is_Target: Boolean := False);
+
+ -- Compute the sensitivity list of all-sensitized process PROC.
+ -- Used for vhdl 08.
+ function Canon_Extract_Process_Sensitivity
+ (Proc : Iir_Sensitized_Process_Statement)
+ return Iir_List;
+end Canon;
diff --git a/src/canon_psl.adb b/src/canon_psl.adb
new file mode 100644
index 000000000..1e1d8de18
--- /dev/null
+++ b/src/canon_psl.adb
@@ -0,0 +1,43 @@
+-- Canonicalization pass for PSL.
+-- Copyright (C) 2009 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with PSL.Nodes; use PSL.Nodes;
+with PSL.Errors; use PSL.Errors;
+with Canon; use Canon;
+with Iirs_Utils; use Iirs_Utils;
+
+package body Canon_PSL is
+ -- Version of Canon.Canon_Extract_Sensitivity for PSL nodes.
+ procedure Canon_Extract_Sensitivity
+ (Expr: PSL_Node; Sensitivity_List: Iir_List)
+ is
+ begin
+ case Get_Kind (Expr) is
+ when N_HDL_Expr =>
+ Canon_Extract_Sensitivity (Get_HDL_Node (Expr), Sensitivity_List);
+ when N_And_Bool
+ | N_Or_Bool =>
+ Canon_Extract_Sensitivity (Get_Left (Expr), Sensitivity_List);
+ Canon_Extract_Sensitivity (Get_Right (Expr), Sensitivity_List);
+ when N_Not_Bool =>
+ Canon_Extract_Sensitivity (Get_Boolean (Expr), Sensitivity_List);
+ when others =>
+ Error_Kind ("PSL.Canon_extract_Sensitivity", Expr);
+ end case;
+ end Canon_Extract_Sensitivity;
+end Canon_PSL;
diff --git a/src/canon_psl.ads b/src/canon_psl.ads
new file mode 100644
index 000000000..3a8c501ac
--- /dev/null
+++ b/src/canon_psl.ads
@@ -0,0 +1,26 @@
+-- Canonicalization pass for PSL.
+-- Copyright (C) 2009 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Types; use Types;
+with Iirs; use Iirs;
+
+package Canon_PSL is
+ -- Version of Canon.Canon_Extract_Sensitivity for PSL nodes.
+ procedure Canon_Extract_Sensitivity
+ (Expr: PSL_Node; Sensitivity_List: Iir_List);
+end Canon_PSL;
diff --git a/src/configuration.adb b/src/configuration.adb
new file mode 100644
index 000000000..f570b692e
--- /dev/null
+++ b/src/configuration.adb
@@ -0,0 +1,614 @@
+-- Configuration generation.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Libraries;
+with Errorout; use Errorout;
+with Std_Package;
+with Sem_Names;
+with Name_Table; use Name_Table;
+with Flags;
+with Iirs_Utils; use Iirs_Utils;
+
+package body Configuration is
+ procedure Add_Design_Concurrent_Stmts (Parent : Iir);
+ procedure Add_Design_Block_Configuration (Blk : Iir_Block_Configuration);
+ procedure Add_Design_Aspect (Aspect : Iir; Add_Default : Boolean);
+
+ Current_File_Dependence : Iir_List := Null_Iir_List;
+ Current_Configuration : Iir_Configuration_Declaration := Null_Iir;
+
+ -- UNIT is a design unit of a configuration declaration.
+ -- Fill the DESIGN_UNITS table with all design units required to build
+ -- UNIT.
+ procedure Add_Design_Unit (Unit : Iir_Design_Unit; From : Iir)
+ is
+ List : Iir_List;
+ El : Iir;
+ Lib_Unit : Iir;
+ File : Iir_Design_File;
+ Prev_File_Dependence : Iir_List;
+ begin
+ if Flag_Build_File_Dependence then
+ File := Get_Design_File (Unit);
+ if Current_File_Dependence /= Null_Iir_List then
+ Add_Element (Current_File_Dependence, File);
+ end if;
+ end if;
+
+ -- If already in the table, then nothing to do.
+ if Get_Elab_Flag (Unit) then
+ return;
+ end if;
+
+ -- May be enabled to debug dependency construction.
+ if False then
+ if From = Null_Iir then
+ Warning_Msg_Elab (Disp_Node (Unit) & " added", Unit);
+ else
+ Warning_Msg_Elab
+ (Disp_Node (Unit) & " added by " & Disp_Node (From), From);
+ end if;
+ end if;
+
+ Set_Elab_Flag (Unit, True);
+
+ Lib_Unit := Get_Library_Unit (Unit);
+
+ if Flag_Build_File_Dependence then
+ Prev_File_Dependence := Current_File_Dependence;
+
+ if Get_Kind (Lib_Unit) = Iir_Kind_Configuration_Declaration
+ and then Get_Identifier (Lib_Unit) = Null_Identifier
+ then
+ -- Do not add dependence for default configuration.
+ Current_File_Dependence := Null_Iir_List;
+ else
+ File := Get_Design_File (Unit);
+ Current_File_Dependence := Get_File_Dependence_List (File);
+ -- Create a list if not yet created.
+ if Current_File_Dependence = Null_Iir_List then
+ Current_File_Dependence := Create_Iir_List;
+ Set_File_Dependence_List (File, Current_File_Dependence);
+ end if;
+ end if;
+ end if;
+
+ if Flag_Load_All_Design_Units then
+ Libraries.Load_Design_Unit (Unit, From);
+ end if;
+
+ -- Add packages from depend list.
+ -- If Flag_Build_File_Dependences is set, add design units of the
+ -- dependence list are added, because of LRM 11.4 Analysis Order.
+ -- Note: a design unit may be referenced but unused.
+ -- (eg: component specification which does not apply).
+ List := Get_Dependence_List (Unit);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ El := Libraries.Find_Design_Unit (El);
+ if El /= Null_Iir then
+ Lib_Unit := Get_Library_Unit (El);
+ if Flag_Build_File_Dependence
+ or else Get_Kind (Lib_Unit) in Iir_Kinds_Package_Declaration
+ then
+ Add_Design_Unit (El, Unit);
+ end if;
+ end if;
+ end loop;
+
+ -- Lib_Unit may have changed.
+ Lib_Unit := Get_Library_Unit (Unit);
+
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Package_Declaration =>
+ -- Analyze the package declaration, so that Set_Package below
+ -- will set the full package (and not a stub).
+ Libraries.Load_Design_Unit (Unit, From);
+ Lib_Unit := Get_Library_Unit (Unit);
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ -- The uninstantiated package is part of the dependency.
+ null;
+ when Iir_Kind_Configuration_Declaration =>
+ -- Add entity and architecture.
+ -- find all sub-configuration
+ Libraries.Load_Design_Unit (Unit, From);
+ Lib_Unit := Get_Library_Unit (Unit);
+ Add_Design_Unit (Get_Design_Unit (Get_Entity (Lib_Unit)), Unit);
+ declare
+ Blk : Iir_Block_Configuration;
+ Prev_Configuration : Iir_Configuration_Declaration;
+ Arch : Iir;
+ begin
+ Prev_Configuration := Current_Configuration;
+ Current_Configuration := Lib_Unit;
+ Blk := Get_Block_Configuration (Lib_Unit);
+ Arch := Get_Block_Specification (Blk);
+ Add_Design_Block_Configuration (Blk);
+ Current_Configuration := Prev_Configuration;
+ Add_Design_Unit (Get_Design_Unit (Arch), Unit);
+ end;
+ when Iir_Kind_Architecture_Body =>
+ -- Add entity
+ -- find all entity/architecture/configuration instantiation
+ Add_Design_Unit (Get_Design_Unit (Get_Entity (Lib_Unit)), Unit);
+ Add_Design_Concurrent_Stmts (Lib_Unit);
+ when Iir_Kind_Entity_Declaration =>
+ null;
+ when Iir_Kind_Package_Body =>
+ null;
+ when others =>
+ Error_Kind ("add_design_unit", Lib_Unit);
+ end case;
+
+ -- Add it in the table, after the dependencies.
+ Design_Units.Append (Unit);
+
+ -- Restore now the file dependence.
+ -- Indeed, we may add a package body when we are in a package
+ -- declaration. However, the later does not depend on the former.
+ -- The file which depends on the package declaration also depends on
+ -- the package body.
+ if Flag_Build_File_Dependence then
+ Current_File_Dependence := Prev_File_Dependence;
+ end if;
+
+ if Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration then
+ -- Add body (if any).
+ declare
+ Bod : Iir_Design_Unit;
+ begin
+ Bod := Libraries.Find_Secondary_Unit (Unit, Null_Identifier);
+ if Get_Need_Body (Lib_Unit) then
+ if not Flags.Flag_Elaborate_With_Outdated then
+ -- LIB_UNIT requires a body.
+ if Bod = Null_Iir then
+ Error_Msg_Elab ("body of " & Disp_Node (Lib_Unit)
+ & " was never analyzed", Lib_Unit);
+ elsif Get_Date (Bod) < Get_Date (Unit) then
+ Error_Msg_Elab (Disp_Node (Bod) & " is outdated");
+ Bod := Null_Iir;
+ end if;
+ end if;
+ else
+ if Bod /= Null_Iir
+ and then Get_Date (Bod) < Get_Date (Unit)
+ then
+ -- There is a body for LIB_UNIT (which doesn't
+ -- require it) but it is outdated.
+ Bod := Null_Iir;
+ end if;
+ end if;
+ if Bod /= Null_Iir then
+ Set_Package (Get_Library_Unit (Bod), Lib_Unit);
+ Add_Design_Unit (Bod, Unit);
+ end if;
+ end;
+ end if;
+ end Add_Design_Unit;
+
+ procedure Add_Design_Concurrent_Stmts (Parent : Iir)
+ is
+ Stmt : Iir;
+ begin
+ Stmt := Get_Concurrent_Statement_Chain (Parent);
+ while Stmt /= Null_Iir loop
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Component_Instantiation_Statement =>
+ if Is_Entity_Instantiation (Stmt) then
+ -- Entity or configuration instantiation.
+ Add_Design_Aspect (Get_Instantiated_Unit (Stmt), True);
+ end if;
+ when Iir_Kind_Generate_Statement
+ | Iir_Kind_Block_Statement =>
+ Add_Design_Concurrent_Stmts (Stmt);
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement
+ | Iir_Kind_Psl_Default_Clock
+ | Iir_Kind_Psl_Declaration
+ | Iir_Kind_Simple_Simultaneous_Statement =>
+ null;
+ when others =>
+ Error_Kind ("add_design_concurrent_stmts(2)", Stmt);
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Add_Design_Concurrent_Stmts;
+
+ procedure Add_Design_Aspect (Aspect : Iir; Add_Default : Boolean)
+ is
+ use Libraries;
+
+ Entity : Iir;
+ Arch : Iir;
+ Config : Iir;
+ Id : Name_Id;
+ Entity_Lib : Iir;
+ begin
+ if Aspect = Null_Iir then
+ return;
+ end if;
+ case Get_Kind (Aspect) is
+ when Iir_Kind_Entity_Aspect_Entity =>
+ -- Add the entity.
+ Entity_Lib := Get_Entity (Aspect);
+ Entity := Get_Design_Unit (Entity_Lib);
+ Add_Design_Unit (Entity, Aspect);
+
+ -- Extract and add the architecture.
+ Arch := Get_Architecture (Aspect);
+ if Arch /= Null_Iir then
+ case Get_Kind (Arch) is
+ when Iir_Kind_Simple_Name =>
+ Id := Get_Identifier (Arch);
+ Arch := Load_Secondary_Unit (Entity, Id, Aspect);
+ if Arch = Null_Iir then
+ Error_Msg_Elab
+ ("cannot find architecture " & Name_Table.Image (Id)
+ & " of " & Disp_Node (Entity_Lib));
+ return;
+ else
+ Set_Architecture (Aspect, Get_Library_Unit (Arch));
+ end if;
+ when Iir_Kind_Architecture_Body =>
+ Arch := Get_Design_Unit (Arch);
+ when others =>
+ Error_Kind ("add_design_aspect", Arch);
+ end case;
+ else
+ Arch := Get_Latest_Architecture (Entity_Lib);
+ if Arch = Null_Iir then
+ Error_Msg_Elab ("no architecture in library for "
+ & Disp_Node (Entity_Lib), Aspect);
+ return;
+ end if;
+ Arch := Get_Design_Unit (Arch);
+ end if;
+ Load_Design_Unit (Arch, Aspect);
+ Add_Design_Unit (Arch, Aspect);
+
+ -- Add the default configuration if required.
+ if Add_Default then
+ Config := Get_Default_Configuration_Declaration
+ (Get_Library_Unit (Arch));
+ if Config /= Null_Iir then
+ Add_Design_Unit (Config, Aspect);
+ end if;
+ end if;
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ Add_Design_Unit
+ (Get_Design_Unit (Get_Configuration (Aspect)), Aspect);
+ when Iir_Kind_Entity_Aspect_Open =>
+ null;
+ when others =>
+ Error_Kind ("add_design_aspect", Aspect);
+ end case;
+ end Add_Design_Aspect;
+
+ -- Return TRUE is PORT must not be open, and emit an error message only if
+ -- LOC is not NULL_IIR.
+ function Check_Open_Port (Port : Iir; Loc : Iir) return Boolean is
+ begin
+ case Get_Mode (Port) is
+ when Iir_In_Mode =>
+ -- LRM 1.1.1.2 Ports
+ -- A port of mode IN may be unconnected or unassociated only if
+ -- its declaration includes a default expression.
+ if Get_Default_Value (Port) = Null_Iir then
+ if Loc /= Null_Iir then
+ Error_Msg_Elab
+ ("IN " & Disp_Node (Port) & " must be connected", Loc);
+ end if;
+ return True;
+ end if;
+ when Iir_Out_Mode
+ | Iir_Inout_Mode
+ | Iir_Buffer_Mode
+ | Iir_Linkage_Mode =>
+ -- LRM 1.1.1.2 Ports
+ -- A port of any mode other than IN may be unconnected or
+ -- unassociated as long as its type is not an unconstrained array
+ -- type.
+ if Get_Kind (Get_Type (Port)) in Iir_Kinds_Array_Type_Definition
+ and then (Get_Constraint_State (Get_Type (Port))
+ /= Fully_Constrained)
+ then
+ if Loc /= Null_Iir then
+ Error_Msg_Elab ("unconstrained " & Disp_Node (Port)
+ & " must be connected", Loc);
+ end if;
+ return True;
+ end if;
+ when others =>
+ Error_Kind ("check_open_port", Port);
+ end case;
+ return False;
+ end Check_Open_Port;
+
+ procedure Check_Binding_Indication (Conf : Iir)
+ is
+ Assoc : Iir;
+ Conf_Chain : Iir;
+ Inst_Chain : Iir;
+ Bind : Iir_Binding_Indication;
+ Err : Boolean;
+ Inst : Iir;
+ Inst_List : Iir_List;
+ Formal : Iir;
+ Assoc_1 : Iir;
+ Actual : Iir;
+ begin
+ Bind := Get_Binding_Indication (Conf);
+ Conf_Chain := Get_Port_Map_Aspect_Chain (Bind);
+
+ Err := False;
+ -- Note: the assoc chain is already canonicalized.
+
+ -- First pass: check for open associations in configuration.
+ Assoc := Conf_Chain;
+ while Assoc /= Null_Iir loop
+ if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then
+ Formal := Get_Association_Interface (Assoc);
+ Err := Err or Check_Open_Port (Formal, Assoc);
+ if Flags.Warn_Binding and then not Get_Artificial_Flag (Assoc) then
+ Warning_Msg_Elab
+ (Disp_Node (Formal) & " of " & Disp_Node (Get_Parent (Formal))
+ & " is not bound", Assoc);
+ Warning_Msg_Elab
+ ("(in " & Disp_Node (Current_Configuration) & ")",
+ Current_Configuration);
+ end if;
+ end if;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ if Err then
+ return;
+ end if;
+
+ -- Second pass: check for port connected to open in instantiation.
+ Inst_List := Get_Instantiation_List (Conf);
+ for I in Natural loop
+ Inst := Get_Nth_Element (Inst_List, I);
+ exit when Inst = Null_Iir;
+ Inst := Get_Named_Entity (Inst);
+ Err := False;
+
+ -- Mark component ports not associated.
+ Inst_Chain := Get_Port_Map_Aspect_Chain (Inst);
+ Assoc := Inst_Chain;
+ while Assoc /= Null_Iir loop
+ if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then
+ Formal := Get_Association_Interface (Assoc);
+ Set_Open_Flag (Formal, True);
+ Err := True;
+ end if;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+
+ -- If there is any component port open, search them in the
+ -- configuration.
+ if Err then
+ Assoc := Conf_Chain;
+ while Assoc /= Null_Iir loop
+ Formal := Get_Association_Interface (Assoc);
+ if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then
+ Actual := Null_Iir;
+ else
+ Actual := Get_Actual (Assoc);
+ Actual := Sem_Names.Name_To_Object (Actual);
+ if Actual /= Null_Iir then
+ Actual := Get_Object_Prefix (Actual);
+ end if;
+ end if;
+ if Actual /= Null_Iir
+ and then Get_Open_Flag (Actual)
+ and then Check_Open_Port (Formal, Null_Iir)
+ then
+ -- For a better message, find the location.
+ Assoc_1 := Inst_Chain;
+ while Assoc_1 /= Null_Iir loop
+ if Get_Kind (Assoc_1) = Iir_Kind_Association_Element_Open
+ and then Actual = Get_Association_Interface (Assoc_1)
+ then
+ Err := Check_Open_Port (Formal, Assoc_1);
+ exit;
+ end if;
+ Assoc_1 := Get_Chain (Assoc_1);
+ end loop;
+ end if;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+
+ -- Clear open flag.
+ Assoc := Inst_Chain;
+ while Assoc /= Null_Iir loop
+ if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then
+ Formal := Get_Association_Interface (Assoc);
+ Set_Open_Flag (Formal, False);
+ end if;
+ Assoc := Get_Chain (Assoc);
+ end loop;
+ end if;
+ end loop;
+ end Check_Binding_Indication;
+
+ -- CONF is either a configuration specification or a component
+ -- configuration.
+ -- If ADD_DEFAULT is true, then the default configuration for the design
+ -- binding must be added if required.
+ procedure Add_Design_Binding_Indication (Conf : Iir; Add_Default : Boolean)
+ is
+ Bind : constant Iir_Binding_Indication := Get_Binding_Indication (Conf);
+ Inst : Iir;
+ begin
+ if Bind = Null_Iir then
+ if Flags.Warn_Binding then
+ Inst := Get_First_Element (Get_Instantiation_List (Conf));
+ Warning_Msg_Elab
+ (Disp_Node (Inst) & " is not bound", Conf);
+ Warning_Msg_Elab
+ ("(in " & Disp_Node (Current_Configuration) & ")",
+ Current_Configuration);
+ end if;
+ return;
+ end if;
+ Check_Binding_Indication (Conf);
+ Add_Design_Aspect (Get_Entity_Aspect (Bind), Add_Default);
+ end Add_Design_Binding_Indication;
+
+ procedure Add_Design_Block_Configuration (Blk : Iir_Block_Configuration)
+ is
+ Item : Iir;
+ Sub_Config : Iir;
+ begin
+ if Blk = Null_Iir then
+ return;
+ end if;
+ Item := Get_Configuration_Item_Chain (Blk);
+ while Item /= Null_Iir loop
+ case Get_Kind (Item) is
+ when Iir_Kind_Configuration_Specification =>
+ Add_Design_Binding_Indication (Item, True);
+ when Iir_Kind_Component_Configuration =>
+ Sub_Config := Get_Block_Configuration (Item);
+ Add_Design_Binding_Indication (Item, Sub_Config = Null_Iir);
+ Add_Design_Block_Configuration (Sub_Config);
+ when Iir_Kind_Block_Configuration =>
+ Add_Design_Block_Configuration (Item);
+ when others =>
+ Error_Kind ("add_design_block_configuration", Item);
+ end case;
+ Item := Get_Chain (Item);
+ end loop;
+ end Add_Design_Block_Configuration;
+
+ -- elaboration of a design hierarchy:
+ -- creates a list of design unit.
+ --
+ -- find top configuration (may be a default one), add it to the list.
+ -- For each element of the list:
+ -- add direct dependences (packages, entity, arch) if not in the list
+ -- for architectures and configuration: find instantiations and add
+ -- corresponding configurations
+ function Configure (Primary_Id : Name_Id; Secondary_Id : Name_Id)
+ return Iir
+ is
+ use Libraries;
+
+ Unit : Iir_Design_Unit;
+ Lib_Unit : Iir;
+ Top : Iir;
+ begin
+ Unit := Find_Primary_Unit (Work_Library, Primary_Id);
+ if Unit = Null_Iir then
+ Error_Msg_Elab ("cannot find entity or configuration "
+ & Name_Table.Image (Primary_Id));
+ return Null_Iir;
+ end if;
+ Lib_Unit := Get_Library_Unit (Unit);
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Entity_Declaration =>
+ Load_Design_Unit (Unit, Null_Iir);
+ Lib_Unit := Get_Library_Unit (Unit);
+ if Secondary_Id /= Null_Identifier then
+ Unit := Find_Secondary_Unit (Unit, Secondary_Id);
+ if Unit = Null_Iir then
+ Error_Msg_Elab
+ ("cannot find architecture "
+ & Name_Table.Image (Secondary_Id)
+ & " of " & Disp_Node (Lib_Unit));
+ return Null_Iir;
+ end if;
+ else
+ declare
+ Arch_Unit : Iir_Architecture_Body;
+ begin
+ Arch_Unit := Get_Latest_Architecture (Lib_Unit);
+ if Arch_Unit = Null_Iir then
+ Error_Msg_Elab
+ (Disp_Node (Lib_Unit)
+ & " has no architecture in library "
+ & Name_Table.Image (Get_Identifier (Work_Library)));
+ return Null_Iir;
+ end if;
+ Unit := Get_Design_Unit (Arch_Unit);
+ end;
+ end if;
+ Load_Design_Unit (Unit, Lib_Unit);
+ if Nbr_Errors /= 0 then
+ return Null_Iir;
+ end if;
+ Lib_Unit := Get_Library_Unit (Unit);
+ Top := Get_Default_Configuration_Declaration (Lib_Unit);
+ if Top = Null_Iir then
+ -- No default configuration for this architecture.
+ raise Internal_Error;
+ end if;
+ when Iir_Kind_Configuration_Declaration =>
+ Top := Unit;
+ when others =>
+ Error_Msg_Elab (Name_Table.Image (Primary_Id)
+ & " is neither an entity nor a configuration");
+ return Null_Iir;
+ end case;
+
+ Set_Elab_Flag (Std_Package.Std_Standard_Unit, True);
+
+ Add_Design_Unit (Top, Null_Iir);
+ return Top;
+ end Configure;
+
+ procedure Check_Entity_Declaration_Top (Entity : Iir_Entity_Declaration)
+ is
+ Has_Error : Boolean := False;
+
+ procedure Error (Msg : String; Loc : Iir) is
+ begin
+ if not Has_Error then
+ Error_Msg_Elab
+ (Disp_Node (Entity) & " cannot be at the top of a design");
+ Has_Error := True;
+ end if;
+ Error_Msg_Elab (Msg, Loc);
+ end Error;
+
+ El : Iir;
+ begin
+ -- Check generics.
+ El := Get_Generic_Chain (Entity);
+ while El /= Null_Iir loop
+ if Get_Default_Value (El) = Null_Iir then
+ Error ("(" & Disp_Node (El) & " has no default value)", El);
+ end if;
+ El := Get_Chain (El);
+ end loop;
+
+ -- Check port.
+ El := Get_Port_Chain (Entity);
+ while El /= Null_Iir loop
+ if not Is_Fully_Constrained_Type (Get_Type (El))
+ and then Get_Default_Value (El) = Null_Iir
+ then
+ Error ("(" & Disp_Node (El)
+ & " is unconstrained and has no default value)", El);
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ end Check_Entity_Declaration_Top;
+end Configuration;
diff --git a/src/configuration.ads b/src/configuration.ads
new file mode 100644
index 000000000..0a19a23c2
--- /dev/null
+++ b/src/configuration.ads
@@ -0,0 +1,55 @@
+-- Configuration generation.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with Iirs; use Iirs;
+with GNAT.Table;
+
+package Configuration is
+ package Design_Units is new GNAT.Table
+ (Table_Component_Type => Iir_Design_Unit,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ -- Get the top configuration to build a design hierarchy whose top is
+ -- PRIMARY + SECONDARY.
+ -- PRIMARY must designate a configuration declaration or an entity
+ -- declaration. In the last case, SECONDARY must be null_identifier or
+ -- designates an architecture declaration.
+ --
+ -- creates a list of design unit.
+ -- and return the top configuration.
+ -- Note: this set the Elab_Flag on units.
+ function Configure (Primary_Id : Name_Id; Secondary_Id : Name_Id)
+ return Iir;
+
+ -- Add design unit UNIT (with its dependences) in the design_units table.
+ procedure Add_Design_Unit (Unit : Iir_Design_Unit; From : Iir);
+
+ -- If set, all design units (even package bodies) are loaded.
+ Flag_Load_All_Design_Units : Boolean := True;
+
+ Flag_Build_File_Dependence : Boolean := False;
+
+ -- Check if ENTITY can be at the top of a hierarchy, ie:
+ -- ENTITY has no generics or all generics have a default expression
+ -- ENTITY has no ports or all ports type are constrained.
+ -- If not, emit a elab error message.
+ procedure Check_Entity_Declaration_Top (Entity : Iir_Entity_Declaration);
+end Configuration;
diff --git a/src/disp_tree.adb b/src/disp_tree.adb
new file mode 100644
index 000000000..fbaaa939b
--- /dev/null
+++ b/src/disp_tree.adb
@@ -0,0 +1,511 @@
+-- Node displaying (for debugging).
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+-- Display trees in raw form. Mainly used for debugging.
+
+with Ada.Text_IO; use Ada.Text_IO;
+with Name_Table;
+with Str_Table;
+with Tokens;
+with Errorout;
+with Files_Map;
+with PSL.Dump_Tree;
+with Nodes_Meta;
+
+-- Do not add a use clause for iirs_utils, as it may crash for ill-formed
+-- trees, which is annoying while debugging.
+
+package body Disp_Tree is
+ -- function Is_Anonymous_Type_Definition (Def : Iir) return Boolean
+ -- renames Iirs_Utils.Is_Anonymous_Type_Definition;
+
+ procedure Disp_Iir (N : Iir;
+ Indent : Natural := 1;
+ Flat : Boolean := False);
+ procedure Disp_Header (N : Iir);
+
+ procedure Disp_Tree_List_Flat (Tree_List: Iir_List; Tab: Natural);
+ pragma Unreferenced (Disp_Tree_List_Flat);
+
+ procedure Put_Indent (Tab: Natural) is
+ Blanks : constant String (1 .. 2 * Tab) := (others => ' ');
+ begin
+ Put (Blanks);
+ end Put_Indent;
+
+ procedure Disp_Iir_Number (Node: Iir)
+ is
+ Res : String (1 .. 10) := " ]";
+ N : Int32 := Int32 (Node);
+ begin
+ for I in reverse 2 .. 9 loop
+ Res (I) := Character'Val (Character'Pos ('0') + (N mod 10));
+ N := N / 10;
+ if N = 0 then
+ Res (I - 1) := '[';
+ Put (Res (I - 1 .. Res'Last));
+ return;
+ end if;
+ end loop;
+ Put (Res);
+ end Disp_Iir_Number;
+
+ -- For iir.
+
+ procedure Disp_Tree_Flat (Tree: Iir; Tab: Natural) is
+ begin
+ Disp_Iir (Tree, Tab, True);
+ end Disp_Tree_Flat;
+
+ procedure Disp_Iir_List
+ (Tree_List : Iir_List; Tab : Natural := 0; Flat : Boolean := False)
+ is
+ El: Iir;
+ begin
+ if Tree_List = Null_Iir_List then
+ Put_Line ("null-list");
+ elsif Tree_List = Iir_List_All then
+ Put_Line ("list-all");
+ elsif Tree_List = Iir_List_Others then
+ Put_Line ("list-others");
+ else
+ New_Line;
+ for I in Natural loop
+ El := Get_Nth_Element (Tree_List, I);
+ exit when El = Null_Iir;
+ Put_Indent (Tab);
+ Disp_Iir (El, Tab + 1, Flat);
+ end loop;
+ end if;
+ end Disp_Iir_List;
+
+ procedure Disp_Chain
+ (Tree_Chain: Iir; Indent: Natural; Flat : Boolean := False)
+ is
+ El: Iir;
+ begin
+ New_Line;
+ El := Tree_Chain;
+ while El /= Null_Iir loop
+ Put_Indent (Indent);
+ Disp_Iir (El, Indent + 1, Flat);
+ El := Get_Chain (El);
+ end loop;
+ end Disp_Chain;
+
+ procedure Disp_Tree_Flat_Chain (Tree_Chain: Iir; Tab: Natural)
+ is
+ El: Iir;
+ begin
+ El := Tree_Chain;
+ while El /= Null_Iir loop
+ Disp_Iir (El, Tab, True);
+ El := Get_Chain (El);
+ end loop;
+ end Disp_Tree_Flat_Chain;
+ pragma Unreferenced (Disp_Tree_Flat_Chain);
+
+ procedure Disp_Tree_List_Flat (Tree_List: Iir_List; Tab: Natural)
+ is
+ El: Iir;
+ begin
+ if Tree_List = Null_Iir_List then
+ Put_Indent (Tab);
+ Put_Line (" null-list");
+ elsif Tree_List = Iir_List_All then
+ Put_Indent (Tab);
+ Put_Line (" list-all");
+ elsif Tree_List = Iir_List_Others then
+ Put_Indent (Tab);
+ Put_Line (" list-others");
+ else
+ for I in Natural loop
+ El := Get_Nth_Element (Tree_List, I);
+ exit when El = Null_Iir;
+ Disp_Tree_Flat (El, Tab);
+ end loop;
+ end if;
+ end Disp_Tree_List_Flat;
+
+ function Image_Name_Id (Ident: Name_Id) return String
+ is
+ use Name_Table;
+ begin
+ if Ident /= Null_Identifier then
+ Image (Ident);
+ return ''' & Name_Buffer (1 .. Name_Length) & ''';
+ else
+ return "";
+ end if;
+ end Image_Name_Id;
+
+ function Image_Iir_Staticness (Static: Iir_Staticness) return String is
+ begin
+ case Static is
+ when Unknown =>
+ return "???";
+ when None =>
+ return "none";
+ when Globally =>
+ return "global";
+ when Locally =>
+ return "local";
+ end case;
+ end Image_Iir_Staticness;
+
+ function Image_Boolean (Bool : Boolean) return String is
+ begin
+ if Bool then
+ return "true";
+ else
+ return "false";
+ end if;
+ end Image_Boolean;
+
+ function Image_Iir_Delay_Mechanism (Mech : Iir_Delay_Mechanism)
+ return String is
+ begin
+ case Mech is
+ when Iir_Inertial_Delay =>
+ return "inertial";
+ when Iir_Transport_Delay =>
+ return "transport";
+ end case;
+ end Image_Iir_Delay_Mechanism;
+
+ function Image_Iir_Lexical_Layout_Type (V : Iir_Lexical_Layout_Type)
+ return String is
+ begin
+ if (V and Iir_Lexical_Has_Mode) /= 0 then
+ return " +mode"
+ & Image_Iir_Lexical_Layout_Type (V and not Iir_Lexical_Has_Mode);
+ elsif (V and Iir_Lexical_Has_Class) /= 0 then
+ return " +class"
+ & Image_Iir_Lexical_Layout_Type (V and not Iir_Lexical_Has_Class);
+ elsif (V and Iir_Lexical_Has_Type) /= 0 then
+ return " +type"
+ & Image_Iir_Lexical_Layout_Type (V and not Iir_Lexical_Has_Type);
+ else
+ return "";
+ end if;
+ end Image_Iir_Lexical_Layout_Type;
+
+ function Image_Iir_Mode (Mode : Iir_Mode) return String is
+ begin
+ case Mode is
+ when Iir_Unknown_Mode =>
+ return "???";
+ when Iir_Linkage_Mode =>
+ return "linkage";
+ when Iir_Buffer_Mode =>
+ return "buffer";
+ when Iir_Out_Mode =>
+ return "out";
+ when Iir_Inout_Mode =>
+ return "inout";
+ when Iir_In_Mode =>
+ return "in";
+ end case;
+ end Image_Iir_Mode;
+
+ function Image_Iir_Signal_Kind (Kind : Iir_Signal_Kind) return String is
+ begin
+ case Kind is
+ when Iir_No_Signal_Kind =>
+ return "no";
+ when Iir_Register_Kind =>
+ return "register";
+ when Iir_Bus_Kind =>
+ return "bus";
+ end case;
+ end Image_Iir_Signal_Kind;
+
+ function Image_Iir_Pure_State (State : Iir_Pure_State) return String is
+ begin
+ case State is
+ when Pure =>
+ return "pure";
+ when Impure =>
+ return "impure";
+ when Maybe_Impure =>
+ return "maybe_impure";
+ when Unknown =>
+ return "unknown";
+ end case;
+ end Image_Iir_Pure_State;
+
+ function Image_Iir_All_Sensitized (Sig : Iir_All_Sensitized)
+ return String is
+ begin
+ case Sig is
+ when Unknown =>
+ return "???";
+ when No_Signal =>
+ return "no_signal";
+ when Read_Signal =>
+ return "read_signal";
+ when Invalid_Signal =>
+ return "invalid_signal";
+ end case;
+ end Image_Iir_All_Sensitized;
+
+ function Image_Iir_Constraint (Const : Iir_Constraint) return String is
+ begin
+ case Const is
+ when Unconstrained =>
+ return "unconstrained";
+ when Partially_Constrained =>
+ return "partially constrained";
+ when Fully_Constrained =>
+ return "fully constrained";
+ end case;
+ end Image_Iir_Constraint;
+
+ function Image_Date_State_Type (State : Date_State_Type) return String is
+ begin
+ case State is
+ when Date_Extern =>
+ return "extern";
+ when Date_Disk =>
+ return "disk";
+ when Date_Parse =>
+ return "parse";
+ when Date_Analyze =>
+ return "analyze";
+ end case;
+ end Image_Date_State_Type;
+
+ function Image_Tri_State_Type (State : Tri_State_Type) return String is
+ begin
+ case State is
+ when True =>
+ return "true";
+ when False =>
+ return "false";
+ when Unknown =>
+ return "unknown";
+ end case;
+ end Image_Tri_State_Type;
+
+ function Image_Time_Stamp_Id (Id : Time_Stamp_Id) return String
+ renames Files_Map.Get_Time_Stamp_String;
+
+ function Image_Iir_Predefined_Functions (F : Iir_Predefined_Functions)
+ return String is
+ begin
+ return Iir_Predefined_Functions'Image (F);
+ end Image_Iir_Predefined_Functions;
+
+ function Image_String_Id (S : String_Id) return String
+ renames Str_Table.Image;
+
+ procedure Disp_PSL_Node (N : PSL_Node; Indent : Natural) is
+ begin
+ Put_Indent (Indent);
+ PSL.Dump_Tree.Dump_Tree (N, True);
+ end Disp_PSL_Node;
+
+ procedure Disp_PSL_NFA (N : PSL_NFA; Indent : Natural) is
+ begin
+ null;
+ end Disp_PSL_NFA;
+
+ function Image_Location_Type (Loc : Location_Type) return String is
+ begin
+ return Errorout.Get_Location_Str (Loc);
+ end Image_Location_Type;
+
+ function Image_Iir_Direction (Dir : Iir_Direction) return String is
+ begin
+ case Dir is
+ when Iir_To =>
+ return "to";
+ when Iir_Downto =>
+ return "downto";
+ end case;
+ end Image_Iir_Direction;
+
+ function Image_Token_Type (Tok : Tokens.Token_Type) return String
+ renames Tokens.Image;
+
+ procedure Header (Str : String; Indent : Natural) is
+ begin
+ Put_Indent (Indent);
+ Put (Str);
+ Put (": ");
+ end Header;
+
+ procedure Disp_Header (N : Iir)
+ is
+ use Nodes_Meta;
+ K : Iir_Kind;
+ begin
+ if N = Null_Iir then
+ Put_Line ("*null*");
+ return;
+ end if;
+
+ K := Get_Kind (N);
+ Put (Get_Iir_Image (K));
+ if Has_Identifier (K) then
+ Put (' ');
+ Put (Image_Name_Id (Get_Identifier (N)));
+ end if;
+
+ Put (' ');
+ Disp_Iir_Number (N);
+
+ New_Line;
+ end Disp_Header;
+
+ procedure Disp_Iir (N : Iir;
+ Indent : Natural := 1;
+ Flat : Boolean := False)
+ is
+ Sub_Indent : constant Natural := Indent + 1;
+ begin
+ Disp_Header (N);
+
+ if Flat or else N = Null_Iir then
+ return;
+ end if;
+
+ Header ("location", Indent);
+ Put_Line (Image_Location_Type (Get_Location (N)));
+
+ -- Protect against infinite recursions.
+ if Indent > 20 then
+ Put_Indent (Indent);
+ Put_Line ("...");
+ return;
+ end if;
+
+ declare
+ use Nodes_Meta;
+ Fields : constant Fields_Array := Get_Fields (Get_Kind (N));
+ F : Fields_Enum;
+ begin
+ for I in Fields'Range loop
+ F := Fields (I);
+ Header (Get_Field_Image (F), Indent);
+ case Get_Field_Type (F) is
+ when Type_Iir =>
+ case Get_Field_Attribute (F) is
+ when Attr_None =>
+ Disp_Iir (Get_Iir (N, F), Sub_Indent);
+ when Attr_Ref =>
+ Disp_Iir (Get_Iir (N, F), Sub_Indent, True);
+ when Attr_Maybe_Ref =>
+ Disp_Iir (Get_Iir (N, F), Sub_Indent, Get_Is_Ref (N));
+ when Attr_Chain =>
+ Disp_Chain (Get_Iir (N, F), Sub_Indent);
+ when Attr_Chain_Next =>
+ Disp_Iir_Number (Get_Iir (N, F));
+ New_Line;
+ when Attr_Of_Ref =>
+ raise Internal_Error;
+ end case;
+ when Type_Iir_List =>
+ Disp_Iir_List (Get_Iir_List (N, F), Sub_Indent,
+ Get_Field_Attribute (F) = Attr_Of_Ref);
+ when Type_PSL_NFA =>
+ Disp_PSL_NFA (Get_PSL_NFA (N, F), Sub_Indent);
+ when Type_String_Id =>
+ Put_Line (Image_String_Id (Get_String_Id (N, F)));
+ when Type_PSL_Node =>
+ Disp_PSL_Node (Get_PSL_Node (N, F), Sub_Indent);
+ when Type_Source_Ptr =>
+ Put_Line (Source_Ptr'Image (Get_Source_Ptr (N, F)));
+ when Type_Date_Type =>
+ Put_Line (Date_Type'Image (Get_Date_Type (N, F)));
+ when Type_Base_Type =>
+ Put_Line (Base_Type'Image (Get_Base_Type (N, F)));
+ when Type_Iir_Constraint =>
+ Put_Line (Image_Iir_Constraint
+ (Get_Iir_Constraint (N, F)));
+ when Type_Iir_Mode =>
+ Put_Line (Image_Iir_Mode (Get_Iir_Mode (N, F)));
+ when Type_Iir_Index32 =>
+ Put_Line (Iir_Index32'Image (Get_Iir_Index32 (N, F)));
+ when Type_Iir_Int64 =>
+ Put_Line (Iir_Int64'Image (Get_Iir_Int64 (N, F)));
+ when Type_Boolean =>
+ Put_Line (Image_Boolean
+ (Get_Boolean (N, F)));
+ when Type_Iir_Staticness =>
+ Put_Line (Image_Iir_Staticness
+ (Get_Iir_Staticness (N, F)));
+ when Type_Date_State_Type =>
+ Put_Line (Image_Date_State_Type
+ (Get_Date_State_Type (N, F)));
+ when Type_Iir_All_Sensitized =>
+ Put_Line (Image_Iir_All_Sensitized
+ (Get_Iir_All_Sensitized (N, F)));
+ when Type_Iir_Signal_Kind =>
+ Put_Line (Image_Iir_Signal_Kind
+ (Get_Iir_Signal_Kind (N, F)));
+ when Type_Tri_State_Type =>
+ Put_Line (Image_Tri_State_Type
+ (Get_Tri_State_Type (N, F)));
+ when Type_Iir_Pure_State =>
+ Put_Line (Image_Iir_Pure_State
+ (Get_Iir_Pure_State (N, F)));
+ when Type_Iir_Delay_Mechanism =>
+ Put_Line (Image_Iir_Delay_Mechanism
+ (Get_Iir_Delay_Mechanism (N, F)));
+ when Type_Iir_Lexical_Layout_Type =>
+ Put_Line (Image_Iir_Lexical_Layout_Type
+ (Get_Iir_Lexical_Layout_Type (N, F)));
+ when Type_Iir_Predefined_Functions =>
+ Put_Line (Image_Iir_Predefined_Functions
+ (Get_Iir_Predefined_Functions (N, F)));
+ when Type_Iir_Direction =>
+ Put_Line (Image_Iir_Direction
+ (Get_Iir_Direction (N, F)));
+ when Type_Location_Type =>
+ Put_Line (Image_Location_Type
+ (Get_Location_Type (N, F)));
+ when Type_Iir_Int32 =>
+ Put_Line (Iir_Int32'Image (Get_Iir_Int32 (N, F)));
+ when Type_Int32 =>
+ Put_Line (Int32'Image (Get_Int32 (N, F)));
+ when Type_Iir_Fp64 =>
+ Put_Line (Iir_Fp64'Image (Get_Iir_Fp64 (N, F)));
+ when Type_Time_Stamp_Id =>
+ Put_Line (Image_Time_Stamp_Id
+ (Get_Time_Stamp_Id (N, F)));
+ when Type_Token_Type =>
+ Put_Line (Image_Token_Type (Get_Token_Type (N, F)));
+ when Type_Name_Id =>
+ Put_Line (Image_Name_Id (Get_Name_Id (N, F)));
+ end case;
+ end loop;
+ end;
+ end Disp_Iir;
+
+ procedure Disp_Tree_For_Psl (N : Int32) is
+ begin
+ Disp_Tree_Flat (Iir (N), 1);
+ end Disp_Tree_For_Psl;
+
+ procedure Disp_Tree (Tree : Iir;
+ Flat : Boolean := false) is
+ begin
+ Disp_Iir (Tree, 1, Flat);
+ end Disp_Tree;
+end Disp_Tree;
diff --git a/src/disp_tree.ads b/src/disp_tree.ads
new file mode 100644
index 000000000..94b1d29e3
--- /dev/null
+++ b/src/disp_tree.ads
@@ -0,0 +1,27 @@
+-- Node displaying (for debugging).
+-- Copyright (C) 2002, 2003, 2004, 2005, 2009 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with Iirs; use Iirs;
+
+package Disp_Tree is
+ -- Disp TREE recursively.
+ procedure Disp_Tree (Tree : Iir;
+ Flat : Boolean := False);
+
+ procedure Disp_Tree_For_Psl (N : Int32);
+end Disp_Tree;
diff --git a/src/disp_vhdl.adb b/src/disp_vhdl.adb
new file mode 100644
index 000000000..73a8e420f
--- /dev/null
+++ b/src/disp_vhdl.adb
@@ -0,0 +1,3247 @@
+-- VHDL regeneration from internal nodes.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+-- Re-print a tree as VHDL sources. Except for comments and parenthesis, the
+-- sequence of tokens displayed is the same as the sequence of tokens in the
+-- input file. If parenthesis are kept by the parser, the only differences
+-- are comments and layout.
+with GNAT.OS_Lib;
+with Std_Package;
+with Flags; use Flags;
+with Errorout; use Errorout;
+with Iirs_Utils; use Iirs_Utils;
+with Name_Table;
+with Std_Names;
+with Tokens;
+with PSL.Nodes;
+with PSL.Prints;
+with PSL.NFAs;
+
+package body Disp_Vhdl is
+
+ subtype Count is Positive;
+
+ Col : Count := 1;
+
+ IO_Error : exception;
+
+ -- Disp the name of DECL.
+ procedure Disp_Name_Of (Decl: Iir);
+
+ -- Indentation for nested declarations and statements.
+ Indentation: constant Count := 2;
+
+ -- Line length (used to try to have a nice display).
+ Line_Length : constant Count := 80;
+
+ -- If True, display extra parenthesis to make priority of operators
+ -- explicit.
+ Flag_Parenthesis : constant Boolean := False;
+
+ -- If set, disp after a string literal the type enclosed into brackets.
+ Disp_String_Literal_Type: constant Boolean := False;
+
+ -- If set, disp position number of associations
+ --Disp_Position_Number: constant Boolean := False;
+
+-- procedure Disp_Tab (Tab: Natural) is
+-- Blanks : String (1 .. Tab) := (others => ' ');
+-- begin
+-- Put (Blanks);
+-- end Disp_Tab;
+
+ procedure Disp_Type (A_Type: Iir);
+ procedure Disp_Nature (Nature : Iir);
+ procedure Disp_Range (Rng : Iir);
+
+ procedure Disp_Concurrent_Statement (Stmt: Iir);
+ procedure Disp_Concurrent_Statement_Chain (Parent: Iir; Indent : Count);
+ procedure Disp_Declaration_Chain (Parent : Iir; Indent: Count);
+ procedure Disp_Process_Statement (Process: Iir);
+ procedure Disp_Sequential_Statements (First : Iir);
+ procedure Disp_Choice (Choice: in out Iir);
+ procedure Disp_Association_Chain (Chain : Iir);
+ procedure Disp_Block_Configuration
+ (Block: Iir_Block_Configuration; Indent: Count);
+ procedure Disp_Subprogram_Declaration (Subprg: Iir);
+ procedure Disp_Binding_Indication (Bind : Iir; Indent : Count);
+ procedure Disp_Subtype_Indication (Def : Iir; Full_Decl : Boolean := False);
+ procedure Disp_Parametered_Attribute (Name : String; Expr : Iir);
+
+ procedure Put (Str : String)
+ is
+ use GNAT.OS_Lib;
+ Len : constant Natural := Str'Length;
+ begin
+ if Write (Standout, Str'Address, Len) /= Len then
+ raise IO_Error;
+ end if;
+ Col := Col + Len;
+ end Put;
+
+ procedure Put (C : Character) is
+ begin
+ Put ((1 => C));
+ end Put;
+
+ procedure New_Line is
+ begin
+ Put (ASCII.LF);
+ Col := 1;
+ end New_Line;
+
+ procedure Put_Line (Str : String) is
+ begin
+ Put (Str);
+ New_Line;
+ end Put_Line;
+
+ procedure Set_Col (P : Count) is
+ begin
+ if Col = P then
+ return;
+ end if;
+ if Col >= P then
+ New_Line;
+ end if;
+ Put ((Col .. P - 1 => ' '));
+ end Set_Col;
+
+ procedure Disp_Ident (Id: Name_Id) is
+ begin
+ Put (Name_Table.Image (Id));
+ end Disp_Ident;
+
+ procedure Disp_Identifier (Node : Iir)
+ is
+ Ident : Name_Id;
+ begin
+ Ident := Get_Identifier (Node);
+ if Ident /= Null_Identifier then
+ Disp_Ident (Ident);
+ else
+ Put ("");
+ end if;
+ end Disp_Identifier;
+
+ procedure Disp_Character_Literal (Lit: Iir_Character_Literal) is
+ begin
+ Put (''' & Name_Table.Get_Character (Get_Identifier (Lit)) & ''');
+ end Disp_Character_Literal;
+
+ procedure Disp_Function_Name (Func: Iir)
+ is
+ use Name_Table;
+ use Std_Names;
+ Id: Name_Id;
+ begin
+ Id := Get_Identifier (Func);
+ case Id is
+ when Name_Id_Operators
+ | Name_Word_Operators
+ | Name_Xnor
+ | Name_Shift_Operators =>
+ Put ("""");
+ Put (Image (Id));
+ Put ("""");
+ when others =>
+ Disp_Ident (Id);
+ end case;
+ end Disp_Function_Name;
+
+ -- Disp the name of DECL.
+ procedure Disp_Name_Of (Decl: Iir) is
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Component_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Element_Declaration
+ | Iir_Kind_Record_Element_Constraint
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Library_Declaration
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Nature_Declaration
+ | Iir_Kind_Terminal_Declaration
+ | Iir_Kinds_Quantity_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Character_Literal
+ | Iir_Kinds_Process_Statement =>
+ Disp_Identifier (Decl);
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ Put ('<');
+ Disp_Ident (Get_Identifier (Decl));
+ Put ('>');
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration =>
+ Disp_Function_Name (Decl);
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ Disp_Identifier (Decl);
+ when Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Physical_Type_Definition
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Protected_Type_Declaration =>
+ -- Used for 'end' DECL_NAME.
+ Disp_Identifier (Get_Type_Declarator (Decl));
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Disp_Ident (Get_Label (Decl));
+ when Iir_Kind_Design_Unit =>
+ Disp_Name_Of (Get_Library_Unit (Decl));
+ when Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Simple_Name =>
+ Disp_Identifier (Decl);
+ when Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ declare
+ Ident : constant Name_Id := Get_Label (Decl);
+ begin
+ if Ident /= Null_Identifier then
+ Disp_Ident (Ident);
+ else
+ Put ("");
+ end if;
+ end;
+ when Iir_Kind_Package_Body =>
+ Disp_Identifier (Get_Package (Decl));
+ when Iir_Kind_Procedure_Body
+ | Iir_Kind_Function_Body =>
+ Disp_Function_Name (Get_Subprogram_Specification (Decl));
+ when Iir_Kind_Protected_Type_Body =>
+ Disp_Identifier
+ (Get_Type_Declarator (Get_Protected_Type_Declaration (Decl)));
+ when others =>
+ Error_Kind ("disp_name_of", Decl);
+ end case;
+ end Disp_Name_Of;
+
+ procedure Disp_Name (Name: Iir) is
+ begin
+ case Get_Kind (Name) is
+ when Iir_Kind_Selected_By_All_Name =>
+ Disp_Name (Get_Prefix (Name));
+ Put (".all");
+ when Iir_Kind_Dereference =>
+ Disp_Name (Get_Prefix (Name));
+ Put (".all");
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Character_Literal =>
+ Put (Iirs_Utils.Image_Identifier (Name));
+ when Iir_Kind_Operator_Symbol =>
+ Disp_Function_Name (Name);
+ when Iir_Kind_Selected_Name =>
+ Disp_Name (Get_Prefix (Name));
+ Put (".");
+ Disp_Function_Name (Name);
+ when Iir_Kind_Parenthesis_Name =>
+ Disp_Name (Get_Prefix (Name));
+ Disp_Association_Chain (Get_Association_Chain (Name));
+ when Iir_Kind_Base_Attribute =>
+ Disp_Name (Get_Prefix (Name));
+ Put ("'base");
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kinds_Interface_Object_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Terminal_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Group_Template_Declaration =>
+ Disp_Name_Of (Name);
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ Disp_Range (Name);
+ when others =>
+ Error_Kind ("disp_name", Name);
+ end case;
+ end Disp_Name;
+
+ procedure Disp_Range (Rng : Iir) is
+ begin
+ case Get_Kind (Rng) is
+ when Iir_Kind_Range_Expression =>
+ declare
+ Origin : constant Iir := Get_Range_Origin (Rng);
+ begin
+ if Origin /= Null_Iir then
+ Disp_Expression (Origin);
+ else
+ Disp_Expression (Get_Left_Limit (Rng));
+ if Get_Direction (Rng) = Iir_To then
+ Put (" to ");
+ else
+ Put (" downto ");
+ end if;
+ Disp_Expression (Get_Right_Limit (Rng));
+ end if;
+ end;
+ when Iir_Kind_Range_Array_Attribute =>
+ Disp_Parametered_Attribute ("range", Rng);
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ Disp_Parametered_Attribute ("reverse_range", Rng);
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ Disp_Name (Rng);
+ when others =>
+ Disp_Subtype_Indication (Rng);
+ -- Disp_Name_Of (Get_Type_Declarator (Decl));
+ end case;
+ end Disp_Range;
+
+ procedure Disp_After_End (Decl : Iir; Name : String) is
+ begin
+ if Get_End_Has_Reserved_Id (Decl) then
+ Put (' ');
+ Put (Name);
+ end if;
+ if Get_End_Has_Identifier (Decl) then
+ Put (' ');
+ Disp_Name_Of (Decl);
+ end if;
+ Put (';');
+ New_Line;
+ end Disp_After_End;
+
+ procedure Disp_End (Decl : Iir; Name : String) is
+ begin
+ Put ("end");
+ Disp_After_End (Decl, Name);
+ end Disp_End;
+
+ procedure Disp_End_Label (Stmt : Iir; Name : String) is
+ begin
+ Put ("end");
+ Put (' ');
+ Put (Name);
+ if Get_End_Has_Identifier (Stmt) then
+ Put (' ');
+ Disp_Ident (Get_Label (Stmt));
+ end if;
+ Put (';');
+ New_Line;
+ end Disp_End_Label;
+
+ procedure Disp_Use_Clause (Clause: Iir_Use_Clause)
+ is
+ Name : Iir;
+ begin
+ Put ("use ");
+ Name := Clause;
+ loop
+ Disp_Name (Get_Selected_Name (Name));
+ Name := Get_Use_Clause_Chain (Name);
+ exit when Name = Null_Iir;
+ Put (", ");
+ end loop;
+ Put_Line (";");
+ end Disp_Use_Clause;
+
+ -- Disp the resolution function (if any) of type definition DEF.
+ procedure Disp_Resolution_Indication (Subtype_Def: Iir)
+ is
+ procedure Inner (Ind : Iir) is
+ begin
+ case Get_Kind (Ind) is
+ when Iir_Kinds_Denoting_Name =>
+ Disp_Name (Ind);
+ when Iir_Kind_Array_Element_Resolution =>
+ Put ("(");
+ Inner (Get_Resolution_Indication (Ind));
+ Put (")");
+ when others =>
+ Error_Kind ("disp_resolution_indication", Ind);
+ end case;
+ end Inner;
+
+ Ind : Iir;
+ begin
+ case Get_Kind (Subtype_Def) is
+ when Iir_Kind_Access_Subtype_Definition =>
+ -- No resolution indication on access subtype.
+ return;
+ when others =>
+ Ind := Get_Resolution_Indication (Subtype_Def);
+ if Ind = Null_Iir then
+ -- No resolution indication.
+ return;
+ end if;
+ end case;
+
+ declare
+ Type_Mark : constant Iir := Get_Denoted_Type_Mark (Subtype_Def);
+ begin
+ if Get_Kind (Type_Mark) in Iir_Kinds_Subtype_Definition
+ and then Get_Resolution_Indication (Type_Mark) = Ind
+ then
+ -- Resolution indication was inherited from the type_mark.
+ return;
+ end if;
+ end;
+
+ Inner (Ind);
+ Put (" ");
+ end Disp_Resolution_Indication;
+
+ procedure Disp_Integer_Subtype_Definition
+ (Def: Iir_Integer_Subtype_Definition)
+ is
+ Base_Type: Iir_Integer_Type_Definition;
+ Decl: Iir;
+ begin
+ if Def /= Std_Package.Universal_Integer_Subtype_Definition then
+ Base_Type := Get_Base_Type (Def);
+ Decl := Get_Type_Declarator (Base_Type);
+ if Base_Type /= Std_Package.Universal_Integer_Subtype_Definition
+ and then Def /= Decl
+ then
+ Disp_Name_Of (Decl);
+ Put (" ");
+ end if;
+ end if;
+ Disp_Resolution_Indication (Def);
+ Put ("range ");
+ Disp_Expression (Get_Range_Constraint (Def));
+ Put (";");
+ end Disp_Integer_Subtype_Definition;
+
+ procedure Disp_Floating_Subtype_Definition
+ (Def: Iir_Floating_Subtype_Definition)
+ is
+ Base_Type: Iir_Floating_Type_Definition;
+ Decl: Iir;
+ begin
+ if Def /= Std_Package.Universal_Real_Subtype_Definition then
+ Base_Type := Get_Base_Type (Def);
+ Decl := Get_Type_Declarator (Base_Type);
+ if Base_Type /= Std_Package.Universal_Real_Subtype_Definition
+ and then Def /= Decl
+ then
+ Disp_Name_Of (Decl);
+ Put (" ");
+ end if;
+ end if;
+ Disp_Resolution_Indication (Def);
+ Put ("range ");
+ Disp_Expression (Get_Range_Constraint (Def));
+ Put (";");
+ end Disp_Floating_Subtype_Definition;
+
+ procedure Disp_Element_Constraint (Def : Iir; Type_Mark : Iir);
+
+ procedure Disp_Array_Element_Constraint (Def : Iir; Type_Mark : Iir)
+ is
+ Def_El : constant Iir := Get_Element_Subtype (Def);
+ Tm_El : constant Iir := Get_Element_Subtype (Type_Mark);
+ Has_Index : constant Boolean := Get_Index_Constraint_Flag (Def);
+ Has_Own_Element_Subtype : constant Boolean := Def_El /= Tm_El;
+ Index : Iir;
+ begin
+ if not Has_Index and not Has_Own_Element_Subtype then
+ return;
+ end if;
+
+ if Get_Constraint_State (Type_Mark) /= Fully_Constrained
+ and then Has_Index
+ then
+ Put (" (");
+ for I in Natural loop
+ Index := Get_Nth_Element (Get_Index_Subtype_List (Def), I);
+ exit when Index = Null_Iir;
+ if I /= 0 then
+ Put (", ");
+ end if;
+ --Disp_Expression (Get_Range_Constraint (Index));
+ Disp_Range (Index);
+ end loop;
+ Put (")");
+ end if;
+
+ if Has_Own_Element_Subtype
+ and then Get_Kind (Def_El) in Iir_Kinds_Composite_Type_Definition
+ then
+ Disp_Element_Constraint (Def_El, Tm_El);
+ end if;
+ end Disp_Array_Element_Constraint;
+
+ procedure Disp_Record_Element_Constraint (Def : Iir)
+ is
+ El_List : constant Iir_List := Get_Elements_Declaration_List (Def);
+ El : Iir;
+ Has_El : Boolean := False;
+ begin
+ for I in Natural loop
+ El := Get_Nth_Element (El_List, I);
+ exit when El = Null_Iir;
+ if Get_Kind (El) = Iir_Kind_Record_Element_Constraint
+ and then Get_Parent (El) = Def
+ then
+ if Has_El then
+ Put (", ");
+ else
+ Put ("(");
+ Has_El := True;
+ end if;
+ Disp_Name_Of (El);
+ Disp_Element_Constraint (Get_Type (El),
+ Get_Base_Type (Get_Type (El)));
+ end if;
+ end loop;
+ if Has_El then
+ Put (")");
+ end if;
+ end Disp_Record_Element_Constraint;
+
+ procedure Disp_Element_Constraint (Def : Iir; Type_Mark : Iir) is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Record_Subtype_Definition =>
+ Disp_Record_Element_Constraint (Def);
+ when Iir_Kind_Array_Subtype_Definition =>
+ Disp_Array_Element_Constraint (Def, Type_Mark);
+ when others =>
+ Error_Kind ("disp_element_constraint", Def);
+ end case;
+ end Disp_Element_Constraint;
+
+ procedure Disp_Tolerance_Opt (N : Iir) is
+ Tol : constant Iir := Get_Tolerance (N);
+ begin
+ if Tol /= Null_Iir then
+ Put ("tolerance ");
+ Disp_Expression (Tol);
+ end if;
+ end Disp_Tolerance_Opt;
+
+ procedure Disp_Subtype_Indication (Def : Iir; Full_Decl : Boolean := False)
+ is
+ Type_Mark : Iir;
+ Base_Type : Iir;
+ Decl : Iir;
+ begin
+ if Get_Kind (Def) in Iir_Kinds_Denoting_Name then
+ Disp_Name (Def);
+ return;
+ end if;
+
+ Decl := Get_Type_Declarator (Def);
+ if not Full_Decl and then Decl /= Null_Iir then
+ Disp_Name_Of (Decl);
+ return;
+ end if;
+
+ -- Resolution function name.
+ Disp_Resolution_Indication (Def);
+
+ -- type mark.
+ Type_Mark := Get_Subtype_Type_Mark (Def);
+ if Type_Mark /= Null_Iir then
+ Disp_Name (Type_Mark);
+ Type_Mark := Get_Type (Type_Mark);
+ end if;
+
+ Base_Type := Get_Base_Type (Def);
+ case Get_Kind (Base_Type) is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Physical_Type_Definition =>
+ if Type_Mark = Null_Iir
+ or else Get_Range_Constraint (Def)
+ /= Get_Range_Constraint (Type_Mark)
+ then
+ if Type_Mark /= Null_Iir then
+ Put (" range ");
+ end if;
+ Disp_Expression (Get_Range_Constraint (Def));
+ end if;
+ if Get_Kind (Base_Type) = Iir_Kind_Floating_Type_Definition then
+ Disp_Tolerance_Opt (Def);
+ end if;
+ when Iir_Kind_Access_Type_Definition =>
+ declare
+ Des_Ind : constant Iir :=
+ Get_Designated_Subtype_Indication (Def);
+ begin
+ if Des_Ind /= Null_Iir then
+ pragma Assert
+ (Get_Kind (Des_Ind) = Iir_Kind_Array_Subtype_Definition);
+ Disp_Array_Element_Constraint
+ (Des_Ind, Get_Designated_Type (Base_Type));
+ end if;
+ end;
+ when Iir_Kind_Array_Type_Definition =>
+ if Type_Mark = Null_Iir then
+ Disp_Array_Element_Constraint (Def, Def);
+ else
+ Disp_Array_Element_Constraint (Def, Type_Mark);
+ end if;
+ when Iir_Kind_Record_Type_Definition =>
+ Disp_Record_Element_Constraint (Def);
+ when others =>
+ Error_Kind ("disp_subtype_indication", Base_Type);
+ end case;
+ end Disp_Subtype_Indication;
+
+ procedure Disp_Enumeration_Type_Definition
+ (Def: Iir_Enumeration_Type_Definition)
+ is
+ Len : Count;
+ Start_Col: Count;
+ Decl: Name_Id;
+ A_Lit: Iir; --Enumeration_Literal_Acc;
+ begin
+ for I in Natural loop
+ A_Lit := Get_Nth_Element (Get_Enumeration_Literal_List (Def), I);
+ exit when A_Lit = Null_Iir;
+ if I = Natural'first then
+ Put ("(");
+ Start_Col := Col;
+ else
+ Put (", ");
+ end if;
+ Decl := Get_Identifier (A_Lit);
+ if Name_Table.Is_Character (Decl) then
+ Len := 3;
+ else
+ Len := Count (Name_Table.Get_Name_Length (Decl));
+ end if;
+ if Col + Len + 2 > Line_Length then
+ New_Line;
+ Set_Col (Start_Col);
+ end if;
+ Disp_Name_Of (A_Lit);
+ end loop;
+ Put (");");
+ end Disp_Enumeration_Type_Definition;
+
+ procedure Disp_Enumeration_Subtype_Definition
+ (Def: Iir_Enumeration_Subtype_Definition)
+ is
+ begin
+ Disp_Resolution_Indication (Def);
+ Put ("range ");
+ Disp_Range (Def);
+ Put (";");
+ end Disp_Enumeration_Subtype_Definition;
+
+ procedure Disp_Discrete_Range (Iterator: Iir) is
+ begin
+ if Get_Kind (Iterator) in Iir_Kinds_Subtype_Definition then
+ Disp_Subtype_Indication (Iterator);
+ else
+ Disp_Range (Iterator);
+ end if;
+ end Disp_Discrete_Range;
+
+ procedure Disp_Array_Subtype_Definition (Def: Iir_Array_Subtype_Definition)
+ is
+ Index: Iir;
+ begin
+ Disp_Resolution_Indication (Def);
+
+ Put ("array (");
+ for I in Natural loop
+ Index := Get_Nth_Element (Get_Index_Subtype_List (Def), I);
+ exit when Index = Null_Iir;
+ if I /= 0 then
+ Put (", ");
+ end if;
+ Disp_Discrete_Range (Index);
+ end loop;
+ Put (") of ");
+ Disp_Subtype_Indication (Get_Element_Subtype (Def));
+ end Disp_Array_Subtype_Definition;
+
+ procedure Disp_Array_Type_Definition (Def: Iir_Array_Type_Definition) is
+ Index: Iir;
+ begin
+ Put ("array (");
+ for I in Natural loop
+ Index := Get_Nth_Element (Get_Index_Subtype_List (Def), I);
+ exit when Index = Null_Iir;
+ if I /= 0 then
+ Put (", ");
+ end if;
+ Disp_Name (Index);
+ Put (" range <>");
+ end loop;
+ Put (") of ");
+ Disp_Subtype_Indication (Get_Element_Subtype_Indication (Def));
+ Put (";");
+ end Disp_Array_Type_Definition;
+
+ procedure Disp_Physical_Literal (Lit: Iir) is
+ begin
+ case Get_Kind (Lit) is
+ when Iir_Kind_Physical_Int_Literal =>
+ Disp_Int64 (Get_Value (Lit));
+ when Iir_Kind_Physical_Fp_Literal =>
+ Disp_Fp64 (Get_Fp_Value (Lit));
+ when Iir_Kind_Unit_Declaration =>
+ Disp_Identifier (Lit);
+ return;
+ when others =>
+ Error_Kind ("disp_physical_literal", Lit);
+ end case;
+ Put (' ');
+ Disp_Name (Get_Unit_Name (Lit));
+ end Disp_Physical_Literal;
+
+ procedure Disp_Physical_Subtype_Definition
+ (Def: Iir_Physical_Subtype_Definition) is
+ begin
+ Disp_Resolution_Indication (Def);
+ Put ("range ");
+ Disp_Expression (Get_Range_Constraint (Def));
+ end Disp_Physical_Subtype_Definition;
+
+ procedure Disp_Record_Type_Definition
+ (Def: Iir_Record_Type_Definition; Indent: Count)
+ is
+ List : Iir_List;
+ El: Iir_Element_Declaration;
+ Reindent : Boolean;
+ begin
+ Put_Line ("record");
+ Set_Col (Indent);
+ List := Get_Elements_Declaration_List (Def);
+ Reindent := True;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if Reindent then
+ Set_Col (Indent + Indentation);
+ end if;
+ Disp_Identifier (El);
+ if Get_Has_Identifier_List (El) then
+ Put (", ");
+ Reindent := False;
+ else
+ Put (" : ");
+ Disp_Subtype_Indication (Get_Type (El));
+ Put_Line (";");
+ Reindent := True;
+ end if;
+ end loop;
+ Set_Col (Indent);
+ Disp_End (Def, "record");
+ end Disp_Record_Type_Definition;
+
+ procedure Disp_Designator_List (List: Iir_List) is
+ El: Iir;
+ begin
+ if List = Null_Iir_List then
+ return;
+ elsif List = Iir_List_All then
+ Put ("all");
+ return;
+ end if;
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if I > 0 then
+ Put (", ");
+ end if;
+ Disp_Expression (El);
+ --Disp_Text_Literal (El);
+ end loop;
+ end Disp_Designator_List;
+
+ -- Display the full definition of a type, ie the sequence that can create
+ -- such a type.
+ procedure Disp_Type_Definition (Def: Iir; Indent: Count) is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Enumeration_Type_Definition =>
+ Disp_Enumeration_Type_Definition (Def);
+ when Iir_Kind_Enumeration_Subtype_Definition =>
+ Disp_Enumeration_Subtype_Definition (Def);
+ when Iir_Kind_Integer_Subtype_Definition =>
+ Disp_Integer_Subtype_Definition (Def);
+ when Iir_Kind_Floating_Subtype_Definition =>
+ Disp_Floating_Subtype_Definition (Def);
+ when Iir_Kind_Array_Type_Definition =>
+ Disp_Array_Type_Definition (Def);
+ when Iir_Kind_Array_Subtype_Definition =>
+ Disp_Array_Subtype_Definition (Def);
+ when Iir_Kind_Physical_Subtype_Definition =>
+ Disp_Physical_Subtype_Definition (Def);
+ when Iir_Kind_Record_Type_Definition =>
+ Disp_Record_Type_Definition (Def, Indent);
+ when Iir_Kind_Access_Type_Definition =>
+ Put ("access ");
+ Disp_Subtype_Indication (Get_Designated_Subtype_Indication (Def));
+ Put (';');
+ when Iir_Kind_File_Type_Definition =>
+ Put ("file of ");
+ Disp_Subtype_Indication (Get_File_Type_Mark (Def));
+ Put (';');
+ when Iir_Kind_Protected_Type_Declaration =>
+ Put_Line ("protected");
+ Disp_Declaration_Chain (Def, Indent + Indentation);
+ Set_Col (Indent);
+ Disp_End (Def, "protected");
+ when Iir_Kind_Integer_Type_Definition =>
+ Put ("");
+ when Iir_Kind_Floating_Type_Definition =>
+ Put ("");
+ when Iir_Kind_Physical_Type_Definition =>
+ Put ("");
+ when others =>
+ Error_Kind ("disp_type_definition", Def);
+ end case;
+ end Disp_Type_Definition;
+
+ procedure Disp_Type_Declaration (Decl: Iir_Type_Declaration)
+ is
+ Indent: Count;
+ Def : Iir;
+ begin
+ Indent := Col;
+ Put ("type ");
+ Disp_Name_Of (Decl);
+ Def := Get_Type_Definition (Decl);
+ if Def = Null_Iir
+ or else Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition
+ then
+ Put_Line (";");
+ else
+ Put (" is ");
+ Disp_Type_Definition (Def, Indent);
+ New_Line;
+ end if;
+ end Disp_Type_Declaration;
+
+ procedure Disp_Anonymous_Type_Declaration
+ (Decl: Iir_Anonymous_Type_Declaration)
+ is
+ Def : constant Iir := Get_Type_Definition (Decl);
+ Indent: constant Count := Col;
+ begin
+ Put ("type ");
+ Disp_Identifier (Decl);
+ Put (" is ");
+ case Get_Kind (Def) is
+ when Iir_Kind_Array_Type_Definition =>
+ declare
+ St : constant Iir := Get_Subtype_Definition (Decl);
+ Indexes : constant Iir_List := Get_Index_Subtype_List (St);
+ Index : Iir;
+ begin
+ Put ("array (");
+ for I in Natural loop
+ Index := Get_Nth_Element (Indexes, I);
+ exit when Index = Null_Iir;
+ if I /= 0 then
+ Put (", ");
+ end if;
+ Disp_Discrete_Range (Index);
+ end loop;
+ Put (") of ");
+ Disp_Subtype_Indication (Get_Element_Subtype_Indication (Def));
+ Put (";");
+ end;
+ when Iir_Kind_Physical_Type_Definition =>
+ declare
+ St : constant Iir := Get_Subtype_Definition (Decl);
+ Unit : Iir_Unit_Declaration;
+ begin
+ Put ("range ");
+ Disp_Expression (Get_Range_Constraint (St));
+ Put_Line (" units");
+ Set_Col (Indent + Indentation);
+ Unit := Get_Unit_Chain (Def);
+ Disp_Identifier (Unit);
+ Put_Line (";");
+ Unit := Get_Chain (Unit);
+ while Unit /= Null_Iir loop
+ Set_Col (Indent + Indentation);
+ Disp_Identifier (Unit);
+ Put (" = ");
+ Disp_Expression (Get_Physical_Literal (Unit));
+ Put_Line (";");
+ Unit := Get_Chain (Unit);
+ end loop;
+ Set_Col (Indent);
+ Disp_End (Def, "units");
+ end;
+ when Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Integer_Type_Definition =>
+ declare
+ St : constant Iir := Get_Subtype_Definition (Decl);
+ begin
+ Put ("range ");
+ Disp_Expression (Get_Range_Constraint (St));
+ Put (";");
+ end;
+ when others =>
+ Disp_Type_Definition (Def, Indent);
+ end case;
+ New_Line;
+ end Disp_Anonymous_Type_Declaration;
+
+ procedure Disp_Subtype_Declaration (Decl: in Iir_Subtype_Declaration)
+ is
+ Def : constant Iir := Get_Type (Decl);
+ Bt_Decl : constant Iir := Get_Type_Declarator (Get_Base_Type (Def));
+ begin
+ if Get_Identifier (Decl) = Get_Identifier (Bt_Decl) then
+ Put ("-- ");
+ end if;
+ Put ("subtype ");
+ Disp_Name_Of (Decl);
+ Put (" is ");
+ Disp_Subtype_Indication (Def, True);
+ Put_Line (";");
+ end Disp_Subtype_Declaration;
+
+ procedure Disp_Type (A_Type: Iir)
+ is
+ Decl: Iir;
+ begin
+ Decl := Get_Type_Declarator (A_Type);
+ if Decl /= Null_Iir then
+ Disp_Name_Of (Decl);
+ else
+ case Get_Kind (A_Type) is
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Integer_Type_Definition =>
+ raise Program_Error;
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ Disp_Subtype_Indication (A_Type);
+ when Iir_Kind_Array_Subtype_Definition =>
+ Disp_Subtype_Indication (A_Type);
+ when others =>
+ Error_Kind ("disp_type", A_Type);
+ end case;
+ end if;
+ end Disp_Type;
+
+ procedure Disp_Nature_Definition (Def : Iir) is
+ begin
+ case Get_Kind (Def) is
+ when Iir_Kind_Scalar_Nature_Definition =>
+ Disp_Subtype_Indication (Get_Across_Type (Def));
+ Put (" across ");
+ Disp_Subtype_Indication (Get_Through_Type (Def));
+ Put (" through ");
+ Disp_Name_Of (Get_Reference (Def));
+ Put (" reference");
+ when others =>
+ Error_Kind ("disp_nature_definition", Def);
+ end case;
+ end Disp_Nature_Definition;
+
+ procedure Disp_Nature_Declaration (Decl : Iir) is
+ begin
+ Put ("nature ");
+ Disp_Name_Of (Decl);
+ Put (" is ");
+ Disp_Nature_Definition (Get_Nature (Decl));
+ Put_Line (";");
+ end Disp_Nature_Declaration;
+
+ procedure Disp_Nature (Nature : Iir)
+ is
+ Decl: Iir;
+ begin
+ Decl := Get_Nature_Declarator (Nature);
+ if Decl /= Null_Iir then
+ Disp_Name_Of (Decl);
+ else
+ Error_Kind ("disp_nature", Nature);
+ end if;
+ end Disp_Nature;
+
+ procedure Disp_Mode (Mode: Iir_Mode) is
+ begin
+ case Mode is
+ when Iir_In_Mode =>
+ Put ("in ");
+ when Iir_Out_Mode =>
+ Put ("out ");
+ when Iir_Inout_Mode =>
+ Put ("inout ");
+ when Iir_Buffer_Mode =>
+ Put ("buffer ");
+ when Iir_Linkage_Mode =>
+ Put ("linkage ");
+ when Iir_Unknown_Mode =>
+ Put (" ");
+ end case;
+ end Disp_Mode;
+
+ procedure Disp_Signal_Kind (Kind: Iir_Signal_Kind) is
+ begin
+ case Kind is
+ when Iir_No_Signal_Kind =>
+ null;
+ when Iir_Register_Kind =>
+ Put (" register");
+ when Iir_Bus_Kind =>
+ Put (" bus");
+ end case;
+ end Disp_Signal_Kind;
+
+ procedure Disp_Interface_Class (Inter: Iir) is
+ begin
+ if (Get_Lexical_Layout (Inter) and Iir_Lexical_Has_Class) /= 0 then
+ case Get_Kind (Inter) is
+ when Iir_Kind_Interface_Signal_Declaration =>
+ Put ("signal ");
+ when Iir_Kind_Interface_Variable_Declaration =>
+ Put ("variable ");
+ when Iir_Kind_Interface_Constant_Declaration =>
+ Put ("constant ");
+ when Iir_Kind_Interface_File_Declaration =>
+ Put ("file ");
+ when others =>
+ Error_Kind ("disp_interface_class", Inter);
+ end case;
+ end if;
+ end Disp_Interface_Class;
+
+ procedure Disp_Interface_Mode_And_Type (Inter: Iir)
+ is
+ Default: constant Iir := Get_Default_Value (Inter);
+ Ind : constant Iir := Get_Subtype_Indication (Inter);
+ begin
+ Put (": ");
+ if (Get_Lexical_Layout (Inter) and Iir_Lexical_Has_Mode) /= 0 then
+ Disp_Mode (Get_Mode (Inter));
+ end if;
+ if Ind = Null_Iir then
+ -- For implicit subprogram
+ Disp_Type (Get_Type (Inter));
+ else
+ Disp_Subtype_Indication (Get_Subtype_Indication (Inter));
+ end if;
+ if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then
+ Disp_Signal_Kind (Get_Signal_Kind (Inter));
+ end if;
+ if Default /= Null_Iir then
+ Put (" := ");
+ Disp_Expression (Default);
+ end if;
+ end Disp_Interface_Mode_And_Type;
+
+ -- Disp interfaces, followed by END_STR (';' in general).
+ procedure Disp_Interface_Chain (Chain: Iir;
+ End_Str: String := "";
+ Comment_Col : Natural := 0)
+ is
+ Inter: Iir;
+ Next_Inter : Iir;
+ Start: Count;
+ begin
+ if Chain = Null_Iir then
+ return;
+ end if;
+ Put (" (");
+ Start := Col;
+ Inter := Chain;
+ loop
+ Next_Inter := Get_Chain (Inter);
+ Set_Col (Start);
+
+ case Get_Kind (Inter) is
+ when Iir_Kinds_Interface_Object_Declaration =>
+ Disp_Interface_Class (Inter);
+ Disp_Name_Of (Inter);
+ while (Get_Lexical_Layout (Inter) and Iir_Lexical_Has_Type) = 0
+ loop
+ Put (", ");
+ Inter := Next_Inter;
+ Next_Inter := Get_Chain (Inter);
+ Disp_Name_Of (Inter);
+ end loop;
+ Disp_Interface_Mode_And_Type (Inter);
+ when Iir_Kind_Interface_Package_Declaration =>
+ Put ("package ");
+ Disp_Identifier (Inter);
+ Put (" is new ");
+ Disp_Name (Get_Uninstantiated_Package_Name (Inter));
+ Put (" generic map ");
+ declare
+ Assoc_Chain : constant Iir :=
+ Get_Generic_Map_Aspect_Chain (Inter);
+ begin
+ if Assoc_Chain = Null_Iir then
+ Put ("(<>)");
+ else
+ Disp_Association_Chain (Assoc_Chain);
+ end if;
+ end;
+ when others =>
+ Error_Kind ("disp_interface_chain", Inter);
+ end case;
+
+ if Next_Inter /= Null_Iir then
+ Put (";");
+ if Comment_Col /= 0 then
+ New_Line;
+ Set_Col (Comment_Col);
+ Put ("--");
+ end if;
+ else
+ Put (')');
+ Put (End_Str);
+ exit;
+ end if;
+
+ Inter := Next_Inter;
+ Next_Inter := Get_Chain (Inter);
+ end loop;
+ end Disp_Interface_Chain;
+
+ procedure Disp_Ports (Parent : Iir) is
+ begin
+ Put ("port");
+ Disp_Interface_Chain (Get_Port_Chain (Parent), ";");
+ end Disp_Ports;
+
+ procedure Disp_Generics (Parent : Iir) is
+ begin
+ Put ("generic");
+ Disp_Interface_Chain (Get_Generic_Chain (Parent), ";");
+ end Disp_Generics;
+
+ procedure Disp_Entity_Declaration (Decl: Iir_Entity_Declaration) is
+ Start: constant Count := Col;
+ begin
+ Put ("entity ");
+ Disp_Name_Of (Decl);
+ Put_Line (" is");
+ if Get_Generic_Chain (Decl) /= Null_Iir then
+ Set_Col (Start + Indentation);
+ Disp_Generics (Decl);
+ end if;
+ if Get_Port_Chain (Decl) /= Null_Iir then
+ Set_Col (Start + Indentation);
+ Disp_Ports (Decl);
+ end if;
+ Disp_Declaration_Chain (Decl, Start + Indentation);
+ if Get_Has_Begin (Decl) then
+ Set_Col (Start);
+ Put_Line ("begin");
+ end if;
+ if Get_Concurrent_Statement_Chain (Decl) /= Null_Iir then
+ Disp_Concurrent_Statement_Chain (Decl, Start + Indentation);
+ end if;
+ Set_Col (Start);
+ Disp_End (Decl, "entity");
+ end Disp_Entity_Declaration;
+
+ procedure Disp_Component_Declaration (Decl: Iir_Component_Declaration)
+ is
+ Indent: Count;
+ begin
+ Indent := Col;
+ Put ("component ");
+ Disp_Name_Of (Decl);
+ if Get_Has_Is (Decl) then
+ Put (" is");
+ end if;
+ if Get_Generic_Chain (Decl) /= Null_Iir then
+ Set_Col (Indent + Indentation);
+ Disp_Generics (Decl);
+ end if;
+ if Get_Port_Chain (Decl) /= Null_Iir then
+ Set_Col (Indent + Indentation);
+ Disp_Ports (Decl);
+ end if;
+ Set_Col (Indent);
+ Disp_End (Decl, "component");
+ end Disp_Component_Declaration;
+
+ procedure Disp_Concurrent_Statement_Chain (Parent : Iir; Indent : Count)
+ is
+ El: Iir;
+ begin
+ El := Get_Concurrent_Statement_Chain (Parent);
+ while El /= Null_Iir loop
+ Set_Col (Indent);
+ Disp_Concurrent_Statement (El);
+ El := Get_Chain (El);
+ end loop;
+ end Disp_Concurrent_Statement_Chain;
+
+ procedure Disp_Architecture_Body (Arch: Iir_Architecture_Body)
+ is
+ Start: Count;
+ begin
+ Start := Col;
+ Put ("architecture ");
+ Disp_Name_Of (Arch);
+ Put (" of ");
+ Disp_Name (Get_Entity_Name (Arch));
+ Put_Line (" is");
+ Disp_Declaration_Chain (Arch, Start + Indentation);
+ Set_Col (Start);
+ Put_Line ("begin");
+ Disp_Concurrent_Statement_Chain (Arch, Start + Indentation);
+ Set_Col (Start);
+ Disp_End (Arch, "architecture");
+ end Disp_Architecture_Body;
+
+ procedure Disp_Signature (Sig : Iir)
+ is
+ List : Iir_List;
+ El : Iir;
+ begin
+ Disp_Name (Get_Signature_Prefix (Sig));
+ Put (" [");
+ List := Get_Type_Marks_List (Sig);
+ if List /= Null_Iir_List then
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if I /= 0 then
+ Put (", ");
+ end if;
+ Disp_Name (El);
+ end loop;
+ end if;
+ El := Get_Return_Type_Mark (Sig);
+ if El /= Null_Iir then
+ Put (" return ");
+ Disp_Name (El);
+ end if;
+ Put ("]");
+ end Disp_Signature;
+
+ procedure Disp_Object_Alias_Declaration (Decl: Iir_Object_Alias_Declaration)
+ is
+ begin
+ Put ("alias ");
+ Disp_Name_Of (Decl);
+ Put (": ");
+ Disp_Type (Get_Type (Decl));
+ Put (" is ");
+ Disp_Expression (Get_Name (Decl));
+ Put_Line (";");
+ end Disp_Object_Alias_Declaration;
+
+ procedure Disp_Non_Object_Alias_Declaration
+ (Decl: Iir_Non_Object_Alias_Declaration)
+ is
+ Sig : constant Iir := Get_Alias_Signature (Decl);
+ begin
+ if Get_Implicit_Alias_Flag (Decl) then
+ Put ("-- ");
+ end if;
+
+ Put ("alias ");
+ Disp_Function_Name (Decl);
+ Put (" is ");
+ if Sig /= Null_Iir then
+ Disp_Signature (Sig);
+ else
+ Disp_Name (Get_Name (Decl));
+ end if;
+ Put_Line (";");
+ end Disp_Non_Object_Alias_Declaration;
+
+ procedure Disp_File_Declaration (Decl: Iir_File_Declaration)
+ is
+ Next_Decl : Iir;
+ Expr: Iir;
+ begin
+ Put ("file ");
+ Disp_Name_Of (Decl);
+ Next_Decl := Decl;
+ while Get_Has_Identifier_List (Next_Decl) loop
+ Next_Decl := Get_Chain (Next_Decl);
+ Put (", ");
+ Disp_Name_Of (Next_Decl);
+ end loop;
+ Put (": ");
+ Disp_Type (Get_Type (Decl));
+ if Vhdl_Std = Vhdl_87 then
+ Put (" is ");
+ if Get_Has_Mode (Decl) then
+ Disp_Mode (Get_Mode (Decl));
+ end if;
+ Disp_Expression (Get_File_Logical_Name (Decl));
+ else
+ Expr := Get_File_Open_Kind (Decl);
+ if Expr /= Null_Iir then
+ Put (" open ");
+ Disp_Expression (Expr);
+ end if;
+ Expr := Get_File_Logical_Name (Decl);
+ if Expr /= Null_Iir then
+ Put (" is ");
+ Disp_Expression (Expr);
+ end if;
+ end if;
+ Put (';');
+ end Disp_File_Declaration;
+
+ procedure Disp_Quantity_Declaration (Decl: Iir)
+ is
+ Expr : Iir;
+ Term : Iir;
+ begin
+ Put ("quantity ");
+ Disp_Name_Of (Decl);
+
+ case Get_Kind (Decl) is
+ when Iir_Kinds_Branch_Quantity_Declaration =>
+ Disp_Tolerance_Opt (Decl);
+ Expr := Get_Default_Value (Decl);
+ if Expr /= Null_Iir then
+ Put (":= ");
+ Disp_Expression (Expr);
+ end if;
+ if Get_Kind (Decl) = Iir_Kind_Across_Quantity_Declaration then
+ Put (" across ");
+ else
+ Put (" through ");
+ end if;
+ Disp_Name_Of (Get_Plus_Terminal (Decl));
+ Term := Get_Minus_Terminal (Decl);
+ if Term /= Null_Iir then
+ Put (" to ");
+ Disp_Name_Of (Term);
+ end if;
+ when Iir_Kind_Free_Quantity_Declaration =>
+ Put (": ");
+ Disp_Type (Get_Type (Decl));
+ Expr := Get_Default_Value (Decl);
+ if Expr /= Null_Iir then
+ Put (":= ");
+ Disp_Expression (Expr);
+ end if;
+ when others =>
+ raise Program_Error;
+ end case;
+ Put (';');
+ end Disp_Quantity_Declaration;
+
+ procedure Disp_Terminal_Declaration (Decl: Iir) is
+ begin
+ Put ("terminal ");
+ Disp_Name_Of (Decl);
+ Put (": ");
+ Disp_Nature (Get_Nature (Decl));
+ Put (';');
+ end Disp_Terminal_Declaration;
+
+ procedure Disp_Object_Declaration (Decl: Iir)
+ is
+ Next_Decl : Iir;
+ begin
+ case Get_Kind (Decl) is
+ when Iir_Kind_Variable_Declaration =>
+ if Get_Shared_Flag (Decl) then
+ Put ("shared ");
+ end if;
+ Put ("variable ");
+ when Iir_Kind_Constant_Declaration =>
+ Put ("constant ");
+ when Iir_Kind_Signal_Declaration =>
+ Put ("signal ");
+ when Iir_Kind_File_Declaration =>
+ Disp_File_Declaration (Decl);
+ return;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Disp_Name_Of (Decl);
+ Next_Decl := Decl;
+ while Get_Has_Identifier_List (Next_Decl) loop
+ Next_Decl := Get_Chain (Next_Decl);
+ Put (", ");
+ Disp_Name_Of (Next_Decl);
+ end loop;
+ Put (": ");
+ Disp_Subtype_Indication (Get_Subtype_Indication (Decl));
+ if Get_Kind (Decl) = Iir_Kind_Signal_Declaration then
+ Disp_Signal_Kind (Get_Signal_Kind (Decl));
+ end if;
+
+ if Get_Default_Value (Decl) /= Null_Iir then
+ Put (" := ");
+ Disp_Expression (Get_Default_Value (Decl));
+ end if;
+ Put_Line (";");
+ end Disp_Object_Declaration;
+
+ procedure Disp_Pure (Subprg : Iir) is
+ begin
+ if Get_Pure_Flag (Subprg) then
+ Put ("pure");
+ else
+ Put ("impure");
+ end if;
+ end Disp_Pure;
+
+ procedure Disp_Subprogram_Declaration (Subprg: Iir)
+ is
+ Start : constant Count := Col;
+ Implicit : constant Boolean :=
+ Get_Kind (Subprg) in Iir_Kinds_Implicit_Subprogram_Declaration;
+ Inter : Iir;
+ begin
+ if Implicit
+ and then
+ Get_Implicit_Definition (Subprg) /= Iir_Predefined_Now_Function
+ then
+ Put ("-- ");
+ end if;
+
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Function_Declaration =>
+ if Get_Has_Pure (Subprg) then
+ Disp_Pure (Subprg);
+ Put (' ');
+ end if;
+ Put ("function");
+ when Iir_Kind_Implicit_Function_Declaration =>
+ Put ("function");
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ Put ("procedure");
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ Put (' ');
+ Disp_Function_Name (Subprg);
+
+ Inter := Get_Interface_Declaration_Chain (Subprg);
+ if Implicit then
+ Disp_Interface_Chain (Inter, "", Start);
+ else
+ Disp_Interface_Chain (Inter, "", 0);
+ end if;
+
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration =>
+ Put (" return ");
+ if Implicit then
+ Disp_Type (Get_Return_Type (Subprg));
+ else
+ Disp_Name (Get_Return_Type_Mark (Subprg));
+ end if;
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Disp_Subprogram_Declaration;
+
+ procedure Disp_Subprogram_Body (Subprg : Iir)
+ is
+ Indent : constant Count := Col;
+ begin
+ Disp_Declaration_Chain (Subprg, Indent + Indentation);
+ Set_Col (Indent);
+ Put_Line ("begin");
+ Set_Col (Indent + Indentation);
+ Disp_Sequential_Statements (Get_Sequential_Statement_Chain (Subprg));
+ Set_Col (Indent);
+ if Get_Kind (Subprg) = Iir_Kind_Function_Body then
+ Disp_End (Subprg, "function");
+ else
+ Disp_End (Subprg, "procedure");
+ end if;
+ end Disp_Subprogram_Body;
+
+ procedure Disp_Instantiation_List (Insts: Iir_List) is
+ El : Iir;
+ begin
+ if Insts = Iir_List_All then
+ Put ("all");
+ elsif Insts = Iir_List_Others then
+ Put ("others");
+ else
+ for I in Natural loop
+ El := Get_Nth_Element (Insts, I);
+ exit when El = Null_Iir;
+ if I /= Natural'First then
+ Put (", ");
+ end if;
+ Disp_Name_Of (El);
+ end loop;
+ end if;
+ end Disp_Instantiation_List;
+
+ procedure Disp_Configuration_Specification
+ (Spec : Iir_Configuration_Specification)
+ is
+ Indent : Count;
+ begin
+ Indent := Col;
+ Put ("for ");
+ Disp_Instantiation_List (Get_Instantiation_List (Spec));
+ Put (": ");
+ Disp_Name (Get_Component_Name (Spec));
+ New_Line;
+ Disp_Binding_Indication (Get_Binding_Indication (Spec),
+ Indent + Indentation);
+ Put_Line (";");
+ end Disp_Configuration_Specification;
+
+ procedure Disp_Disconnection_Specification
+ (Dis : Iir_Disconnection_Specification)
+ is
+ begin
+ Put ("disconnect ");
+ Disp_Instantiation_List (Get_Signal_List (Dis));
+ Put (": ");
+ Disp_Name (Get_Type_Mark (Dis));
+ Put (" after ");
+ Disp_Expression (Get_Expression (Dis));
+ Put_Line (";");
+ end Disp_Disconnection_Specification;
+
+ procedure Disp_Attribute_Declaration (Attr : Iir_Attribute_Declaration)
+ is
+ begin
+ Put ("attribute ");
+ Disp_Identifier (Attr);
+ Put (": ");
+ Disp_Name (Get_Type_Mark (Attr));
+ Put_Line (";");
+ end Disp_Attribute_Declaration;
+
+ procedure Disp_Attribute_Value (Attr : Iir) is
+ begin
+ Disp_Name_Of (Get_Designated_Entity (Attr));
+ Put ("'");
+ Disp_Identifier
+ (Get_Attribute_Designator (Get_Attribute_Specification (Attr)));
+ end Disp_Attribute_Value;
+
+ procedure Disp_Attribute_Name (Attr : Iir)
+ is
+ Sig : constant Iir := Get_Attribute_Signature (Attr);
+ begin
+ if Sig /= Null_Iir then
+ Disp_Signature (Sig);
+ else
+ Disp_Name (Get_Prefix (Attr));
+ end if;
+ Put ("'");
+ Disp_Ident (Get_Identifier (Attr));
+ end Disp_Attribute_Name;
+
+ procedure Disp_Entity_Kind (Tok : Tokens.Token_Type) is
+ begin
+ Put (Tokens.Image (Tok));
+ end Disp_Entity_Kind;
+
+ procedure Disp_Entity_Name_List (List : Iir_List)
+ is
+ El : Iir;
+ begin
+ if List = Iir_List_All then
+ Put ("all");
+ elsif List = Iir_List_Others then
+ Put ("others");
+ else
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if I /= 0 then
+ Put (", ");
+ end if;
+ if Get_Kind (El) = Iir_Kind_Signature then
+ Disp_Signature (El);
+ else
+ Disp_Name (El);
+ end if;
+ end loop;
+ end if;
+ end Disp_Entity_Name_List;
+
+ procedure Disp_Attribute_Specification (Attr : Iir_Attribute_Specification)
+ is
+ begin
+ Put ("attribute ");
+ Disp_Identifier (Get_Attribute_Designator (Attr));
+ Put (" of ");
+ Disp_Entity_Name_List (Get_Entity_Name_List (Attr));
+ Put (": ");
+ Disp_Entity_Kind (Get_Entity_Class (Attr));
+ Put (" is ");
+ Disp_Expression (Get_Expression (Attr));
+ Put_Line (";");
+ end Disp_Attribute_Specification;
+
+ procedure Disp_Protected_Type_Body
+ (Bod : Iir_Protected_Type_Body; Indent : Count)
+ is
+ begin
+ Put ("type ");
+ Disp_Identifier (Bod);
+ Put (" is protected body");
+ New_Line;
+ Disp_Declaration_Chain (Bod, Indent + Indentation);
+ Set_Col (Indent);
+ Disp_End (Bod, "protected body");
+ end Disp_Protected_Type_Body;
+
+ procedure Disp_Group_Template_Declaration (Decl : Iir)
+ is
+ use Tokens;
+ Ent : Iir;
+ begin
+ Put ("group ");
+ Disp_Identifier (Decl);
+ Put (" is (");
+ Ent := Get_Entity_Class_Entry_Chain (Decl);
+ loop
+ Disp_Entity_Kind (Get_Entity_Class (Ent));
+ Ent := Get_Chain (Ent);
+ exit when Ent = Null_Iir;
+ if Get_Entity_Class (Ent) = Tok_Box then
+ Put (" <>");
+ exit;
+ else
+ Put (", ");
+ end if;
+ end loop;
+ Put_Line (");");
+ end Disp_Group_Template_Declaration;
+
+ procedure Disp_Group_Declaration (Decl : Iir)
+ is
+ List : Iir_List;
+ El : Iir;
+ begin
+ Put ("group ");
+ Disp_Identifier (Decl);
+ Put (" : ");
+ Disp_Name (Get_Group_Template_Name (Decl));
+ Put (" (");
+ List := Get_Group_Constituent_List (Decl);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if I /= 0 then
+ Put (", ");
+ end if;
+ Disp_Name_Of (El);
+ end loop;
+ Put_Line (");");
+ end Disp_Group_Declaration;
+
+ procedure Disp_Declaration_Chain (Parent : Iir; Indent: Count)
+ is
+ Decl: Iir;
+ begin
+ Decl := Get_Declaration_Chain (Parent);
+ while Decl /= Null_Iir loop
+ Set_Col (Indent);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Type_Declaration =>
+ Disp_Type_Declaration (Decl);
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ Disp_Anonymous_Type_Declaration (Decl);
+ when Iir_Kind_Subtype_Declaration =>
+ Disp_Subtype_Declaration (Decl);
+ when Iir_Kind_Use_Clause =>
+ Disp_Use_Clause (Decl);
+ when Iir_Kind_Component_Declaration =>
+ Disp_Component_Declaration (Decl);
+ when Iir_Kind_File_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Variable_Declaration =>
+ Disp_Object_Declaration (Decl);
+ while Get_Has_Identifier_List (Decl) loop
+ Decl := Get_Chain (Decl);
+ end loop;
+ when Iir_Kind_Object_Alias_Declaration =>
+ Disp_Object_Alias_Declaration (Decl);
+ when Iir_Kind_Terminal_Declaration =>
+ Disp_Terminal_Declaration (Decl);
+ when Iir_Kinds_Quantity_Declaration =>
+ Disp_Quantity_Declaration (Decl);
+ when Iir_Kind_Nature_Declaration =>
+ Disp_Nature_Declaration (Decl);
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ Disp_Non_Object_Alias_Declaration (Decl);
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ Disp_Subprogram_Declaration (Decl);
+ Put_Line (";");
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ Disp_Subprogram_Declaration (Decl);
+ if not Get_Has_Body (Decl) then
+ Put_Line (";");
+ end if;
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ -- The declaration was just displayed.
+ Put_Line (" is");
+ Set_Col (Indent);
+ Disp_Subprogram_Body (Decl);
+ when Iir_Kind_Protected_Type_Body =>
+ Disp_Protected_Type_Body (Decl, Indent);
+ when Iir_Kind_Configuration_Specification =>
+ Disp_Configuration_Specification (Decl);
+ when Iir_Kind_Disconnection_Specification =>
+ Disp_Disconnection_Specification (Decl);
+ when Iir_Kind_Attribute_Declaration =>
+ Disp_Attribute_Declaration (Decl);
+ when Iir_Kind_Attribute_Specification =>
+ Disp_Attribute_Specification (Decl);
+ when Iir_Kinds_Signal_Attribute =>
+ null;
+ when Iir_Kind_Group_Template_Declaration =>
+ Disp_Group_Template_Declaration (Decl);
+ when Iir_Kind_Group_Declaration =>
+ Disp_Group_Declaration (Decl);
+ when others =>
+ Error_Kind ("disp_declaration_chain", Decl);
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+ end Disp_Declaration_Chain;
+
+ procedure Disp_Waveform (Chain : Iir_Waveform_Element)
+ is
+ We: Iir_Waveform_Element;
+ Val : Iir;
+ begin
+ if Chain = Null_Iir then
+ Put ("null after {disconnection_time}");
+ return;
+ end if;
+ We := Chain;
+ while We /= Null_Iir loop
+ if We /= Chain then
+ Put (", ");
+ end if;
+ Val := Get_We_Value (We);
+ Disp_Expression (Val);
+ if Get_Time (We) /= Null_Iir then
+ Put (" after ");
+ Disp_Expression (Get_Time (We));
+ end if;
+ We := Get_Chain (We);
+ end loop;
+ end Disp_Waveform;
+
+ procedure Disp_Delay_Mechanism (Stmt: Iir) is
+ Expr: Iir;
+ begin
+ case Get_Delay_Mechanism (Stmt) is
+ when Iir_Transport_Delay =>
+ Put ("transport ");
+ when Iir_Inertial_Delay =>
+ Expr := Get_Reject_Time_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Put ("reject ");
+ Disp_Expression (Expr);
+ Put (" inertial ");
+ end if;
+ end case;
+ end Disp_Delay_Mechanism;
+
+ procedure Disp_Signal_Assignment (Stmt: Iir) is
+ begin
+ Disp_Expression (Get_Target (Stmt));
+ Put (" <= ");
+ Disp_Delay_Mechanism (Stmt);
+ Disp_Waveform (Get_Waveform_Chain (Stmt));
+ Put_Line (";");
+ end Disp_Signal_Assignment;
+
+ procedure Disp_Variable_Assignment (Stmt: Iir) is
+ begin
+ Disp_Expression (Get_Target (Stmt));
+ Put (" := ");
+ Disp_Expression (Get_Expression (Stmt));
+ Put_Line (";");
+ end Disp_Variable_Assignment;
+
+ procedure Disp_Label (Stmt : Iir)
+ is
+ Label: constant Name_Id := Get_Label (Stmt);
+ begin
+ if Label /= Null_Identifier then
+ Disp_Ident (Label);
+ Put (": ");
+ end if;
+ end Disp_Label;
+
+ procedure Disp_Postponed (Stmt : Iir) is
+ begin
+ if Get_Postponed_Flag (Stmt) then
+ Put ("postponed ");
+ end if;
+ end Disp_Postponed;
+
+ procedure Disp_Concurrent_Selected_Signal_Assignment (Stmt: Iir)
+ is
+ Indent: constant Count := Col;
+ Assoc: Iir;
+ Assoc_Chain : Iir;
+ begin
+ Set_Col (Indent);
+ Disp_Label (Stmt);
+ Disp_Postponed (Stmt);
+ Put ("with ");
+ Disp_Expression (Get_Expression (Stmt));
+ Put (" select ");
+ Disp_Expression (Get_Target (Stmt));
+ Put (" <= ");
+ if Get_Guard (Stmt) /= Null_Iir then
+ Put ("guarded ");
+ end if;
+ Disp_Delay_Mechanism (Stmt);
+ Assoc_Chain := Get_Selected_Waveform_Chain (Stmt);
+ Assoc := Assoc_Chain;
+ while Assoc /= Null_Iir loop
+ if Assoc /= Assoc_Chain then
+ Put_Line (",");
+ end if;
+ Set_Col (Indent + Indentation);
+ Disp_Waveform (Get_Associated_Chain (Assoc));
+ Put (" when ");
+ Disp_Choice (Assoc);
+ end loop;
+ Put_Line (";");
+ end Disp_Concurrent_Selected_Signal_Assignment;
+
+ procedure Disp_Concurrent_Conditional_Signal_Assignment (Stmt: Iir)
+ is
+ Indent: Count;
+ Cond_Wf : Iir_Conditional_Waveform;
+ Expr : Iir;
+ begin
+ Disp_Label (Stmt);
+ Disp_Postponed (Stmt);
+ Disp_Expression (Get_Target (Stmt));
+ Put (" <= ");
+ if Get_Guard (Stmt) /= Null_Iir then
+ Put ("guarded ");
+ end if;
+ Disp_Delay_Mechanism (Stmt);
+ Indent := Col;
+ Set_Col (Indent);
+ Cond_Wf := Get_Conditional_Waveform_Chain (Stmt);
+ while Cond_Wf /= Null_Iir loop
+ Disp_Waveform (Get_Waveform_Chain (Cond_Wf));
+ Expr := Get_Condition (Cond_Wf);
+ if Expr /= Null_Iir then
+ Put (" when ");
+ Disp_Expression (Expr);
+ Put_Line (" else");
+ Set_Col (Indent);
+ end if;
+ Cond_Wf := Get_Chain (Cond_Wf);
+ end loop;
+
+ Put_Line (";");
+ end Disp_Concurrent_Conditional_Signal_Assignment;
+
+ procedure Disp_Assertion_Statement (Stmt: Iir)
+ is
+ Start: constant Count := Col;
+ Expr: Iir;
+ begin
+ if Get_Kind (Stmt) = Iir_Kind_Concurrent_Assertion_Statement then
+ Disp_Label (Stmt);
+ Disp_Postponed (Stmt);
+ end if;
+ Put ("assert ");
+ Disp_Expression (Get_Assertion_Condition (Stmt));
+ Expr := Get_Report_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Set_Col (Start + Indentation);
+ Put ("report ");
+ Disp_Expression (Expr);
+ end if;
+ Expr := Get_Severity_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Set_Col (Start + Indentation);
+ Put ("severity ");
+ Disp_Expression (Expr);
+ end if;
+ Put_Line (";");
+ end Disp_Assertion_Statement;
+
+ procedure Disp_Report_Statement (Stmt: Iir)
+ is
+ Start: Count;
+ Expr: Iir;
+ begin
+ Start := Col;
+ Put ("report ");
+ Expr := Get_Report_Expression (Stmt);
+ Disp_Expression (Expr);
+ Expr := Get_Severity_Expression (Stmt);
+ if Expr /= Null_Iir then
+ Set_Col (Start + Indentation);
+ Put ("severity ");
+ Disp_Expression (Expr);
+ end if;
+ Put_Line (";");
+ end Disp_Report_Statement;
+
+ procedure Disp_Dyadic_Operator (Expr: Iir) is
+ begin
+ if Flag_Parenthesis then
+ Put ("(");
+ end if;
+ Disp_Expression (Get_Left (Expr));
+ Put (' ' & Name_Table.Image (Iirs_Utils.Get_Operator_Name (Expr)) & ' ');
+ Disp_Expression (Get_Right (Expr));
+ if Flag_Parenthesis then
+ Put (")");
+ end if;
+ end Disp_Dyadic_Operator;
+
+ procedure Disp_Monadic_Operator (Expr: Iir) is
+ begin
+ Put (Name_Table.Image (Iirs_Utils.Get_Operator_Name (Expr)));
+ Put (' ');
+ if Flag_Parenthesis then
+ Put ('(');
+ end if;
+ Disp_Expression (Get_Operand (Expr));
+ if Flag_Parenthesis then
+ Put (')');
+ end if;
+ end Disp_Monadic_Operator;
+
+ procedure Disp_Case_Statement (Stmt: Iir_Case_Statement)
+ is
+ Indent: Count;
+ Assoc: Iir;
+ Sel_Stmt : Iir;
+ begin
+ Indent := Col;
+ Put ("case ");
+ Disp_Expression (Get_Expression (Stmt));
+ Put_Line (" is");
+ Assoc := Get_Case_Statement_Alternative_Chain (Stmt);
+ while Assoc /= Null_Iir loop
+ Set_Col (Indent + Indentation);
+ Put ("when ");
+ Sel_Stmt := Get_Associated_Chain (Assoc);
+ Disp_Choice (Assoc);
+ Put_Line (" =>");
+ Set_Col (Indent + 2 * Indentation);
+ Disp_Sequential_Statements (Sel_Stmt);
+ end loop;
+ Set_Col (Indent);
+ Disp_End_Label (Stmt, "case");
+ end Disp_Case_Statement;
+
+ procedure Disp_Wait_Statement (Stmt: Iir_Wait_Statement) is
+ List: Iir_List;
+ Expr: Iir;
+ begin
+ Put ("wait");
+ List := Get_Sensitivity_List (Stmt);
+ if List /= Null_Iir_List then
+ Put (" on ");
+ Disp_Designator_List (List);
+ end if;
+ Expr := Get_Condition_Clause (Stmt);
+ if Expr /= Null_Iir then
+ Put (" until ");
+ Disp_Expression (Expr);
+ end if;
+ Expr := Get_Timeout_Clause (Stmt);
+ if Expr /= Null_Iir then
+ Put (" for ");
+ Disp_Expression (Expr);
+ end if;
+ Put_Line (";");
+ end Disp_Wait_Statement;
+
+ procedure Disp_If_Statement (Stmt: Iir_If_Statement) is
+ Clause: Iir;
+ Expr: Iir;
+ Start: Count;
+ begin
+ Start := Col;
+ Put ("if ");
+ Clause := Stmt;
+ Disp_Expression (Get_Condition (Clause));
+ Put_Line (" then");
+ while Clause /= Null_Iir loop
+ Set_Col (Start + Indentation);
+ Disp_Sequential_Statements (Get_Sequential_Statement_Chain (Clause));
+ Clause := Get_Else_Clause (Clause);
+ exit when Clause = Null_Iir;
+ Expr := Get_Condition (Clause);
+ Set_Col (Start);
+ if Expr /= Null_Iir then
+ Put ("elsif ");
+ Disp_Expression (Expr);
+ Put_Line (" then");
+ else
+ Put_Line ("else");
+ end if;
+ end loop;
+ Set_Col (Start);
+ Disp_End_Label (Stmt, "if");
+ end Disp_If_Statement;
+
+ procedure Disp_Parameter_Specification
+ (Iterator : Iir_Iterator_Declaration) is
+ begin
+ Disp_Identifier (Iterator);
+ Put (" in ");
+ Disp_Discrete_Range (Get_Discrete_Range (Iterator));
+ end Disp_Parameter_Specification;
+
+ procedure Disp_Method_Object (Call : Iir)
+ is
+ Obj : Iir;
+ begin
+ Obj := Get_Method_Object (Call);
+ if Obj /= Null_Iir then
+ Disp_Name (Obj);
+ Put ('.');
+ end if;
+ end Disp_Method_Object;
+
+ procedure Disp_Procedure_Call (Call : Iir) is
+ begin
+ if True then
+ Disp_Name (Get_Prefix (Call));
+ else
+ Disp_Method_Object (Call);
+ Disp_Identifier (Get_Implementation (Call));
+ Put (' ');
+ end if;
+ Disp_Association_Chain (Get_Parameter_Association_Chain (Call));
+ Put_Line (";");
+ end Disp_Procedure_Call;
+
+ procedure Disp_Sequential_Statements (First : Iir)
+ is
+ Stmt: Iir;
+ Start: constant Count := Col;
+ begin
+ Stmt := First;
+ while Stmt /= Null_Iir loop
+ Set_Col (Start);
+ Disp_Label (Stmt);
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Null_Statement =>
+ Put_Line ("null;");
+ when Iir_Kind_If_Statement =>
+ Disp_If_Statement (Stmt);
+ when Iir_Kind_For_Loop_Statement =>
+ Put ("for ");
+ Disp_Parameter_Specification
+ (Get_Parameter_Specification (Stmt));
+ Put_Line (" loop");
+ Set_Col (Start + Indentation);
+ Disp_Sequential_Statements
+ (Get_Sequential_Statement_Chain (Stmt));
+ Set_Col (Start);
+ Disp_End_Label (Stmt, "loop");
+ when Iir_Kind_While_Loop_Statement =>
+ if Get_Condition (Stmt) /= Null_Iir then
+ Put ("while ");
+ Disp_Expression (Get_Condition (Stmt));
+ Put (" ");
+ end if;
+ Put_Line ("loop");
+ Set_Col (Start + Indentation);
+ Disp_Sequential_Statements
+ (Get_Sequential_Statement_Chain (Stmt));
+ Set_Col (Start);
+ Disp_End_Label (Stmt, "loop");
+ when Iir_Kind_Signal_Assignment_Statement =>
+ Disp_Signal_Assignment (Stmt);
+ when Iir_Kind_Variable_Assignment_Statement =>
+ Disp_Variable_Assignment (Stmt);
+ when Iir_Kind_Assertion_Statement =>
+ Disp_Assertion_Statement (Stmt);
+ when Iir_Kind_Report_Statement =>
+ Disp_Report_Statement (Stmt);
+ when Iir_Kind_Return_Statement =>
+ if Get_Expression (Stmt) /= Null_Iir then
+ Put ("return ");
+ Disp_Expression (Get_Expression (Stmt));
+ Put_Line (";");
+ else
+ Put_Line ("return;");
+ end if;
+ when Iir_Kind_Case_Statement =>
+ Disp_Case_Statement (Stmt);
+ when Iir_Kind_Wait_Statement =>
+ Disp_Wait_Statement (Stmt);
+ when Iir_Kind_Procedure_Call_Statement =>
+ Disp_Procedure_Call (Get_Procedure_Call (Stmt));
+ when Iir_Kind_Exit_Statement
+ | Iir_Kind_Next_Statement =>
+ declare
+ Label : constant Iir := Get_Loop_Label (Stmt);
+ Cond : constant Iir := Get_Condition (Stmt);
+ begin
+ if Get_Kind (Stmt) = Iir_Kind_Exit_Statement then
+ Put ("exit");
+ else
+ Put ("next");
+ end if;
+ if Label /= Null_Iir then
+ Put (" ");
+ Disp_Name (Label);
+ end if;
+ if Cond /= Null_Iir then
+ Put (" when ");
+ Disp_Expression (Cond);
+ end if;
+ Put_Line (";");
+ end;
+
+ when others =>
+ Error_Kind ("disp_sequential_statements", Stmt);
+ end case;
+ Stmt := Get_Chain (Stmt);
+ end loop;
+ end Disp_Sequential_Statements;
+
+ procedure Disp_Process_Statement (Process: Iir)
+ is
+ Start: constant Count := Col;
+ begin
+ Disp_Label (Process);
+ Disp_Postponed (Process);
+
+ Put ("process ");
+ if Get_Kind (Process) = Iir_Kind_Sensitized_Process_Statement then
+ Put ("(");
+ Disp_Designator_List (Get_Sensitivity_List (Process));
+ Put (")");
+ end if;
+ if Get_Has_Is (Process) then
+ Put (" is");
+ end if;
+ New_Line;
+ Disp_Declaration_Chain (Process, Start + Indentation);
+ Set_Col (Start);
+ Put_Line ("begin");
+ Set_Col (Start + Indentation);
+ Disp_Sequential_Statements (Get_Sequential_Statement_Chain (Process));
+ Set_Col (Start);
+ Put ("end");
+ if Get_End_Has_Postponed (Process) then
+ Put (" postponed");
+ end if;
+ Disp_After_End (Process, "process");
+ end Disp_Process_Statement;
+
+ procedure Disp_Conversion (Conv : Iir) is
+ begin
+ case Get_Kind (Conv) is
+ when Iir_Kind_Function_Call =>
+ Disp_Function_Name (Get_Implementation (Conv));
+ when Iir_Kind_Type_Conversion =>
+ Disp_Name_Of (Get_Type_Mark (Conv));
+ when others =>
+ Error_Kind ("disp_conversion", Conv);
+ end case;
+ end Disp_Conversion;
+
+ procedure Disp_Association_Chain (Chain : Iir)
+ is
+ El: Iir;
+ Formal: Iir;
+ Need_Comma : Boolean;
+ Conv : Iir;
+ begin
+ if Chain = Null_Iir then
+ return;
+ end if;
+ Put ("(");
+ Need_Comma := False;
+
+ El := Chain;
+ while El /= Null_Iir loop
+ if Get_Kind (El) /= Iir_Kind_Association_Element_By_Individual then
+ if Need_Comma then
+ Put (", ");
+ end if;
+
+ -- Formal part.
+ if Get_Kind (El) = Iir_Kind_Association_Element_By_Expression then
+ Conv := Get_Out_Conversion (El);
+ if Conv /= Null_Iir then
+ Disp_Conversion (Conv);
+ Put (" (");
+ end if;
+ else
+ Conv := Null_Iir;
+ end if;
+ Formal := Get_Formal (El);
+ if Formal /= Null_Iir then
+ Disp_Expression (Formal);
+ if Conv /= Null_Iir then
+ Put (")");
+ end if;
+ Put (" => ");
+ end if;
+
+ case Get_Kind (El) is
+ when Iir_Kind_Association_Element_Open =>
+ Put ("open");
+ when Iir_Kind_Association_Element_Package =>
+ Disp_Name (Get_Actual (El));
+ when others =>
+ Conv := Get_In_Conversion (El);
+ if Conv /= Null_Iir then
+ Disp_Conversion (Conv);
+ Put (" (");
+ end if;
+ Disp_Expression (Get_Actual (El));
+ if Conv /= Null_Iir then
+ Put (")");
+ end if;
+ end case;
+ Need_Comma := True;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ Put (")");
+ end Disp_Association_Chain;
+
+ procedure Disp_Generic_Map_Aspect (Parent : Iir) is
+ begin
+ Put ("generic map ");
+ Disp_Association_Chain (Get_Generic_Map_Aspect_Chain (Parent));
+ end Disp_Generic_Map_Aspect;
+
+ procedure Disp_Port_Map_Aspect (Parent : Iir) is
+ begin
+ Put ("port map ");
+ Disp_Association_Chain (Get_Port_Map_Aspect_Chain (Parent));
+ end Disp_Port_Map_Aspect;
+
+ procedure Disp_Entity_Aspect (Aspect : Iir) is
+ Arch : Iir;
+ begin
+ case Get_Kind (Aspect) is
+ when Iir_Kind_Entity_Aspect_Entity =>
+ Put ("entity ");
+ Disp_Name (Get_Entity_Name (Aspect));
+ Arch := Get_Architecture (Aspect);
+ if Arch /= Null_Iir then
+ Put (" (");
+ Disp_Name_Of (Arch);
+ Put (")");
+ end if;
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ Put ("configuration ");
+ Disp_Name (Get_Configuration_Name (Aspect));
+ when Iir_Kind_Entity_Aspect_Open =>
+ Put ("open");
+ when others =>
+ Error_Kind ("disp_entity_aspect", Aspect);
+ end case;
+ end Disp_Entity_Aspect;
+
+ procedure Disp_Component_Instantiation_Statement
+ (Stmt: Iir_Component_Instantiation_Statement)
+ is
+ Component: constant Iir := Get_Instantiated_Unit (Stmt);
+ Alist: Iir;
+ begin
+ Disp_Label (Stmt);
+ if Get_Kind (Component) in Iir_Kinds_Denoting_Name then
+ Disp_Name (Component);
+ else
+ Disp_Entity_Aspect (Component);
+ end if;
+ Alist := Get_Generic_Map_Aspect_Chain (Stmt);
+ if Alist /= Null_Iir then
+ Put (" ");
+ Disp_Generic_Map_Aspect (Stmt);
+ end if;
+ Alist := Get_Port_Map_Aspect_Chain (Stmt);
+ if Alist /= Null_Iir then
+ Put (" ");
+ Disp_Port_Map_Aspect (Stmt);
+ end if;
+ Put (";");
+ end Disp_Component_Instantiation_Statement;
+
+ procedure Disp_Function_Call (Expr: Iir_Function_Call) is
+ begin
+ if True then
+ Disp_Name (Get_Prefix (Expr));
+ else
+ Disp_Method_Object (Expr);
+ Disp_Function_Name (Get_Implementation (Expr));
+ end if;
+ Disp_Association_Chain (Get_Parameter_Association_Chain (Expr));
+ end Disp_Function_Call;
+
+ procedure Disp_Indexed_Name (Indexed: Iir)
+ is
+ List : Iir_List;
+ El: Iir;
+ begin
+ Disp_Expression (Get_Prefix (Indexed));
+ Put (" (");
+ List := Get_Index_List (Indexed);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if I /= 0 then
+ Put (", ");
+ end if;
+ Disp_Expression (El);
+ end loop;
+ Put (")");
+ end Disp_Indexed_Name;
+
+ procedure Disp_Choice (Choice: in out Iir) is
+ begin
+ loop
+ case Get_Kind (Choice) is
+ when Iir_Kind_Choice_By_Others =>
+ Put ("others");
+ when Iir_Kind_Choice_By_None =>
+ null;
+ when Iir_Kind_Choice_By_Expression =>
+ Disp_Expression (Get_Choice_Expression (Choice));
+ when Iir_Kind_Choice_By_Range =>
+ Disp_Range (Get_Choice_Range (Choice));
+ when Iir_Kind_Choice_By_Name =>
+ Disp_Name_Of (Get_Choice_Name (Choice));
+ when others =>
+ Error_Kind ("disp_choice", Choice);
+ end case;
+ Choice := Get_Chain (Choice);
+ exit when Choice = Null_Iir;
+ exit when Get_Same_Alternative_Flag (Choice) = False;
+ --exit when Choice = Null_Iir;
+ Put (" | ");
+ end loop;
+ end Disp_Choice;
+
+ procedure Disp_Aggregate (Aggr: Iir_Aggregate)
+ is
+ Indent: Count;
+ Assoc: Iir;
+ Expr : Iir;
+ begin
+ Indent := Col;
+ if Indent > Line_Length - 10 then
+ Indent := 2 * Indentation;
+ end if;
+ Put ("(");
+ Assoc := Get_Association_Choices_Chain (Aggr);
+ loop
+ Expr := Get_Associated_Expr (Assoc);
+ if Get_Kind (Assoc) /= Iir_Kind_Choice_By_None then
+ Disp_Choice (Assoc);
+ Put (" => ");
+ else
+ Assoc := Get_Chain (Assoc);
+ end if;
+ if Get_Kind (Expr) = Iir_Kind_Aggregate
+ or else Get_Kind (Expr) = Iir_Kind_String_Literal then
+ Set_Col (Indent);
+ end if;
+ Disp_Expression (Expr);
+ exit when Assoc = Null_Iir;
+ Put (", ");
+ end loop;
+ Put (")");
+ end Disp_Aggregate;
+
+ procedure Disp_Simple_Aggregate (Aggr: Iir_Simple_Aggregate)
+ is
+ List : Iir_List;
+ El : Iir;
+ First : Boolean := True;
+ begin
+ Put ("(");
+ List := Get_Simple_Aggregate_List (Aggr);
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ if First then
+ First := False;
+ else
+ Put (", ");
+ end if;
+ Disp_Expression (El);
+ end loop;
+ Put (")");
+ end Disp_Simple_Aggregate;
+
+ procedure Disp_Parametered_Attribute (Name : String; Expr : Iir)
+ is
+ Param : Iir;
+ Pfx : Iir;
+ begin
+ Pfx := Get_Prefix (Expr);
+ case Get_Kind (Pfx) is
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ Disp_Name_Of (Pfx);
+ when others =>
+ Disp_Expression (Pfx);
+ end case;
+ Put ("'");
+ Put (Name);
+ Param := Get_Parameter (Expr);
+ if Param /= Null_Iir
+ and then Param /= Std_Package.Universal_Integer_One
+ then
+ Put (" (");
+ Disp_Expression (Param);
+ Put (")");
+ end if;
+ end Disp_Parametered_Attribute;
+
+ procedure Disp_Parametered_Type_Attribute (Name : String; Expr : Iir) is
+ begin
+ Disp_Name (Get_Prefix (Expr));
+ Put ("'");
+ Put (Name);
+ Put (" (");
+ Disp_Expression (Get_Parameter (Expr));
+ Put (")");
+ end Disp_Parametered_Type_Attribute;
+
+ procedure Disp_String_Literal (Str : Iir)
+ is
+ Ptr : constant String_Fat_Acc := Get_String_Fat_Acc (Str);
+ Len : constant Int32 := Get_String_Length (Str);
+ begin
+ for I in 1 .. Len loop
+ if Ptr (I) = '"' then
+ Put ('"');
+ end if;
+ Put (Ptr (I));
+ end loop;
+ end Disp_String_Literal;
+
+ procedure Disp_Expression (Expr: Iir)
+ is
+ Orig : Iir;
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Integer_Literal =>
+ Orig := Get_Literal_Origin (Expr);
+ if Orig /= Null_Iir then
+ Disp_Expression (Orig);
+ else
+ Disp_Int64 (Get_Value (Expr));
+ end if;
+ when Iir_Kind_Floating_Point_Literal =>
+ Orig := Get_Literal_Origin (Expr);
+ if Orig /= Null_Iir then
+ Disp_Expression (Orig);
+ else
+ Disp_Fp64 (Get_Fp_Value (Expr));
+ end if;
+ when Iir_Kind_String_Literal =>
+ Orig := Get_Literal_Origin (Expr);
+ if Orig /= Null_Iir then
+ Disp_Expression (Orig);
+ else
+ Put ("""");
+ Disp_String_Literal (Expr);
+ Put ("""");
+ if Disp_String_Literal_Type or Flags.List_Verbose then
+ Put ("[type: ");
+ Disp_Type (Get_Type (Expr));
+ Put ("]");
+ end if;
+ end if;
+ when Iir_Kind_Bit_String_Literal =>
+ Orig := Get_Literal_Origin (Expr);
+ if Orig /= Null_Iir then
+ Disp_Expression (Orig);
+ else
+ if False then
+ case Get_Bit_String_Base (Expr) is
+ when Base_2 =>
+ Put ('B');
+ when Base_8 =>
+ Put ('O');
+ when Base_16 =>
+ Put ('X');
+ end case;
+ end if;
+ Put ("B""");
+ Disp_String_Literal (Expr);
+ Put ("""");
+ end if;
+ when Iir_Kind_Physical_Fp_Literal
+ | Iir_Kind_Physical_Int_Literal =>
+ Orig := Get_Literal_Origin (Expr);
+ if Orig /= Null_Iir then
+ Disp_Expression (Orig);
+ else
+ Disp_Physical_Literal (Expr);
+ end if;
+ when Iir_Kind_Unit_Declaration =>
+ Disp_Name_Of (Expr);
+ when Iir_Kind_Character_Literal =>
+ Disp_Identifier (Expr);
+ when Iir_Kind_Enumeration_Literal =>
+ Orig := Get_Literal_Origin (Expr);
+ if Orig /= Null_Iir then
+ Disp_Expression (Orig);
+ else
+ Disp_Name_Of (Expr);
+ end if;
+ when Iir_Kind_Overflow_Literal =>
+ Orig := Get_Literal_Origin (Expr);
+ if Orig /= Null_Iir then
+ Disp_Expression (Orig);
+ else
+ Put ("*OVERFLOW*");
+ end if;
+
+ when Iir_Kind_Object_Alias_Declaration =>
+ Disp_Name_Of (Expr);
+ when Iir_Kind_Aggregate =>
+ Disp_Aggregate (Expr);
+ when Iir_Kind_Null_Literal =>
+ Put ("null");
+ when Iir_Kind_Simple_Aggregate =>
+ Orig := Get_Literal_Origin (Expr);
+ if Orig /= Null_Iir then
+ Disp_Expression (Orig);
+ else
+ Disp_Simple_Aggregate (Expr);
+ end if;
+
+ when Iir_Kind_Attribute_Value =>
+ Disp_Attribute_Value (Expr);
+ when Iir_Kind_Attribute_Name =>
+ Disp_Attribute_Name (Expr);
+
+ when Iir_Kind_Element_Declaration =>
+ Disp_Name_Of (Expr);
+
+ when Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Iterator_Declaration =>
+ Disp_Name_Of (Expr);
+ return;
+
+ when Iir_Kinds_Dyadic_Operator =>
+ Disp_Dyadic_Operator (Expr);
+ when Iir_Kinds_Monadic_Operator =>
+ Disp_Monadic_Operator (Expr);
+ when Iir_Kind_Function_Call =>
+ Disp_Function_Call (Expr);
+ when Iir_Kind_Parenthesis_Expression =>
+ Put ("(");
+ Disp_Expression (Get_Expression (Expr));
+ Put (")");
+ when Iir_Kind_Type_Conversion =>
+ Disp_Name (Get_Type_Mark (Expr));
+ Put (" (");
+ Disp_Expression (Get_Expression (Expr));
+ Put (")");
+ when Iir_Kind_Qualified_Expression =>
+ declare
+ Qexpr : constant Iir := Get_Expression (Expr);
+ Has_Paren : constant Boolean :=
+ Get_Kind (Qexpr) = Iir_Kind_Parenthesis_Expression
+ or else Get_Kind (Qexpr) = Iir_Kind_Aggregate;
+ begin
+ Disp_Name (Get_Type_Mark (Expr));
+ Put ("'");
+ if not Has_Paren then
+ Put ("(");
+ end if;
+ Disp_Expression (Qexpr);
+ if not Has_Paren then
+ Put (")");
+ end if;
+ end;
+ when Iir_Kind_Allocator_By_Expression =>
+ Put ("new ");
+ Disp_Expression (Get_Expression (Expr));
+ when Iir_Kind_Allocator_By_Subtype =>
+ Put ("new ");
+ Disp_Subtype_Indication (Get_Subtype_Indication (Expr));
+
+ when Iir_Kind_Indexed_Name =>
+ Disp_Indexed_Name (Expr);
+ when Iir_Kind_Slice_Name =>
+ Disp_Expression (Get_Prefix (Expr));
+ Put (" (");
+ Disp_Range (Get_Suffix (Expr));
+ Put (")");
+ when Iir_Kind_Selected_Element =>
+ Disp_Expression (Get_Prefix (Expr));
+ Put (".");
+ Disp_Name_Of (Get_Selected_Element (Expr));
+ when Iir_Kind_Implicit_Dereference =>
+ Disp_Expression (Get_Prefix (Expr));
+ when Iir_Kind_Dereference =>
+ Disp_Expression (Get_Prefix (Expr));
+ Put (".all");
+
+ when Iir_Kind_Left_Type_Attribute =>
+ Disp_Name (Get_Prefix (Expr));
+ Put ("'left");
+ when Iir_Kind_Right_Type_Attribute =>
+ Disp_Name (Get_Prefix (Expr));
+ Put ("'right");
+ when Iir_Kind_High_Type_Attribute =>
+ Disp_Name (Get_Prefix (Expr));
+ Put ("'high");
+ when Iir_Kind_Low_Type_Attribute =>
+ Disp_Name (Get_Prefix (Expr));
+ Put ("'low");
+ when Iir_Kind_Ascending_Type_Attribute =>
+ Disp_Name (Get_Prefix (Expr));
+ Put ("'ascending");
+
+ when Iir_Kind_Stable_Attribute =>
+ Disp_Parametered_Attribute ("stable", Expr);
+ when Iir_Kind_Quiet_Attribute =>
+ Disp_Parametered_Attribute ("quiet", Expr);
+ when Iir_Kind_Delayed_Attribute =>
+ Disp_Parametered_Attribute ("delayed", Expr);
+ when Iir_Kind_Transaction_Attribute =>
+ Disp_Expression (Get_Prefix (Expr));
+ Put ("'transaction");
+ when Iir_Kind_Event_Attribute =>
+ Disp_Expression (Get_Prefix (Expr));
+ Put ("'event");
+ when Iir_Kind_Active_Attribute =>
+ Disp_Expression (Get_Prefix (Expr));
+ Put ("'active");
+ when Iir_Kind_Driving_Attribute =>
+ Disp_Expression (Get_Prefix (Expr));
+ Put ("'driving");
+ when Iir_Kind_Driving_Value_Attribute =>
+ Disp_Expression (Get_Prefix (Expr));
+ Put ("'driving_value");
+ when Iir_Kind_Last_Value_Attribute =>
+ Disp_Expression (Get_Prefix (Expr));
+ Put ("'last_value");
+ when Iir_Kind_Last_Active_Attribute =>
+ Disp_Expression (Get_Prefix (Expr));
+ Put ("'last_active");
+ when Iir_Kind_Last_Event_Attribute =>
+ Disp_Expression (Get_Prefix (Expr));
+ Put ("'last_event");
+
+ when Iir_Kind_Pos_Attribute =>
+ Disp_Parametered_Type_Attribute ("pos", Expr);
+ when Iir_Kind_Val_Attribute =>
+ Disp_Parametered_Type_Attribute ("val", Expr);
+ when Iir_Kind_Succ_Attribute =>
+ Disp_Parametered_Type_Attribute ("succ", Expr);
+ when Iir_Kind_Pred_Attribute =>
+ Disp_Parametered_Type_Attribute ("pred", Expr);
+ when Iir_Kind_Leftof_Attribute =>
+ Disp_Parametered_Type_Attribute ("leftof", Expr);
+ when Iir_Kind_Rightof_Attribute =>
+ Disp_Parametered_Type_Attribute ("rightof", Expr);
+
+ when Iir_Kind_Length_Array_Attribute =>
+ Disp_Parametered_Attribute ("length", Expr);
+ when Iir_Kind_Range_Array_Attribute =>
+ Disp_Parametered_Attribute ("range", Expr);
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ Disp_Parametered_Attribute ("reverse_range", Expr);
+ when Iir_Kind_Left_Array_Attribute =>
+ Disp_Parametered_Attribute ("left", Expr);
+ when Iir_Kind_Right_Array_Attribute =>
+ Disp_Parametered_Attribute ("right", Expr);
+ when Iir_Kind_Low_Array_Attribute =>
+ Disp_Parametered_Attribute ("low", Expr);
+ when Iir_Kind_High_Array_Attribute =>
+ Disp_Parametered_Attribute ("high", Expr);
+ when Iir_Kind_Ascending_Array_Attribute =>
+ Disp_Parametered_Attribute ("ascending", Expr);
+
+ when Iir_Kind_Image_Attribute =>
+ Disp_Parametered_Attribute ("image", Expr);
+ when Iir_Kind_Value_Attribute =>
+ Disp_Parametered_Attribute ("value", Expr);
+ when Iir_Kind_Simple_Name_Attribute =>
+ Disp_Name (Get_Prefix (Expr));
+ Put ("'simple_name");
+ when Iir_Kind_Instance_Name_Attribute =>
+ Disp_Name (Get_Prefix (Expr));
+ Put ("'instance_name");
+ when Iir_Kind_Path_Name_Attribute =>
+ Disp_Name (Get_Prefix (Expr));
+ Put ("'path_name");
+
+ when Iir_Kind_Selected_By_All_Name =>
+ Disp_Expression (Get_Prefix (Expr));
+ when Iir_Kind_Selected_Name =>
+ Disp_Name (Expr);
+ when Iir_Kind_Simple_Name =>
+ Disp_Name (Expr);
+
+ when Iir_Kinds_Type_And_Subtype_Definition =>
+ Disp_Type (Expr);
+
+ when Iir_Kind_Range_Expression =>
+ Disp_Range (Expr);
+ when Iir_Kind_Subtype_Declaration =>
+ Disp_Name_Of (Expr);
+
+ when others =>
+ Error_Kind ("disp_expression", Expr);
+ end case;
+ end Disp_Expression;
+
+ procedure Disp_PSL_HDL_Expr (N : PSL.Nodes.HDL_Node) is
+ begin
+ Disp_Expression (Iir (N));
+ end Disp_PSL_HDL_Expr;
+
+ procedure Disp_Psl_Expression (Expr : PSL_Node) is
+ begin
+ PSL.Prints.HDL_Expr_Printer := Disp_PSL_HDL_Expr'Access;
+ PSL.Prints.Print_Property (Expr);
+ end Disp_Psl_Expression;
+
+ procedure Disp_Block_Header (Header : Iir_Block_Header; Indent: Count)
+ is
+ Chain : Iir;
+ begin
+ if Header = Null_Iir then
+ return;
+ end if;
+ Chain := Get_Generic_Chain (Header);
+ if Chain /= Null_Iir then
+ Set_Col (Indent + Indentation);
+ Disp_Generics (Header);
+ Chain := Get_Generic_Map_Aspect_Chain (Header);
+ if Chain /= Null_Iir then
+ Set_Col (Indent + Indentation);
+ Disp_Generic_Map_Aspect (Header);
+ Put_Line (";");
+ end if;
+ end if;
+ Chain := Get_Port_Chain (Header);
+ if Chain /= Null_Iir then
+ Set_Col (Indent + Indentation);
+ Disp_Ports (Header);
+ Chain := Get_Port_Map_Aspect_Chain (Header);
+ if Chain /= Null_Iir then
+ Set_Col (Indent + Indentation);
+ Disp_Port_Map_Aspect (Header);
+ Put_Line (";");
+ end if;
+ end if;
+ end Disp_Block_Header;
+
+ procedure Disp_Block_Statement (Block: Iir_Block_Statement)
+ is
+ Indent: Count;
+ Sensitivity: Iir_List;
+ Guard : Iir_Guard_Signal_Declaration;
+ begin
+ Indent := Col;
+ Disp_Label (Block);
+ Put ("block");
+ Guard := Get_Guard_Decl (Block);
+ if Guard /= Null_Iir then
+ Put (" (");
+ Disp_Expression (Get_Guard_Expression (Guard));
+ Put_Line (")");
+ Sensitivity := Get_Guard_Sensitivity_List (Guard);
+ if Sensitivity /= Null_Iir_List then
+ Set_Col (Indent + Indentation);
+ Put ("-- guard sensitivity list ");
+ Disp_Designator_List (Sensitivity);
+ end if;
+ else
+ New_Line;
+ end if;
+ Disp_Block_Header (Get_Block_Header (Block),
+ Indent + Indentation);
+ Disp_Declaration_Chain (Block, Indent + Indentation);
+ Set_Col (Indent);
+ Put_Line ("begin");
+ Disp_Concurrent_Statement_Chain (Block, Indent + Indentation);
+ Set_Col (Indent);
+ Disp_End (Block, "block");
+ end Disp_Block_Statement;
+
+ procedure Disp_Generate_Statement (Stmt : Iir_Generate_Statement)
+ is
+ Indent : Count;
+ Scheme : Iir;
+ begin
+ Indent := Col;
+ Disp_Label (Stmt);
+ Scheme := Get_Generation_Scheme (Stmt);
+ case Get_Kind (Scheme) is
+ when Iir_Kind_Iterator_Declaration =>
+ Put ("for ");
+ Disp_Parameter_Specification (Scheme);
+ when others =>
+ Put ("if ");
+ Disp_Expression (Scheme);
+ end case;
+ Put_Line (" generate");
+ Disp_Declaration_Chain (Stmt, Indent);
+ if Get_Has_Begin (Stmt) then
+ Set_Col (Indent);
+ Put_Line ("begin");
+ end if;
+ Disp_Concurrent_Statement_Chain (Stmt, Indent + Indentation);
+ Set_Col (Indent);
+ Disp_End (Stmt, "generate");
+ end Disp_Generate_Statement;
+
+ procedure Disp_Psl_Default_Clock (Stmt : Iir) is
+ begin
+ Put ("--psl default clock is ");
+ Disp_Psl_Expression (Get_Psl_Boolean (Stmt));
+ Put_Line (";");
+ end Disp_Psl_Default_Clock;
+
+ procedure Disp_PSL_NFA (N : PSL.Nodes.NFA)
+ is
+ use PSL.NFAs;
+ use PSL.Nodes;
+
+ procedure Disp_State (S : NFA_State) is
+ Str : constant String := Int32'Image (Get_State_Label (S));
+ begin
+ Put (Str (2 .. Str'Last));
+ end Disp_State;
+
+ S : NFA_State;
+ E : NFA_Edge;
+ begin
+ if N /= No_NFA then
+ S := Get_First_State (N);
+ while S /= No_State loop
+ E := Get_First_Src_Edge (S);
+ while E /= No_Edge loop
+ Put ("-- ");
+ Disp_State (S);
+ Put (" -> ");
+ Disp_State (Get_Edge_Dest (E));
+ Put (": ");
+ Disp_Psl_Expression (Get_Edge_Expr (E));
+ New_Line;
+ E := Get_Next_Src_Edge (E);
+ end loop;
+ S := Get_Next_State (S);
+ end loop;
+ end if;
+ end Disp_PSL_NFA;
+
+ procedure Disp_Psl_Assert_Statement (Stmt : Iir) is
+ begin
+ Put ("--psl assert ");
+ Disp_Psl_Expression (Get_Psl_Property (Stmt));
+ Put_Line (";");
+ Disp_PSL_NFA (Get_PSL_NFA (Stmt));
+ end Disp_Psl_Assert_Statement;
+
+ procedure Disp_Psl_Cover_Statement (Stmt : Iir) is
+ begin
+ Put ("--psl cover ");
+ Disp_Psl_Expression (Get_Psl_Property (Stmt));
+ Put_Line (";");
+ Disp_PSL_NFA (Get_PSL_NFA (Stmt));
+ end Disp_Psl_Cover_Statement;
+
+ procedure Disp_Simple_Simultaneous_Statement (Stmt : Iir)
+ is
+ begin
+ Disp_Label (Stmt);
+ Disp_Expression (Get_Simultaneous_Left (Stmt));
+ Put (" == ");
+ Disp_Expression (Get_Simultaneous_Right (Stmt));
+ Put_Line (";");
+ end Disp_Simple_Simultaneous_Statement;
+
+ procedure Disp_Concurrent_Statement (Stmt: Iir) is
+ begin
+ case Get_Kind (Stmt) is
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment =>
+ Disp_Concurrent_Conditional_Signal_Assignment (Stmt);
+ when Iir_Kind_Concurrent_Selected_Signal_Assignment =>
+ Disp_Concurrent_Selected_Signal_Assignment (Stmt);
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ Disp_Process_Statement (Stmt);
+ when Iir_Kind_Concurrent_Assertion_Statement =>
+ Disp_Assertion_Statement (Stmt);
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Disp_Component_Instantiation_Statement (Stmt);
+ when Iir_Kind_Concurrent_Procedure_Call_Statement =>
+ Disp_Label (Stmt);
+ Disp_Postponed (Stmt);
+ Disp_Procedure_Call (Get_Procedure_Call (Stmt));
+ when Iir_Kind_Block_Statement =>
+ Disp_Block_Statement (Stmt);
+ when Iir_Kind_Generate_Statement =>
+ Disp_Generate_Statement (Stmt);
+ when Iir_Kind_Psl_Default_Clock =>
+ Disp_Psl_Default_Clock (Stmt);
+ when Iir_Kind_Psl_Assert_Statement =>
+ Disp_Psl_Assert_Statement (Stmt);
+ when Iir_Kind_Psl_Cover_Statement =>
+ Disp_Psl_Cover_Statement (Stmt);
+ when Iir_Kind_Simple_Simultaneous_Statement =>
+ Disp_Simple_Simultaneous_Statement (Stmt);
+ when others =>
+ Error_Kind ("disp_concurrent_statement", Stmt);
+ end case;
+ end Disp_Concurrent_Statement;
+
+ procedure Disp_Package_Declaration (Decl: Iir_Package_Declaration)
+ is
+ Header : constant Iir := Get_Package_Header (Decl);
+ begin
+ Put ("package ");
+ Disp_Identifier (Decl);
+ Put_Line (" is");
+ if Header /= Null_Iir then
+ Disp_Generics (Header);
+ New_Line;
+ end if;
+ Disp_Declaration_Chain (Decl, Col + Indentation);
+ Disp_End (Decl, "package");
+ end Disp_Package_Declaration;
+
+ procedure Disp_Package_Body (Decl: Iir)
+ is
+ begin
+ Put ("package body ");
+ Disp_Identifier (Decl);
+ Put_Line (" is");
+ Disp_Declaration_Chain (Decl, Col + Indentation);
+ Disp_End (Decl, "package body");
+ end Disp_Package_Body;
+
+ procedure Disp_Package_Instantiation_Declaration (Decl: Iir) is
+ begin
+ Put ("package ");
+ Disp_Identifier (Decl);
+ Put_Line (" is new ");
+ Disp_Name (Get_Uninstantiated_Package_Name (Decl));
+ Put (" ");
+ Disp_Generic_Map_Aspect (Decl);
+ Put_Line (";");
+ end Disp_Package_Instantiation_Declaration;
+
+ procedure Disp_Binding_Indication (Bind : Iir; Indent : Count)
+ is
+ El : Iir;
+ begin
+ El := Get_Entity_Aspect (Bind);
+ if El /= Null_Iir then
+ Set_Col (Indent);
+ Put ("use ");
+ Disp_Entity_Aspect (El);
+ end if;
+ El := Get_Generic_Map_Aspect_Chain (Bind);
+ if El /= Null_Iir then
+ Set_Col (Indent);
+ Disp_Generic_Map_Aspect (Bind);
+ end if;
+ El := Get_Port_Map_Aspect_Chain (Bind);
+ if El /= Null_Iir then
+ Set_Col (Indent);
+ Disp_Port_Map_Aspect (Bind);
+ end if;
+ end Disp_Binding_Indication;
+
+ procedure Disp_Component_Configuration
+ (Conf : Iir_Component_Configuration; Indent : Count)
+ is
+ Block : Iir_Block_Configuration;
+ Binding : Iir;
+ begin
+ Set_Col (Indent);
+ Put ("for ");
+ Disp_Instantiation_List (Get_Instantiation_List (Conf));
+ Put (" : ");
+ Disp_Name_Of (Get_Component_Name (Conf));
+ New_Line;
+ Binding := Get_Binding_Indication (Conf);
+ if Binding /= Null_Iir then
+ Disp_Binding_Indication (Binding, Indent + Indentation);
+ Put (";");
+ end if;
+ Block := Get_Block_Configuration (Conf);
+ if Block /= Null_Iir then
+ Disp_Block_Configuration (Block, Indent + Indentation);
+ end if;
+ Set_Col (Indent);
+ Put_Line ("end for;");
+ end Disp_Component_Configuration;
+
+ procedure Disp_Configuration_Items
+ (Conf : Iir_Block_Configuration; Indent : Count)
+ is
+ El : Iir;
+ begin
+ El := Get_Configuration_Item_Chain (Conf);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Block_Configuration =>
+ Disp_Block_Configuration (El, Indent);
+ when Iir_Kind_Component_Configuration =>
+ Disp_Component_Configuration (El, Indent);
+ when Iir_Kind_Configuration_Specification =>
+ -- This may be created by canon.
+ Set_Col (Indent);
+ Disp_Configuration_Specification (El);
+ Set_Col (Indent);
+ Put_Line ("end for;");
+ when others =>
+ Error_Kind ("disp_configuration_item_list", El);
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Disp_Configuration_Items;
+
+ procedure Disp_Block_Configuration
+ (Block: Iir_Block_Configuration; Indent: Count)
+ is
+ Spec : Iir;
+ begin
+ Set_Col (Indent);
+ Put ("for ");
+ Spec := Get_Block_Specification (Block);
+ case Get_Kind (Spec) is
+ when Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Architecture_Body =>
+ Disp_Name_Of (Spec);
+ when Iir_Kind_Indexed_Name =>
+ declare
+ Index_List : constant Iir_List := Get_Index_List (Spec);
+ begin
+ Disp_Name_Of (Get_Prefix (Spec));
+ Put (" (");
+ if Index_List = Iir_List_Others then
+ Put ("others");
+ else
+ Disp_Expression (Get_First_Element (Index_List));
+ end if;
+ Put (")");
+ end;
+ when Iir_Kind_Slice_Name =>
+ Disp_Name_Of (Get_Prefix (Spec));
+ Put (" (");
+ Disp_Range (Get_Suffix (Spec));
+ Put (")");
+ when Iir_Kind_Simple_Name =>
+ Disp_Name (Spec);
+ when others =>
+ Error_Kind ("disp_block_configuration", Spec);
+ end case;
+ New_Line;
+ Disp_Declaration_Chain (Block, Indent + Indentation);
+ Disp_Configuration_Items (Block, Indent + Indentation);
+ Set_Col (Indent);
+ Put_Line ("end for;");
+ end Disp_Block_Configuration;
+
+ procedure Disp_Configuration_Declaration
+ (Decl: Iir_Configuration_Declaration)
+ is
+ begin
+ Put ("configuration ");
+ Disp_Name_Of (Decl);
+ Put (" of ");
+ Disp_Name (Get_Entity_Name (Decl));
+ Put_Line (" is");
+ Disp_Declaration_Chain (Decl, Col);
+ Disp_Block_Configuration (Get_Block_Configuration (Decl),
+ Col + Indentation);
+ Disp_End (Decl, "configuration");
+ end Disp_Configuration_Declaration;
+
+ procedure Disp_Design_Unit (Unit: Iir_Design_Unit)
+ is
+ Indent: constant Count := Col;
+ Decl: Iir;
+ Next_Decl : Iir;
+ begin
+ Decl := Get_Context_Items (Unit);
+ while Decl /= Null_Iir loop
+ Next_Decl := Get_Chain (Decl);
+
+ Set_Col (Indent);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Use_Clause =>
+ Disp_Use_Clause (Decl);
+ when Iir_Kind_Library_Clause =>
+ Put ("library ");
+ Disp_Identifier (Decl);
+ while Get_Has_Identifier_List (Decl) loop
+ Decl := Next_Decl;
+ Next_Decl := Get_Chain (Decl);
+ Put (", ");
+ Disp_Identifier (Decl);
+ end loop;
+ Put_Line (";");
+ when others =>
+ Error_Kind ("disp_design_unit1", Decl);
+ end case;
+ Decl := Next_Decl;
+ end loop;
+
+ Decl := Get_Library_Unit (Unit);
+ Set_Col (Indent);
+ case Get_Kind (Decl) is
+ when Iir_Kind_Entity_Declaration =>
+ Disp_Entity_Declaration (Decl);
+ when Iir_Kind_Architecture_Body =>
+ Disp_Architecture_Body (Decl);
+ when Iir_Kind_Package_Declaration =>
+ Disp_Package_Declaration (Decl);
+ when Iir_Kind_Package_Body =>
+ Disp_Package_Body (Decl);
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ Disp_Package_Instantiation_Declaration (Decl);
+ when Iir_Kind_Configuration_Declaration =>
+ Disp_Configuration_Declaration (Decl);
+ when others =>
+ Error_Kind ("disp_design_unit2", Decl);
+ end case;
+ New_Line;
+ New_Line;
+ end Disp_Design_Unit;
+
+ procedure Disp_Vhdl (An_Iir: Iir) is
+ begin
+ -- Put (Count'Image (Line_Length));
+ case Get_Kind (An_Iir) is
+ when Iir_Kind_Design_Unit =>
+ Disp_Design_Unit (An_Iir);
+ when Iir_Kind_Character_Literal =>
+ Disp_Character_Literal (An_Iir);
+ when Iir_Kind_Enumeration_Type_Definition =>
+ Disp_Enumeration_Type_Definition (An_Iir);
+ when Iir_Kind_Enumeration_Subtype_Definition =>
+ Disp_Enumeration_Subtype_Definition (An_Iir);
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment =>
+ Disp_Concurrent_Conditional_Signal_Assignment (An_Iir);
+ when Iir_Kinds_Dyadic_Operator =>
+ Disp_Dyadic_Operator (An_Iir);
+ when Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Object_Alias_Declaration =>
+ Disp_Name_Of (An_Iir);
+ when Iir_Kind_Enumeration_Literal =>
+ Disp_Identifier (An_Iir);
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Disp_Component_Instantiation_Statement (An_Iir);
+ when Iir_Kind_Integer_Subtype_Definition =>
+ Disp_Integer_Subtype_Definition (An_Iir);
+ when Iir_Kind_Array_Subtype_Definition =>
+ Disp_Array_Subtype_Definition (An_Iir);
+ when Iir_Kind_Array_Type_Definition =>
+ Disp_Array_Type_Definition (An_Iir);
+ when Iir_Kind_Package_Declaration =>
+ Disp_Package_Declaration (An_Iir);
+ when Iir_Kind_Wait_Statement =>
+ Disp_Wait_Statement (An_Iir);
+ when Iir_Kind_Selected_Name
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name =>
+ Disp_Expression (An_Iir);
+ when others =>
+ Error_Kind ("disp", An_Iir);
+ end case;
+ end Disp_Vhdl;
+
+ procedure Disp_Int64 (Val: Iir_Int64)
+ is
+ Str: constant String := Iir_Int64'Image (Val);
+ begin
+ if Str(Str'First) = ' ' then
+ Put (Str (Str'First + 1 .. Str'Last));
+ else
+ Put (Str);
+ end if;
+ end Disp_Int64;
+
+ procedure Disp_Int32 (Val: Iir_Int32)
+ is
+ Str: constant String := Iir_Int32'Image (Val);
+ begin
+ if Str(Str'First) = ' ' then
+ Put (Str (Str'First + 1 .. Str'Last));
+ else
+ Put (Str);
+ end if;
+ end Disp_Int32;
+
+ procedure Disp_Fp64 (Val: Iir_Fp64)
+ is
+ Str: constant String := Iir_Fp64'Image (Val);
+ begin
+ if Str(Str'First) = ' ' then
+ Put (Str (Str'First + 1 .. Str'Last));
+ else
+ Put (Str);
+ end if;
+ end Disp_Fp64;
+end Disp_Vhdl;
diff --git a/src/disp_vhdl.ads b/src/disp_vhdl.ads
new file mode 100644
index 000000000..880290efd
--- /dev/null
+++ b/src/disp_vhdl.ads
@@ -0,0 +1,38 @@
+-- VHDL regeneration from internal nodes.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with Iirs; use Iirs;
+
+package Disp_Vhdl is
+ -- General procedure to display a node.
+ -- Mainly used to dispatch to other functions according to the kind of
+ -- the node.
+ procedure Disp_Vhdl (An_Iir: Iir);
+
+ procedure Disp_Expression (Expr: Iir);
+ -- Display an expression.
+
+ -- Disp an iir_int64, without the leading blank.
+ procedure Disp_Int64 (Val: Iir_Int64);
+
+ -- Disp an iir_int32, without the leading blank.
+ procedure Disp_Int32 (Val: Iir_Int32);
+
+ -- Disp an iir_Fp64, without the leading blank.
+ procedure Disp_Fp64 (Val: Iir_Fp64);
+end Disp_Vhdl;
diff --git a/src/errorout.adb b/src/errorout.adb
new file mode 100644
index 000000000..1652bb43e
--- /dev/null
+++ b/src/errorout.adb
@@ -0,0 +1,1113 @@
+-- Error message handling.
+-- 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 GHDL; 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 Scanner;
+with Tokens; use Tokens;
+with Name_Table;
+with Iirs_Utils; use Iirs_Utils;
+with Files_Map; use Files_Map;
+with Ada.Strings.Unbounded;
+with Std_Names;
+with Flags;
+with PSL.Nodes;
+
+package body Errorout is
+ procedure Put (Str : String)
+ is
+ use Ada.Text_IO;
+ begin
+ Put (Standard_Error, Str);
+ end Put;
+
+ procedure Put (C : Character)
+ is
+ use Ada.Text_IO;
+ begin
+ Put (Standard_Error, C);
+ end Put;
+
+ procedure Put_Line (Str : String)
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line (Standard_Error, Str);
+ end Put_Line;
+
+ procedure Disp_Natural (Val: Natural)
+ is
+ Str: constant String := Natural'Image (Val);
+ begin
+ Put (Str(Str'First + 1 .. Str'Last));
+ end Disp_Natural;
+
+ procedure Error_Msg (Msg: String) is
+ begin
+ Put (Ada.Command_Line.Command_Name);
+ Put (": ");
+ Put_Line (Msg);
+ end Error_Msg;
+
+ procedure Error_Kind (Msg : String; An_Iir : Iir) is
+ begin
+ Put_Line (Msg & ": cannot handle "
+ & Iir_Kind'Image (Get_Kind (An_Iir))
+ & " (" & Disp_Location (An_Iir) & ')');
+ raise Internal_Error;
+ end Error_Kind;
+
+ procedure Error_Kind (Msg : String; Def : Iir_Predefined_Functions) is
+ begin
+ Put_Line (Msg & ": cannot handle "
+ & Iir_Predefined_Functions'Image (Def));
+ raise Internal_Error;
+ end Error_Kind;
+
+ procedure Error_Kind (Msg : String; N : PSL_Node) is
+ begin
+ Put (Msg);
+ Put (": cannot handle ");
+ Put_Line (PSL.Nodes.Nkind'Image (PSL.Nodes.Get_Kind (N)));
+ raise Internal_Error;
+ end Error_Kind;
+
+ procedure Error_Msg_Option_NR (Msg: String) is
+ begin
+ Put (Ada.Command_Line.Command_Name);
+ Put (": ");
+ Put_Line (Msg);
+ end Error_Msg_Option_NR;
+
+ procedure Error_Msg_Option (Msg: String) is
+ begin
+ Error_Msg_Option_NR (Msg);
+ raise Option_Error;
+ end Error_Msg_Option;
+
+ procedure Disp_Location
+ (File: Name_Id; Line: Natural; Col: Natural) is
+ begin
+ Put (Name_Table.Image (File));
+ Put (':');
+ Disp_Natural (Line);
+ Put (':');
+ Disp_Natural (Col);
+ Put (':');
+ end Disp_Location;
+
+ procedure Disp_Current_Location is
+ begin
+ Disp_Location (Scanner.Get_Current_File,
+ Scanner.Get_Current_Line,
+ Scanner.Get_Current_Column);
+ end Disp_Current_Location;
+
+ procedure Disp_Token_Location is
+ begin
+ Disp_Location (Scanner.Get_Current_File,
+ Scanner.Get_Current_Line,
+ Scanner.Get_Token_Column);
+ end Disp_Token_Location;
+
+ procedure Disp_Location (Loc : Location_Type)
+ is
+ Name : Name_Id;
+ Line : Natural;
+ Col : Natural;
+ begin
+ if Loc = Location_Nil then
+ -- Avoid a crash, but should not happen.
+ Put ("??:??:??:");
+ else
+ Location_To_Position (Loc, Name, Line, Col);
+ Disp_Location (Name, Line, Col);
+ end if;
+ end Disp_Location;
+
+ function Get_Location_Safe (N : Iir) return Location_Type is
+ begin
+ if N = Null_Iir then
+ return Location_Nil;
+ else
+ return Get_Location (N);
+ end if;
+ end Get_Location_Safe;
+
+ procedure Disp_Iir_Location (An_Iir: Iir) is
+ begin
+ Disp_Location (Get_Location_Safe (An_Iir));
+ end Disp_Iir_Location;
+
+ procedure Disp_PSL_Location (N : PSL_Node) is
+ begin
+ Disp_Location (PSL.Nodes.Get_Location (N));
+ end Disp_PSL_Location;
+
+ procedure Warning_Msg (Msg: String) is
+ begin
+ Put ("warning: ");
+ Put_Line (Msg);
+ end Warning_Msg;
+
+ procedure Warning_Msg_Parse (Msg: String) is
+ begin
+ if Flags.Flag_Only_Elab_Warnings then
+ return;
+ end if;
+ Disp_Token_Location;
+ if Flags.Warn_Error then
+ Nbr_Errors := Nbr_Errors + 1;
+ Put (" ");
+ else
+ Put ("warning: ");
+ end if;
+ Put_Line (Msg);
+ end Warning_Msg_Parse;
+
+ procedure Warning_Msg_Sem (Msg: String; Loc : Location_Type) is
+ begin
+ if Flags.Flag_Only_Elab_Warnings then
+ return;
+ end if;
+ Disp_Location (Loc);
+ if Flags.Warn_Error then
+ Nbr_Errors := Nbr_Errors + 1;
+ Put (" ");
+ else
+ Put ("warning: ");
+ end if;
+ Put_Line (Msg);
+ end Warning_Msg_Sem;
+
+ procedure Warning_Msg_Sem (Msg: String; Loc : Iir) is
+ begin
+ Warning_Msg_Sem (Msg, Get_Location_Safe (Loc));
+ end Warning_Msg_Sem;
+
+ procedure Warning_Msg_Elab (Msg: String; Loc : Location_Type) is
+ begin
+ Disp_Location (Loc);
+ if Flags.Warn_Error then
+ Nbr_Errors := Nbr_Errors + 1;
+ Put (" ");
+ else
+ Put ("warning: ");
+ end if;
+ Put_Line (Msg);
+ end Warning_Msg_Elab;
+
+ procedure Warning_Msg_Elab (Msg: String; Loc : Iir) is
+ begin
+ Warning_Msg_Elab (Msg, Get_Location_Safe (Loc));
+ end Warning_Msg_Elab;
+
+ procedure Disp_Current_Token;
+ pragma Unreferenced (Disp_Current_Token);
+
+ procedure Disp_Current_Token is
+ begin
+ case Scanner.Current_Token is
+ when Tok_Identifier =>
+ Put ("identifier """
+ & Name_Table.Image (Scanner.Current_Identifier) & """");
+ when others =>
+ Put (Token_Type'Image (Scanner.Current_Token));
+ end case;
+ end Disp_Current_Token;
+
+ -- Disp a message during scan.
+ procedure Error_Msg_Scan (Msg: String) is
+ begin
+ Nbr_Errors := Nbr_Errors + 1;
+ Disp_Current_Location;
+ Put (' ');
+ Put_Line (Msg);
+ end Error_Msg_Scan;
+
+ procedure Error_Msg_Scan (Msg: String; Loc : Location_Type) is
+ begin
+ Nbr_Errors := Nbr_Errors + 1;
+ Disp_Location (Loc);
+ Put (' ');
+ Put_Line (Msg);
+ end Error_Msg_Scan;
+
+ -- Disp a message during scan.
+ procedure Warning_Msg_Scan (Msg: String) is
+ begin
+ Disp_Current_Location;
+ Put ("warning: ");
+ Put_Line (Msg);
+ end Warning_Msg_Scan;
+
+ -- Disp a message during scan.
+ procedure Error_Msg_Parse (Msg: String) is
+ begin
+ Nbr_Errors := Nbr_Errors + 1;
+ Disp_Token_Location;
+ Put (' ');
+ Put_Line (Msg);
+ end Error_Msg_Parse;
+
+ procedure Error_Msg_Parse (Msg: String; Loc : Iir) is
+ begin
+ Nbr_Errors := Nbr_Errors + 1;
+ Disp_Iir_Location (Loc);
+ Put (' ');
+ Put_Line (Msg);
+ end Error_Msg_Parse;
+
+ procedure Error_Msg_Parse (Msg: String; Loc : Location_Type) is
+ begin
+ Nbr_Errors := Nbr_Errors + 1;
+ Disp_Location (Loc);
+ Put (' ');
+ Put_Line (Msg);
+ end Error_Msg_Parse;
+
+ -- Disp a message during semantic analysis.
+ -- LOC is used for location and current token.
+ procedure Error_Msg_Sem (Msg: String; Loc: in Iir) is
+ begin
+ Nbr_Errors := Nbr_Errors + 1;
+ if Loc /= Null_Iir then
+ Disp_Iir_Location (Loc);
+ Put (' ');
+ end if;
+ Put_Line (Msg);
+ end Error_Msg_Sem;
+
+ procedure Error_Msg_Sem (Msg: String; Loc: PSL_Node) is
+ use PSL.Nodes;
+ begin
+ Nbr_Errors := Nbr_Errors + 1;
+ if Loc /= Null_Node then
+ Disp_PSL_Location (Loc);
+ Put (' ');
+ end if;
+ Put_Line (Msg);
+ end Error_Msg_Sem;
+
+ procedure Error_Msg_Sem (Msg: String; Loc : Location_Type) is
+ begin
+ Nbr_Errors := Nbr_Errors + 1;
+ Disp_Location (Loc);
+ Put (' ');
+ Put_Line (Msg);
+ end Error_Msg_Sem;
+
+ -- Disp a message during elaboration.
+ procedure Error_Msg_Elab (Msg: String) is
+ begin
+ Nbr_Errors := Nbr_Errors + 1;
+ Put ("error: ");
+ Put_Line (Msg);
+ end Error_Msg_Elab;
+
+ procedure Error_Msg_Elab (Msg: String; Loc : Iir) is
+ begin
+ Nbr_Errors := Nbr_Errors + 1;
+ Disp_Iir_Location (Loc);
+ Put (' ');
+ Put_Line (Msg);
+ end Error_Msg_Elab;
+
+ -- Disp a bug message.
+ procedure Error_Internal (Expr: in Iir; Msg: String := "")
+ is
+ pragma Unreferenced (Expr);
+ begin
+ Put ("internal error: ");
+ Put_Line (Msg);
+ raise Internal_Error;
+ end Error_Internal;
+
+ function Disp_Label (Node : Iir; Str : String) return String
+ is
+ Id : Name_Id;
+ begin
+ Id := Get_Label (Node);
+ if Id = Null_Identifier then
+ return "(unlabeled) " & Str;
+ else
+ return Str & " labeled """ & Name_Table.Image (Id) & """";
+ end if;
+ end Disp_Label;
+
+ -- Disp a node.
+ -- Used for output of message.
+ function Disp_Node (Node: Iir) return String is
+ function Disp_Identifier (Node : Iir; Str : String) return String
+ is
+ Id : Name_Id;
+ begin
+ Id := Get_Identifier (Node);
+ return Str & " """ & Name_Table.Image (Id) & """";
+ end Disp_Identifier;
+
+ function Disp_Type (Node : Iir; Str : String) return String
+ is
+ Decl: Iir;
+ begin
+ Decl := Get_Type_Declarator (Node);
+ if Decl = Null_Iir then
+ return "the anonymous " & Str
+ & " defined at " & Disp_Location (Node);
+ else
+ return Disp_Identifier (Decl, Str);
+ end if;
+ end Disp_Type;
+
+ begin
+ case Get_Kind (Node) is
+ when Iir_Kind_String_Literal =>
+ return "string literal """
+ & Image_String_Lit (Node) & """";
+ when Iir_Kind_Bit_String_Literal =>
+ return "bit string literal """
+ & Image_String_Lit (Node) & """";
+ when Iir_Kind_Character_Literal =>
+ return "character literal " & Image_Identifier (Node);
+ when Iir_Kind_Integer_Literal =>
+ return "integer literal";
+ when Iir_Kind_Floating_Point_Literal =>
+ return "floating point literal";
+ when Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal =>
+ return "physical literal";
+ when Iir_Kind_Enumeration_Literal =>
+ return "enumeration literal " & Image_Identifier (Node);
+ when Iir_Kind_Element_Declaration =>
+ return Disp_Identifier (Node, "element");
+ when Iir_Kind_Record_Element_Constraint =>
+ return "record element constraint";
+ when Iir_Kind_Array_Element_Resolution =>
+ return "array element resolution";
+ when Iir_Kind_Record_Resolution =>
+ return "record resolution";
+ when Iir_Kind_Record_Element_Resolution =>
+ return "record element resolution";
+ when Iir_Kind_Null_Literal =>
+ return "null literal";
+ when Iir_Kind_Overflow_Literal =>
+ return Disp_Node (Get_Literal_Origin (Node));
+ when Iir_Kind_Aggregate =>
+ return "aggregate";
+ when Iir_Kind_Unit_Declaration =>
+ return Disp_Identifier (Node, "physical unit");
+ when Iir_Kind_Simple_Aggregate =>
+ return "locally static array literal";
+
+ when Iir_Kind_Operator_Symbol =>
+ return "operator name";
+ when Iir_Kind_Aggregate_Info =>
+ return "aggregate info";
+ when Iir_Kind_Signature =>
+ return "signature";
+ when Iir_Kind_Waveform_Element =>
+ return "waveform element";
+ when Iir_Kind_Conditional_Waveform =>
+ return "conditional waveform";
+ when Iir_Kind_Association_Element_Open =>
+ return "open association element";
+ when Iir_Kind_Association_Element_By_Individual =>
+ return "individual association element";
+ when Iir_Kind_Association_Element_By_Expression
+ | Iir_Kind_Association_Element_Package =>
+ return "association element";
+ when Iir_Kind_Overload_List =>
+ return "overloaded name or expression";
+
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Enumeration_Type_Definition =>
+ return Image_Identifier (Get_Type_Declarator (Node));
+ when Iir_Kind_Array_Type_Definition =>
+ return Disp_Type (Node, "array type");
+ when Iir_Kind_Array_Subtype_Definition =>
+ return Disp_Type (Node, "array subtype");
+ when Iir_Kind_Record_Type_Definition =>
+ return Disp_Type (Node, "record type");
+ when Iir_Kind_Record_Subtype_Definition =>
+ return Disp_Type (Node, "record subtype");
+ when Iir_Kind_Enumeration_Subtype_Definition =>
+ return Disp_Type (Node, "enumeration subtype");
+ when Iir_Kind_Integer_Subtype_Definition =>
+ return Disp_Type (Node, "integer subtype");
+ when Iir_Kind_Physical_Type_Definition =>
+ return Disp_Type (Node, "physical type");
+ when Iir_Kind_Physical_Subtype_Definition =>
+ return Disp_Type (Node, "physical subtype");
+ when Iir_Kind_File_Type_Definition =>
+ return Disp_Type (Node, "file type");
+ when Iir_Kind_Access_Type_Definition =>
+ return Disp_Type (Node, "access type");
+ when Iir_Kind_Access_Subtype_Definition =>
+ return Disp_Type (Node, "access subtype");
+ when Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Floating_Type_Definition =>
+ return Disp_Type (Node, "floating type");
+ when Iir_Kind_Incomplete_Type_Definition =>
+ return Disp_Type (Node, "incomplete type");
+ when Iir_Kind_Protected_Type_Declaration =>
+ return Disp_Type (Node, "protected type");
+ when Iir_Kind_Protected_Type_Body =>
+ return Disp_Type (Node, "protected type body");
+ when Iir_Kind_Subtype_Definition =>
+ return "subtype definition";
+
+ when Iir_Kind_Scalar_Nature_Definition =>
+ return Image_Identifier (Get_Nature_Declarator (Node));
+
+ when Iir_Kind_Choice_By_Expression =>
+ return "choice by expression";
+ when Iir_Kind_Choice_By_Range =>
+ return "choice by range";
+ when Iir_Kind_Choice_By_Name =>
+ return "choice by name";
+ when Iir_Kind_Choice_By_Others =>
+ return "others choice";
+ when Iir_Kind_Choice_By_None =>
+ return "positionnal choice";
+
+ when Iir_Kind_Function_Call =>
+ return "function call";
+ when Iir_Kind_Procedure_Call_Statement =>
+ return "procedure call statement";
+ when Iir_Kind_Procedure_Call =>
+ return "procedure call";
+ when Iir_Kind_Selected_Name =>
+ Name_Table.Image (Get_Identifier (Node));
+ return '''
+ & Name_Table.Name_Buffer (1 .. Name_Table.Name_Length)
+ & ''';
+ when Iir_Kind_Simple_Name =>
+ Name_Table.Image (Get_Identifier (Node));
+ return '''
+ & Name_Table.Name_Buffer (1 .. Name_Table.Name_Length)
+ & ''';
+ when Iir_Kind_Entity_Aspect_Entity =>
+ return "aspect " & Disp_Node (Get_Entity (Node))
+ & '(' & Image_Identifier (Get_Architecture (Node)) & ')';
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ return "configuration entity aspect";
+ when Iir_Kind_Entity_Aspect_Open =>
+ return "open entity aspect";
+
+ when Iir_Kinds_Monadic_Operator
+ | Iir_Kinds_Dyadic_Operator =>
+ return "operator """
+ & Name_Table.Image (Get_Operator_Name (Node)) & """";
+ when Iir_Kind_Parenthesis_Expression =>
+ return "expression";
+ when Iir_Kind_Qualified_Expression =>
+ return "qualified expression";
+ when Iir_Kind_Type_Conversion =>
+ return "type conversion";
+ when Iir_Kind_Allocator_By_Subtype
+ | Iir_Kind_Allocator_By_Expression =>
+ return "allocator";
+ when Iir_Kind_Indexed_Name =>
+ return "indexed name";
+ when Iir_Kind_Range_Expression =>
+ return "range expression";
+ when Iir_Kind_Implicit_Dereference =>
+ return "implicit access dereference";
+ when Iir_Kind_Dereference =>
+ return "access dereference";
+ when Iir_Kind_Selected_Element =>
+ return "selected element";
+ when Iir_Kind_Selected_By_All_Name =>
+ return ".all name";
+ when Iir_Kind_Psl_Expression =>
+ return "PSL instantiation";
+
+ when Iir_Kind_Interface_Constant_Declaration =>
+ if Get_Parent (Node) = Null_Iir then
+ -- For constant interface of predefined operator.
+ return "anonymous interface";
+ end if;
+ case Get_Kind (Get_Parent (Node)) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Block_Header =>
+ return Disp_Identifier (Node, "generic");
+ when others =>
+ return Disp_Identifier (Node, "constant interface");
+ end case;
+ when Iir_Kind_Interface_Signal_Declaration =>
+ case Get_Kind (Get_Parent (Node)) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Block_Header =>
+ return Disp_Identifier (Node, "port");
+ when others =>
+ return Disp_Identifier (Node, "signal interface");
+ end case;
+ when Iir_Kind_Interface_Variable_Declaration =>
+ return Disp_Identifier (Node, "variable interface");
+ when Iir_Kind_Interface_File_Declaration =>
+ return Disp_Identifier (Node, "file interface");
+ when Iir_Kind_Interface_Package_Declaration =>
+ return Disp_Identifier (Node, "package interface");
+ when Iir_Kind_Signal_Declaration =>
+ return Disp_Identifier (Node, "signal");
+ when Iir_Kind_Variable_Declaration =>
+ return Disp_Identifier (Node, "variable");
+ when Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Constant_Declaration =>
+ return Disp_Identifier (Node, "constant");
+ when Iir_Kind_File_Declaration =>
+ return Disp_Identifier (Node, "file");
+ when Iir_Kind_Object_Alias_Declaration =>
+ return Disp_Identifier (Node, "alias");
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ return Disp_Identifier (Node, "non-object alias");
+ when Iir_Kind_Guard_Signal_Declaration =>
+ return "GUARD signal";
+ when Iir_Kind_Group_Template_Declaration =>
+ return Disp_Identifier (Node, "group template");
+ when Iir_Kind_Group_Declaration =>
+ return Disp_Identifier (Node, "group");
+
+ when Iir_Kind_Library_Declaration
+ | Iir_Kind_Library_Clause =>
+ return Disp_Identifier (Node, "library");
+ when Iir_Kind_Design_File =>
+ return "design file";
+
+ when Iir_Kind_Procedure_Declaration =>
+ return Disp_Identifier (Node, "procedure");
+ when Iir_Kind_Procedure_Body
+ | Iir_Kind_Function_Body =>
+ return "subprogram body";
+ when Iir_Kind_Function_Declaration =>
+ return Disp_Identifier (Node, "function");
+
+ when Iir_Kind_Package_Declaration =>
+ return Disp_Identifier (Node, "package");
+ when Iir_Kind_Package_Body =>
+ return Disp_Identifier (Node, "package body");
+ when Iir_Kind_Entity_Declaration =>
+ return Disp_Identifier (Node, "entity");
+ when Iir_Kind_Architecture_Body =>
+ return Disp_Identifier (Node, "architecture") &
+ " of" & Disp_Identifier (Get_Entity_Name (Node), "");
+ when Iir_Kind_Configuration_Declaration =>
+ declare
+ Id : Name_Id;
+ Ent : Iir;
+ Arch : Iir;
+ begin
+ Id := Get_Identifier (Node);
+ if Id /= Null_Identifier then
+ return Disp_Identifier (Node, "configuration");
+ else
+ Ent := Get_Entity (Node);
+ Arch := Get_Block_Specification
+ (Get_Block_Configuration (Node));
+ return "default configuration of "
+ & Image_Identifier (Ent)
+ & '(' & Image_Identifier (Arch) & ')';
+ end if;
+ end;
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ return Disp_Identifier (Node, "instantiation package");
+
+ when Iir_Kind_Package_Header =>
+ return "package header";
+
+ when Iir_Kind_Component_Declaration =>
+ return Disp_Identifier (Node, "component");
+
+ when Iir_Kind_Design_Unit =>
+ return Disp_Node (Get_Library_Unit (Node));
+ when Iir_Kind_Use_Clause =>
+ return "use clause";
+ when Iir_Kind_Disconnection_Specification =>
+ return "disconnection specification";
+
+ when Iir_Kind_Slice_Name =>
+ return "slice";
+ when Iir_Kind_Parenthesis_Name =>
+ return "function call, slice or indexed name";
+ when Iir_Kind_Type_Declaration =>
+ return Disp_Identifier (Node, "type");
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ return Disp_Identifier (Node, "type");
+ when Iir_Kind_Subtype_Declaration =>
+ return Disp_Identifier (Node, "subtype");
+
+ when Iir_Kind_Nature_Declaration =>
+ return Disp_Identifier (Node, "nature");
+ when Iir_Kind_Subnature_Declaration =>
+ return Disp_Identifier (Node, "subnature");
+
+ when Iir_Kind_Component_Instantiation_Statement =>
+ return Disp_Identifier (Node, "component instance");
+ when Iir_Kind_Configuration_Specification =>
+ return "configuration specification";
+ when Iir_Kind_Component_Configuration =>
+ return "component configuration";
+ when Iir_Kind_Implicit_Function_Declaration =>
+ return Disp_Identifier (Node, "implicit function")
+ & Disp_Identifier (Get_Type_Reference (Node), " of type");
+-- return "implicit function "
+-- & Get_Predefined_Function_Name
+-- (Get_Implicit_Definition (Node));
+ when Iir_Kind_Implicit_Procedure_Declaration =>
+ return "implicit procedure "
+ & Get_Predefined_Function_Name (Get_Implicit_Definition (Node));
+
+ when Iir_Kind_Concurrent_Procedure_Call_Statement =>
+ return "concurrent procedure call";
+ when Iir_Kind_Generate_Statement =>
+ return "generate statement";
+
+ when Iir_Kind_Simple_Simultaneous_Statement =>
+ return "simple simultaneous statement";
+
+ when Iir_Kind_Psl_Declaration =>
+ return Disp_Identifier (Node, "PSL declaration");
+
+ when Iir_Kind_Terminal_Declaration =>
+ return Disp_Identifier (Node, "terminal declaration");
+ when Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration =>
+ return Disp_Identifier (Node, "quantity declaration");
+
+ when Iir_Kind_Attribute_Declaration =>
+ return Disp_Identifier (Node, "attribute");
+ when Iir_Kind_Attribute_Specification =>
+ return "attribute specification";
+ when Iir_Kind_Entity_Class =>
+ return "entity class";
+ when Iir_Kind_Attribute_Value =>
+ return "attribute value";
+ when Iir_Kind_Attribute_Name =>
+ return "attribute";
+ when Iir_Kind_Base_Attribute =>
+ return "'base attribute";
+ when Iir_Kind_Length_Array_Attribute =>
+ return "'length attribute";
+ when Iir_Kind_Range_Array_Attribute =>
+ return "'range attribute";
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ return "'reverse_range attribute";
+ when Iir_Kind_Ascending_Type_Attribute
+ | Iir_Kind_Ascending_Array_Attribute =>
+ return "'ascending attribute";
+ when Iir_Kind_Left_Type_Attribute
+ | Iir_Kind_Left_Array_Attribute =>
+ return "'left attribute";
+ when Iir_Kind_Right_Type_Attribute
+ | Iir_Kind_Right_Array_Attribute =>
+ return "'right attribute";
+ when Iir_Kind_Low_Type_Attribute
+ | Iir_Kind_Low_Array_Attribute =>
+ return "'low attribute";
+ when Iir_Kind_Leftof_Attribute =>
+ return "'leftof attribute";
+ when Iir_Kind_Rightof_Attribute =>
+ return "'rightof attribute";
+ when Iir_Kind_Pred_Attribute =>
+ return "'pred attribute";
+ when Iir_Kind_Succ_Attribute =>
+ return "'succ attribute";
+ when Iir_Kind_Pos_Attribute =>
+ return "'pos attribute";
+ when Iir_Kind_Val_Attribute =>
+ return "'val attribute";
+ when Iir_Kind_Image_Attribute =>
+ return "'image attribute";
+ when Iir_Kind_Value_Attribute =>
+ return "'value attribute";
+ when Iir_Kind_High_Type_Attribute
+ | Iir_Kind_High_Array_Attribute =>
+ return "'high attribute";
+ when Iir_Kind_Transaction_Attribute =>
+ return "'transaction attribute";
+ when Iir_Kind_Stable_Attribute =>
+ return "'stable attribute";
+ when Iir_Kind_Quiet_Attribute =>
+ return "'quiet attribute";
+ when Iir_Kind_Delayed_Attribute =>
+ return "'delayed attribute";
+ when Iir_Kind_Driving_Attribute =>
+ return "'driving attribute";
+ when Iir_Kind_Driving_Value_Attribute =>
+ return "'driving_value attribute";
+ when Iir_Kind_Event_Attribute =>
+ return "'event attribute";
+ when Iir_Kind_Active_Attribute =>
+ return "'active attribute";
+ when Iir_Kind_Last_Event_Attribute =>
+ return "'last_event attribute";
+ when Iir_Kind_Last_Active_Attribute =>
+ return "'last_active attribute";
+ when Iir_Kind_Last_Value_Attribute =>
+ return "'last_value attribute";
+ when Iir_Kind_Behavior_Attribute =>
+ return "'behavior attribute";
+ when Iir_Kind_Structure_Attribute =>
+ return "'structure attribute";
+
+ when Iir_Kind_Path_Name_Attribute =>
+ return "'path_name attribute";
+ when Iir_Kind_Instance_Name_Attribute =>
+ return "'instance_name attribute";
+ when Iir_Kind_Simple_Name_Attribute =>
+ return "'simple_name attribute";
+
+ when Iir_Kind_For_Loop_Statement =>
+ return Disp_Label (Node, "for loop statement");
+ when Iir_Kind_While_Loop_Statement =>
+ return Disp_Label (Node, "loop statement");
+ when Iir_Kind_Process_Statement
+ | Iir_Kind_Sensitized_Process_Statement =>
+ return Disp_Label (Node, "process");
+ when Iir_Kind_Block_Statement =>
+ return Disp_Label (Node, "block statement");
+ when Iir_Kind_Block_Header =>
+ return "block header";
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment =>
+ return Disp_Label
+ (Node, "concurrent conditional signal assignment");
+ when Iir_Kind_Concurrent_Selected_Signal_Assignment =>
+ return Disp_Label
+ (Node, "concurrent selected signal assignment");
+ when Iir_Kind_Concurrent_Assertion_Statement =>
+ return Disp_Label (Node, "concurrent assertion");
+ when Iir_Kind_Psl_Assert_Statement =>
+ return Disp_Label (Node, "PSL assertion");
+ when Iir_Kind_Psl_Cover_Statement =>
+ return Disp_Label (Node, "PSL cover");
+ when Iir_Kind_Psl_Default_Clock =>
+ return "PSL default clock";
+
+ when Iir_Kind_If_Statement =>
+ return Disp_Label (Node, "if statement");
+ when Iir_Kind_Elsif =>
+ return Disp_Label (Node, "else/elsif statement");
+ when Iir_Kind_Next_Statement =>
+ return Disp_Label (Node, "next statement");
+ when Iir_Kind_Exit_Statement =>
+ return Disp_Label (Node, "exit statement");
+ when Iir_Kind_Case_Statement =>
+ return Disp_Label (Node, "case statement");
+ when Iir_Kind_Return_Statement =>
+ return Disp_Label (Node, "return statement");
+ when Iir_Kind_Signal_Assignment_Statement =>
+ return Disp_Label (Node, "signal assignment statement");
+ when Iir_Kind_Variable_Assignment_Statement =>
+ return Disp_Label (Node, "variable assignment statement");
+ when Iir_Kind_Null_Statement =>
+ return Disp_Label (Node, "null statement");
+ when Iir_Kind_Wait_Statement =>
+ return Disp_Label (Node, "wait statement");
+ when Iir_Kind_Assertion_Statement =>
+ return Disp_Label (Node, "assertion statement");
+ when Iir_Kind_Report_Statement =>
+ return Disp_Label (Node, "report statement");
+
+ when Iir_Kind_Block_Configuration =>
+ return "block configuration";
+ when Iir_Kind_Binding_Indication =>
+ return "binding indication";
+
+ when Iir_Kind_Error =>
+ return "error";
+ when Iir_Kind_Unused =>
+ return "*unused*";
+ end case;
+ end Disp_Node;
+
+ -- Disp a node location.
+ -- Used for output of message.
+
+ function Get_Location_Str
+ (Name : Name_Id; Line, Col : Natural; Filename : Boolean)
+ return String
+ is
+ Line_Str : constant String := Natural'Image (Line);
+ Col_Str : constant String := Natural'Image (Col);
+ begin
+ if Filename then
+ return Name_Table.Image (Name)
+ & ':' & Line_Str (Line_Str'First + 1 .. Line_Str'Last)
+ & ':' & Col_Str (Col_Str'First + 1 .. Col_Str'Last);
+ else
+ return Line_Str (Line_Str'First + 1 .. Line_Str'Last)
+ & ':' & Col_Str (Col_Str'First + 1 .. Col_Str'Last);
+ end if;
+ end Get_Location_Str;
+
+ function Get_Location_Str (Loc : Location_Type; Filename : Boolean := True)
+ return string
+ is
+ Line, Col : Natural;
+ Name : Name_Id;
+ begin
+ if Loc = Location_Nil then
+ -- Avoid a crash.
+ return "??:??:??";
+ else
+ Location_To_Position (Loc, Name, Line, Col);
+ return Get_Location_Str (Name, Line, Col, Filename);
+ end if;
+ end Get_Location_Str;
+
+ function Disp_Location (Node: Iir) return String is
+ begin
+ return Get_Location_Str (Get_Location (Node));
+ end Disp_Location;
+
+ function Disp_Name (Kind : Iir_Kind) return String is
+ begin
+ case Kind is
+ when Iir_Kind_Constant_Declaration =>
+ return "constant declaration";
+ when Iir_Kind_Signal_Declaration =>
+ return "signal declaration";
+ when Iir_Kind_Variable_Declaration =>
+ return "variable declaration";
+ when Iir_Kind_File_Declaration =>
+ return "file declaration";
+ when others =>
+ return "???" & Iir_Kind'Image (Kind);
+ end case;
+ end Disp_Name;
+
+ function Image (N : Iir_Int64) return String
+ is
+ Res : constant String := Iir_Int64'Image (N);
+ begin
+ if Res (1) = ' ' then
+ return Res (2 .. Res'Last);
+ else
+ return Res;
+ end if;
+ end Image;
+
+ function Disp_Discrete (Dtype : Iir; Pos : Iir_Int64) return String is
+ begin
+ case Get_Kind (Dtype) is
+ when Iir_Kind_Integer_Type_Definition =>
+ return Image (Pos);
+ when Iir_Kind_Enumeration_Type_Definition =>
+ return Name_Table.Image
+ (Get_Identifier (Get_Nth_Element
+ (Get_Enumeration_Literal_List (Dtype),
+ Natural (Pos))));
+ when others =>
+ Error_Kind ("disp_discrete", Dtype);
+ end case;
+ end Disp_Discrete;
+
+ function Disp_Subprg (Subprg : Iir) return String
+ is
+ use Ada.Strings.Unbounded;
+ Res : Unbounded_String;
+
+ procedure Append_Type (Def : Iir)
+ is
+ use Name_Table;
+ Decl : Iir := Get_Type_Declarator (Def);
+ begin
+ if Decl = Null_Iir then
+ Decl := Get_Type_Declarator (Get_Base_Type (Def));
+ end if;
+ Image (Get_Identifier (Decl));
+ Append (Res, Name_Buffer (1 .. Name_Length));
+ end Append_Type;
+
+ begin
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Enumeration_Literal =>
+ Append (Res, "enumeration literal ");
+ when Iir_Kind_Implicit_Function_Declaration =>
+ Append (Res, "implicit function ");
+ when Iir_Kind_Implicit_Procedure_Declaration =>
+ Append (Res, "implicit procedure ");
+ when Iir_Kind_Function_Declaration =>
+ Append (Res, "function ");
+ when Iir_Kind_Procedure_Declaration =>
+ Append (Res, "procedure ");
+ when others =>
+ Error_Kind ("disp_subprg", Subprg);
+ end case;
+
+ declare
+ use Name_Table;
+
+ Id : constant Name_Id := Get_Identifier (Subprg);
+ begin
+ Image (Id);
+ case Id is
+ when Std_Names.Name_Id_Operators
+ | Std_Names.Name_Word_Operators
+ | Std_Names.Name_Xnor
+ | Std_Names.Name_Shift_Operators =>
+ Append (Res, """");
+ Append (Res, Name_Buffer (1 .. Name_Length));
+ Append (Res, """");
+ when others =>
+ Append (Res, Name_Buffer (1 .. Name_Length));
+ end case;
+ end;
+
+ Append (Res, " [");
+
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ declare
+ El : Iir;
+ begin
+ El := Get_Interface_Declaration_Chain (Subprg);
+ while El /= Null_Iir loop
+ Append_Type (Get_Type (El));
+ El := Get_Chain (El);
+ exit when El = Null_Iir;
+ Append (Res, ", ");
+ end loop;
+ end;
+ when others =>
+ null;
+ end case;
+
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Enumeration_Literal =>
+ Append (Res, " return ");
+ Append_Type (Get_Return_Type (Subprg));
+ when others =>
+ null;
+ end case;
+
+ Append (Res, "]");
+
+ return To_String (Res);
+ end Disp_Subprg;
+
+ -- DEF must be any type definition.
+ -- Return the type name of DEF, handle anonymous subtypes.
+ function Disp_Type_Name (Def : Iir) return String
+ is
+ Decl : Iir;
+ begin
+ Decl := Get_Type_Declarator (Def);
+ if Decl /= Null_Iir then
+ return Image_Identifier (Decl);
+ end if;
+ Decl := Get_Type_Declarator (Get_Base_Type (Def));
+ if Decl /= Null_Iir then
+ return "a subtype of " & Image_Identifier (Decl);
+ else
+ return "an unknown type";
+ end if;
+ end Disp_Type_Name;
+
+ function Disp_Type_Of (Node : Iir) return String
+ is
+ A_Type : Iir;
+ begin
+ A_Type := Get_Type (Node);
+ if A_Type = Null_Iir then
+ return "unknown";
+ elsif Get_Kind (A_Type) = Iir_Kind_Overload_List then
+ declare
+ use Ada.Strings.Unbounded;
+ Res : Unbounded_String;
+ List : Iir_List;
+ El : Iir;
+ Nbr : Natural;
+ begin
+ List := Get_Overload_List (A_Type);
+ Nbr := Get_Nbr_Elements (List);
+ if Nbr = 0 then
+ return "unknown";
+ elsif Nbr = 1 then
+ return Disp_Type_Name (Get_First_Element (List));
+ else
+ Append (Res, "one of ");
+ for I in 0 .. Nbr - 1 loop
+ El := Get_Nth_Element (List, I);
+ Append (Res, Disp_Type_Name (El));
+ if I < Nbr - 2 then
+ Append (Res, ", ");
+ elsif I = Nbr - 2 then
+ Append (Res, " or ");
+ end if;
+ end loop;
+ return To_String (Res);
+ end if;
+ end;
+ else
+ return Disp_Type_Name (A_Type);
+ end if;
+ end Disp_Type_Of;
+
+ procedure Error_Pure (Caller : Iir; Callee : Iir; Loc : Iir)
+ is
+ L : Location_Type;
+ begin
+ if Loc = Null_Iir then
+ L := Get_Location (Caller);
+ else
+ L := Get_Location (Loc);
+ end if;
+ Error_Msg_Sem
+ ("pure " & Disp_Node (Caller) & " cannot call (impure) "
+ & Disp_Node (Callee), L);
+ Error_Msg_Sem
+ ("(" & Disp_Node (Callee) & " is defined here)", Callee);
+ end Error_Pure;
+
+ procedure Error_Not_Match (Expr: Iir; A_Type: Iir; Loc : Iir)
+ is
+ begin
+ Error_Msg_Sem ("can't match " & Disp_Node (Expr) & " with type "
+ & Disp_Node (A_Type), Loc);
+ if Loc /= Expr then
+ Error_Msg_Sem ("(location of " & Disp_Node (Expr) & ")", Expr);
+ end if;
+ end Error_Not_Match;
+
+ function Get_Mode_Name (Mode : Iir_Mode) return String is
+ begin
+ case Mode is
+ when Iir_Unknown_Mode =>
+ raise Internal_Error;
+ when Iir_Linkage_Mode =>
+ return "linkage";
+ when Iir_Buffer_Mode =>
+ return "buffer";
+ when Iir_Out_Mode =>
+ return "out";
+ when Iir_Inout_Mode =>
+ return "inout";
+ when Iir_In_Mode =>
+ return "in";
+ end case;
+ end Get_Mode_Name;
+
+end Errorout;
diff --git a/src/errorout.ads b/src/errorout.ads
new file mode 100644
index 000000000..ce694fe37
--- /dev/null
+++ b/src/errorout.ads
@@ -0,0 +1,128 @@
+-- Error message handling.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with Iirs; use Iirs;
+
+package Errorout is
+ Option_Error: exception;
+ Parse_Error: exception;
+ Compilation_Error: exception;
+
+ -- This kind can't be handled.
+ --procedure Error_Kind (Msg: String; Kind: Iir_Kind);
+ procedure Error_Kind (Msg: String; An_Iir: in Iir);
+ procedure Error_Kind (Msg: String; Def : Iir_Predefined_Functions);
+ procedure Error_Kind (Msg : String; N : PSL_Node);
+ pragma No_Return (Error_Kind);
+
+ -- The number of errors (ie, number of calls to error_msg*).
+ Nbr_Errors: Natural := 0;
+
+ -- Disp an error, prepended with program name.
+ procedure Error_Msg (Msg: String);
+
+ -- Disp an error, prepended with program name, and raise option_error.
+ -- This is used for errors before initialisation, such as bad option or
+ -- bad filename.
+ procedure Error_Msg_Option (Msg: String);
+ pragma No_Return (Error_Msg_Option);
+
+ -- Same as Error_Msg_Option but do not raise Option_Error.
+ procedure Error_Msg_Option_NR (Msg: String);
+
+ -- Disp an error location (using AN_IIR location) using the standard
+ -- format `file:line:col: '.
+ procedure Disp_Iir_Location (An_Iir: Iir);
+
+ -- Disp a warning.
+ procedure Warning_Msg (Msg: String);
+ procedure Warning_Msg_Parse (Msg: String);
+ procedure Warning_Msg_Sem (Msg: String; Loc : Iir);
+ procedure Warning_Msg_Sem (Msg: String; Loc : Location_Type);
+
+ -- Disp a message during scan.
+ -- The current location is automatically displayed before the message.
+ procedure Error_Msg_Scan (Msg: String);
+ procedure Error_Msg_Scan (Msg: String; Loc : Location_Type);
+ procedure Warning_Msg_Scan (Msg: String);
+
+ -- Disp a message during parse
+ -- The location of the current token is automatically displayed before
+ -- the message.
+ procedure Error_Msg_Parse (Msg: String);
+ procedure Error_Msg_Parse (Msg: String; Loc : Iir);
+ procedure Error_Msg_Parse (Msg: String; Loc : Location_Type);
+
+ -- Disp a message during semantic analysis.
+ -- an_iir is used for location and current token.
+ procedure Error_Msg_Sem (Msg: String; Loc: Iir);
+ procedure Error_Msg_Sem (Msg: String; Loc: PSL_Node);
+ procedure Error_Msg_Sem (Msg: String; Loc: Location_Type);
+
+ -- Disp a message during elaboration (or configuration).
+ procedure Error_Msg_Elab (Msg: String);
+ procedure Error_Msg_Elab (Msg: String; Loc: Iir);
+
+ -- Disp a warning durig elaboration (or configuration).
+ procedure Warning_Msg_Elab (Msg: String; Loc : Iir);
+
+ -- Disp a bug message.
+ procedure Error_Internal (Expr: Iir; Msg: String := "");
+ pragma No_Return (Error_Internal);
+
+ -- Disp a node.
+ -- Used for output of message.
+ function Disp_Node (Node: Iir) return String;
+
+ -- Disp a node location.
+ -- Used for output of message.
+ function Disp_Location (Node: Iir) return String;
+ function Get_Location_Str (Loc : Location_Type; Filename : Boolean := True)
+ return String;
+
+ -- Disp non-terminal name from KIND.
+ function Disp_Name (Kind : Iir_Kind) return String;
+
+ -- SUBPRG must be a subprogram declaration or an enumeration literal
+ -- declaration.
+ -- Returns:
+ -- "enumeration literal XX [ return TYPE ]"
+ -- "function XXX [ TYPE1, TYPE2 return TYPE ]"
+ -- "procedure XXX [ TYPE1, TYPE2 ]"
+ -- "implicit function XXX [ TYPE1, TYPE2 return TYPE ]"
+ -- "implicit procedure XXX [ TYPE1, TYPE2 ]"
+ function Disp_Subprg (Subprg : Iir) return String;
+
+ -- Print element POS of discrete type DTYPE.
+ function Disp_Discrete (Dtype : Iir; Pos : Iir_Int64) return String;
+
+ -- Disp the name of the type of NODE if known.
+ -- Disp "unknown" if it is not known.
+ -- Disp all possible types if it is an overload list.
+ function Disp_Type_Of (Node : Iir) return String;
+
+ -- Disp an error message when a pure function CALLER calls impure CALLEE.
+ procedure Error_Pure (Caller : Iir; Callee : Iir; Loc : Iir);
+
+ -- Report an error message as type of EXPR does not match A_TYPE.
+ -- Location is LOC.
+ procedure Error_Not_Match (Expr: Iir; A_Type: Iir; Loc : Iir);
+
+ -- Disp interface mode MODE.
+ function Get_Mode_Name (Mode : Iir_Mode) return String;
+end Errorout;
diff --git a/src/evaluation.adb b/src/evaluation.adb
new file mode 100644
index 000000000..8279e140c
--- /dev/null
+++ b/src/evaluation.adb
@@ -0,0 +1,3047 @@
+-- Evaluation of static expressions.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Unchecked_Deallocation;
+with Errorout; use Errorout;
+with Name_Table; use Name_Table;
+with Str_Table;
+with Iirs_Utils; use Iirs_Utils;
+with Std_Package; use Std_Package;
+with Flags; use Flags;
+with Std_Names;
+with Ada.Characters.Handling;
+
+package body Evaluation is
+ function Get_Physical_Value (Expr : Iir) return Iir_Int64
+ is
+ pragma Unsuppress (Overflow_Check);
+ Kind : constant Iir_Kind := Get_Kind (Expr);
+ Unit : Iir;
+ begin
+ case Kind is
+ when Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal =>
+ -- Extract Unit.
+ Unit := Get_Physical_Unit_Value
+ (Get_Named_Entity (Get_Unit_Name (Expr)));
+ case Kind is
+ when Iir_Kind_Physical_Int_Literal =>
+ return Get_Value (Expr) * Get_Value (Unit);
+ when Iir_Kind_Physical_Fp_Literal =>
+ return Iir_Int64
+ (Get_Fp_Value (Expr) * Iir_Fp64 (Get_Value (Unit)));
+ when others =>
+ raise Program_Error;
+ end case;
+ when Iir_Kind_Unit_Declaration =>
+ return Get_Value (Get_Physical_Unit_Value (Expr));
+ when others =>
+ Error_Kind ("get_physical_value", Expr);
+ end case;
+ exception
+ when Constraint_Error =>
+ Error_Msg_Sem ("arithmetic overflow in physical expression", Expr);
+ return Get_Value (Expr);
+ end Get_Physical_Value;
+
+ function Build_Integer (Val : Iir_Int64; Origin : Iir)
+ return Iir_Integer_Literal
+ is
+ Res : Iir_Integer_Literal;
+ begin
+ Res := Create_Iir (Iir_Kind_Integer_Literal);
+ Location_Copy (Res, Origin);
+ Set_Value (Res, Val);
+ Set_Type (Res, Get_Type (Origin));
+ Set_Literal_Origin (Res, Origin);
+ Set_Expr_Staticness (Res, Locally);
+ return Res;
+ end Build_Integer;
+
+ function Build_Floating (Val : Iir_Fp64; Origin : Iir)
+ return Iir_Floating_Point_Literal
+ is
+ Res : Iir_Floating_Point_Literal;
+ begin
+ Res := Create_Iir (Iir_Kind_Floating_Point_Literal);
+ Location_Copy (Res, Origin);
+ Set_Fp_Value (Res, Val);
+ Set_Type (Res, Get_Type (Origin));
+ Set_Literal_Origin (Res, Origin);
+ Set_Expr_Staticness (Res, Locally);
+ return Res;
+ end Build_Floating;
+
+ function Build_Enumeration_Constant (Val : Iir_Index32; Origin : Iir)
+ return Iir_Enumeration_Literal
+ is
+ Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin));
+ Enum_List : constant Iir_List :=
+ Get_Enumeration_Literal_List (Enum_Type);
+ Lit : constant Iir_Enumeration_Literal :=
+ Get_Nth_Element (Enum_List, Integer (Val));
+ Res : Iir_Enumeration_Literal;
+ begin
+ Res := Copy_Enumeration_Literal (Lit);
+ Location_Copy (Res, Origin);
+ Set_Literal_Origin (Res, Origin);
+ return Res;
+ end Build_Enumeration_Constant;
+
+ function Build_Physical (Val : Iir_Int64; Origin : Iir)
+ return Iir_Physical_Int_Literal
+ is
+ Res : Iir_Physical_Int_Literal;
+ Unit_Name : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Physical_Int_Literal);
+ Location_Copy (Res, Origin);
+ Unit_Name := Get_Primary_Unit_Name (Get_Base_Type (Get_Type (Origin)));
+ Set_Unit_Name (Res, Unit_Name);
+ Set_Value (Res, Val);
+ Set_Type (Res, Get_Type (Origin));
+ Set_Literal_Origin (Res, Origin);
+ Set_Expr_Staticness (Res, Locally);
+ return Res;
+ end Build_Physical;
+
+ function Build_Discrete (Val : Iir_Int64; Origin : Iir) return Iir is
+ begin
+ case Get_Kind (Get_Type (Origin)) is
+ when Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ return Build_Enumeration_Constant (Iir_Index32 (Val), Origin);
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition =>
+ return Build_Integer (Val, Origin);
+ when others =>
+ Error_Kind ("build_discrete", Get_Type (Origin));
+ end case;
+ end Build_Discrete;
+
+ function Build_String (Val : String_Id; Len : Nat32; Origin : Iir)
+ return Iir_String_Literal
+ is
+ Res : Iir_String_Literal;
+ begin
+ Res := Create_Iir (Iir_Kind_String_Literal);
+ Location_Copy (Res, Origin);
+ Set_String_Id (Res, Val);
+ Set_String_Length (Res, Len);
+ Set_Type (Res, Get_Type (Origin));
+ Set_Literal_Origin (Res, Origin);
+ Set_Expr_Staticness (Res, Locally);
+ return Res;
+ end Build_String;
+
+ function Build_Simple_Aggregate
+ (El_List : Iir_List; Origin : Iir; Stype : Iir)
+ return Iir_Simple_Aggregate
+ is
+ Res : Iir_Simple_Aggregate;
+ begin
+ Res := Create_Iir (Iir_Kind_Simple_Aggregate);
+ Location_Copy (Res, Origin);
+ Set_Simple_Aggregate_List (Res, El_List);
+ Set_Type (Res, Stype);
+ Set_Literal_Origin (Res, Origin);
+ Set_Expr_Staticness (Res, Locally);
+ Set_Literal_Subtype (Res, Stype);
+ return Res;
+ end Build_Simple_Aggregate;
+
+ function Build_Overflow (Origin : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Overflow_Literal);
+ Location_Copy (Res, Origin);
+ Set_Type (Res, Get_Type (Origin));
+ Set_Literal_Origin (Res, Origin);
+ Set_Expr_Staticness (Res, Locally);
+ return Res;
+ end Build_Overflow;
+
+ function Build_Constant (Val : Iir; Origin : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ -- Note: this must work for any literals, because it may be used to
+ -- replace a locally static constant by its initial value.
+ case Get_Kind (Val) is
+ when Iir_Kind_Integer_Literal =>
+ Res := Create_Iir (Iir_Kind_Integer_Literal);
+ Set_Value (Res, Get_Value (Val));
+
+ when Iir_Kind_Floating_Point_Literal =>
+ Res := Create_Iir (Iir_Kind_Floating_Point_Literal);
+ Set_Fp_Value (Res, Get_Fp_Value (Val));
+
+ when Iir_Kind_Enumeration_Literal =>
+ return Build_Enumeration_Constant
+ (Iir_Index32 (Get_Enum_Pos (Val)), Origin);
+
+ when Iir_Kind_Physical_Int_Literal =>
+ Res := Create_Iir (Iir_Kind_Physical_Int_Literal);
+ Set_Unit_Name (Res, Get_Primary_Unit_Name
+ (Get_Base_Type (Get_Type (Origin))));
+ Set_Value (Res, Get_Physical_Value (Val));
+
+ when Iir_Kind_Unit_Declaration =>
+ Res := Create_Iir (Iir_Kind_Physical_Int_Literal);
+ Set_Value (Res, Get_Physical_Value (Val));
+ Set_Unit_Name (Res, Get_Primary_Unit_Name (Get_Type (Val)));
+
+ when Iir_Kind_String_Literal =>
+ Res := Create_Iir (Iir_Kind_String_Literal);
+ Set_String_Id (Res, Get_String_Id (Val));
+ Set_String_Length (Res, Get_String_Length (Val));
+
+ when Iir_Kind_Bit_String_Literal =>
+ Res := Create_Iir (Iir_Kind_Bit_String_Literal);
+ Set_String_Id (Res, Get_String_Id (Val));
+ Set_String_Length (Res, Get_String_Length (Val));
+ Set_Bit_String_Base (Res, Get_Bit_String_Base (Val));
+ Set_Bit_String_0 (Res, Get_Bit_String_0 (Val));
+ Set_Bit_String_1 (Res, Get_Bit_String_1 (Val));
+
+ when Iir_Kind_Simple_Aggregate =>
+ Res := Create_Iir (Iir_Kind_Simple_Aggregate);
+ Set_Simple_Aggregate_List (Res, Get_Simple_Aggregate_List (Val));
+ Set_Literal_Subtype (Res, Get_Type (Origin));
+
+ when Iir_Kind_Overflow_Literal =>
+ Res := Create_Iir (Iir_Kind_Overflow_Literal);
+
+ when others =>
+ Error_Kind ("build_constant", Val);
+ end case;
+ Location_Copy (Res, Origin);
+ Set_Type (Res, Get_Type (Origin));
+ Set_Literal_Origin (Res, Origin);
+ Set_Expr_Staticness (Res, Locally);
+ return Res;
+ end Build_Constant;
+
+ function Build_Boolean (Cond : Boolean) return Iir is
+ begin
+ if Cond then
+ return Boolean_True;
+ else
+ return Boolean_False;
+ end if;
+ end Build_Boolean;
+
+ function Build_Enumeration (Val : Iir_Index32; Origin : Iir)
+ return Iir_Enumeration_Literal
+ is
+ Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin));
+ Enum_List : constant Iir_List :=
+ Get_Enumeration_Literal_List (Enum_Type);
+ begin
+ return Get_Nth_Element (Enum_List, Integer (Val));
+ end Build_Enumeration;
+
+ function Build_Enumeration (Val : Boolean; Origin : Iir)
+ return Iir_Enumeration_Literal
+ is
+ Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin));
+ Enum_List : constant Iir_List :=
+ Get_Enumeration_Literal_List (Enum_Type);
+ begin
+ return Get_Nth_Element (Enum_List, Boolean'Pos (Val));
+ end Build_Enumeration;
+
+ function Build_Constant_Range (Range_Expr : Iir; Origin : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Range_Expression);
+ Location_Copy (Res, Origin);
+ Set_Type (Res, Get_Type (Range_Expr));
+ Set_Left_Limit (Res, Get_Left_Limit (Range_Expr));
+ Set_Right_Limit (Res, Get_Right_Limit (Range_Expr));
+ Set_Direction (Res, Get_Direction (Range_Expr));
+ Set_Range_Origin (Res, Origin);
+ Set_Expr_Staticness (Res, Locally);
+ return Res;
+ end Build_Constant_Range;
+
+ function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir
+ is
+ Orig_Type : constant Iir := Get_Base_Type (Get_Type (Origin));
+ begin
+ case Get_Kind (Orig_Type) is
+ when Iir_Kind_Integer_Type_Definition =>
+ if Is_Pos then
+ return Build_Integer (Iir_Int64'Last, Origin);
+ else
+ return Build_Integer (Iir_Int64'First, Origin);
+ end if;
+ when others =>
+ Error_Kind ("build_extreme_value", Orig_Type);
+ end case;
+ end Build_Extreme_Value;
+
+ -- A_RANGE is a range expression, whose type, location, expr_staticness,
+ -- left_limit and direction are set.
+ -- Type of A_RANGE must have a range_constraint.
+ -- Set the right limit of A_RANGE from LEN.
+ procedure Set_Right_Limit_By_Length (A_Range : Iir; Len : Iir_Int64)
+ is
+ Left, Right : Iir;
+ Pos : Iir_Int64;
+ A_Type : Iir;
+ begin
+ if Get_Expr_Staticness (A_Range) /= Locally then
+ raise Internal_Error;
+ end if;
+ A_Type := Get_Type (A_Range);
+
+ Left := Get_Left_Limit (A_Range);
+
+ Pos := Eval_Pos (Left);
+ case Get_Direction (A_Range) is
+ when Iir_To =>
+ Pos := Pos + Len -1;
+ when Iir_Downto =>
+ Pos := Pos - Len + 1;
+ end case;
+ if Len > 0
+ and then not Eval_Int_In_Range (Pos, Get_Range_Constraint (A_Type))
+ then
+ Error_Msg_Sem ("range length is beyond subtype length", A_Range);
+ Right := Left;
+ else
+ -- FIXME: what about nul range?
+ Right := Build_Discrete (Pos, A_Range);
+ Set_Literal_Origin (Right, Null_Iir);
+ end if;
+ Set_Right_Limit (A_Range, Right);
+ end Set_Right_Limit_By_Length;
+
+ -- Create a range of type A_TYPE whose length is LEN.
+ -- Note: only two nodes are created:
+ -- * the range_expression (node returned)
+ -- * the right bound
+ -- The left bound *IS NOT* created, but points to the left bound of A_TYPE.
+ function Create_Range_By_Length
+ (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type)
+ return Iir
+ is
+ Index_Constraint : Iir;
+ Constraint : Iir;
+ begin
+ -- The left limit must be locally static in order to compute the right
+ -- limit.
+ pragma Assert (Get_Type_Staticness (A_Type) = Locally);
+
+ Index_Constraint := Get_Range_Constraint (A_Type);
+ Constraint := Create_Iir (Iir_Kind_Range_Expression);
+ Set_Location (Constraint, Loc);
+ Set_Expr_Staticness (Constraint, Locally);
+ Set_Type (Constraint, A_Type);
+ Set_Left_Limit (Constraint, Get_Left_Limit (Index_Constraint));
+ Set_Direction (Constraint, Get_Direction (Index_Constraint));
+ Set_Right_Limit_By_Length (Constraint, Len);
+ return Constraint;
+ end Create_Range_By_Length;
+
+ function Create_Range_Subtype_From_Type (A_Type : Iir; Loc : Location_Type)
+ return Iir
+ is
+ Res : Iir;
+ begin
+ pragma Assert (Get_Type_Staticness (A_Type) = Locally);
+
+ case Get_Kind (A_Type) is
+ when Iir_Kind_Enumeration_Type_Definition =>
+ Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition);
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition =>
+ Res := Create_Iir (Get_Kind (A_Type));
+ when others =>
+ Error_Kind ("create_range_subtype_by_length", A_Type);
+ end case;
+ Set_Location (Res, Loc);
+ Set_Base_Type (Res, Get_Base_Type (A_Type));
+ Set_Type_Staticness (Res, Locally);
+
+ return Res;
+ end Create_Range_Subtype_From_Type;
+
+ -- Create a subtype of A_TYPE whose length is LEN.
+ -- This is used to create subtypes for strings or aggregates.
+ function Create_Range_Subtype_By_Length
+ (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type)
+ return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Range_Subtype_From_Type (A_Type, Loc);
+
+ Set_Range_Constraint (Res, Create_Range_By_Length (A_Type, Len, Loc));
+ return Res;
+ end Create_Range_Subtype_By_Length;
+
+ function Create_Unidim_Array_From_Index
+ (Base_Type : Iir; Index_Type : Iir; Loc : Iir)
+ return Iir_Array_Subtype_Definition
+ is
+ Res : Iir_Array_Subtype_Definition;
+ begin
+ Res := Create_Array_Subtype (Base_Type, Get_Location (Loc));
+ Append_Element (Get_Index_Subtype_List (Res), Index_Type);
+ Set_Type_Staticness (Res, Min (Get_Type_Staticness (Res),
+ Get_Type_Staticness (Index_Type)));
+ Set_Constraint_State (Res, Fully_Constrained);
+ Set_Index_Constraint_Flag (Res, True);
+ return Res;
+ end Create_Unidim_Array_From_Index;
+
+ function Create_Unidim_Array_By_Length
+ (Base_Type : Iir; Len : Iir_Int64; Loc : Iir)
+ return Iir_Array_Subtype_Definition
+ is
+ Index_Type : constant Iir := Get_Index_Type (Base_Type, 0);
+ N_Index_Type : Iir;
+ begin
+ N_Index_Type := Create_Range_Subtype_By_Length
+ (Index_Type, Len, Get_Location (Loc));
+ return Create_Unidim_Array_From_Index (Base_Type, N_Index_Type, Loc);
+ end Create_Unidim_Array_By_Length;
+
+ procedure Free_Eval_Static_Expr (Res : Iir; Orig : Iir) is
+ begin
+ if Res /= Orig and then Get_Literal_Origin (Res) = Orig then
+ Free_Iir (Res);
+ end if;
+ end Free_Eval_Static_Expr;
+
+ -- Free the result RES of Eval_String_Literal called with ORIG, if created.
+ procedure Free_Eval_String_Literal (Res : Iir; Orig : Iir)
+ is
+ L : Iir_List;
+ begin
+ if Res /= Orig then
+ L := Get_Simple_Aggregate_List (Res);
+ Destroy_Iir_List (L);
+ Free_Iir (Res);
+ end if;
+ end Free_Eval_String_Literal;
+
+ function Eval_String_Literal (Str : Iir) return Iir
+ is
+ Ptr : String_Fat_Acc;
+ Len : Nat32;
+ begin
+ case Get_Kind (Str) is
+ when Iir_Kind_String_Literal =>
+ declare
+ Element_Type : Iir;
+ Literal_List : Iir_List;
+ Lit : Iir;
+
+ List : Iir_List;
+ begin
+ Element_Type := Get_Base_Type
+ (Get_Element_Subtype (Get_Base_Type (Get_Type (Str))));
+ Literal_List := Get_Enumeration_Literal_List (Element_Type);
+ List := Create_Iir_List;
+
+ Ptr := Get_String_Fat_Acc (Str);
+ Len := Get_String_Length (Str);
+
+ for I in 1 .. Len loop
+ Lit := Find_Name_In_List
+ (Literal_List,
+ Name_Table.Get_Identifier (Ptr (I)));
+ Append_Element (List, Lit);
+ end loop;
+ return Build_Simple_Aggregate (List, Str, Get_Type (Str));
+ end;
+
+ when Iir_Kind_Bit_String_Literal =>
+ declare
+ Str_Type : constant Iir := Get_Type (Str);
+ List : Iir_List;
+ Lit_0 : constant Iir := Get_Bit_String_0 (Str);
+ Lit_1 : constant Iir := Get_Bit_String_1 (Str);
+ begin
+ List := Create_Iir_List;
+
+ Ptr := Get_String_Fat_Acc (Str);
+ Len := Get_String_Length (Str);
+
+ for I in 1 .. Len loop
+ case Ptr (I) is
+ when '0' =>
+ Append_Element (List, Lit_0);
+ when '1' =>
+ Append_Element (List, Lit_1);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end loop;
+ return Build_Simple_Aggregate (List, Str, Str_Type);
+ end;
+
+ when Iir_Kind_Simple_Aggregate =>
+ return Str;
+
+ when others =>
+ Error_Kind ("eval_string_literal", Str);
+ end case;
+ end Eval_String_Literal;
+
+ function Eval_Monadic_Operator (Orig : Iir; Operand : Iir) return Iir
+ is
+ pragma Unsuppress (Overflow_Check);
+
+ Func : Iir_Predefined_Functions;
+ begin
+ if Get_Kind (Operand) = Iir_Kind_Overflow_Literal then
+ -- Propagate overflow.
+ return Build_Overflow (Orig);
+ end if;
+
+ Func := Get_Implicit_Definition (Get_Implementation (Orig));
+ case Func is
+ when Iir_Predefined_Integer_Negation =>
+ return Build_Integer (-Get_Value (Operand), Orig);
+ when Iir_Predefined_Integer_Identity =>
+ return Build_Integer (Get_Value (Operand), Orig);
+ when Iir_Predefined_Integer_Absolute =>
+ return Build_Integer (abs Get_Value (Operand), Orig);
+
+ when Iir_Predefined_Floating_Negation =>
+ return Build_Floating (-Get_Fp_Value (Operand), Orig);
+ when Iir_Predefined_Floating_Identity =>
+ return Build_Floating (Get_Fp_Value (Operand), Orig);
+ when Iir_Predefined_Floating_Absolute =>
+ return Build_Floating (abs Get_Fp_Value (Operand), Orig);
+
+ when Iir_Predefined_Physical_Negation =>
+ return Build_Physical (-Get_Physical_Value (Operand), Orig);
+ when Iir_Predefined_Physical_Identity =>
+ return Build_Physical (Get_Physical_Value (Operand), Orig);
+ when Iir_Predefined_Physical_Absolute =>
+ return Build_Physical (abs Get_Physical_Value (Operand), Orig);
+
+ when Iir_Predefined_Boolean_Not
+ | Iir_Predefined_Bit_Not =>
+ return Build_Enumeration (Get_Enum_Pos (Operand) = 0, Orig);
+
+ when Iir_Predefined_TF_Array_Not =>
+ declare
+ O_List : Iir_List;
+ R_List : Iir_List;
+ El : Iir;
+ Lit : Iir;
+ begin
+ O_List := Get_Simple_Aggregate_List
+ (Eval_String_Literal (Operand));
+ R_List := Create_Iir_List;
+
+ for I in Natural loop
+ El := Get_Nth_Element (O_List, I);
+ exit when El = Null_Iir;
+ case Get_Enum_Pos (El) is
+ when 0 =>
+ Lit := Bit_1;
+ when 1 =>
+ Lit := Bit_0;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Append_Element (R_List, Lit);
+ end loop;
+ return Build_Simple_Aggregate
+ (R_List, Orig, Get_Type (Operand));
+ end;
+ when others =>
+ Error_Internal (Orig, "eval_monadic_operator: " &
+ Iir_Predefined_Functions'Image (Func));
+ end case;
+ exception
+ when Constraint_Error =>
+ -- Can happen for absolute.
+ Warning_Msg_Sem ("arithmetic overflow in static expression", Orig);
+ return Build_Overflow (Orig);
+ end Eval_Monadic_Operator;
+
+ function Eval_Dyadic_Bit_Array_Operator
+ (Expr : Iir;
+ Left, Right : Iir;
+ Func : Iir_Predefined_Dyadic_TF_Array_Functions)
+ return Iir
+ is
+ use Str_Table;
+ L_Str : constant String_Fat_Acc := Get_String_Fat_Acc (Left);
+ R_Str : constant String_Fat_Acc := Get_String_Fat_Acc (Right);
+ Len : Nat32;
+ Id : String_Id;
+ Res : Iir;
+ begin
+ Len := Get_String_Length (Left);
+ if Len /= Get_String_Length (Right) then
+ Warning_Msg_Sem ("length of left and right operands mismatch", Expr);
+ return Build_Overflow (Expr);
+ else
+ Id := Start;
+ case Func is
+ when Iir_Predefined_TF_Array_And =>
+ for I in 1 .. Len loop
+ case L_Str (I) is
+ when '0' =>
+ Append ('0');
+ when '1' =>
+ Append (R_Str (I));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end loop;
+ when Iir_Predefined_TF_Array_Nand =>
+ for I in 1 .. Len loop
+ case L_Str (I) is
+ when '0' =>
+ Append ('1');
+ when '1' =>
+ case R_Str (I) is
+ when '0' =>
+ Append ('1');
+ when '1' =>
+ Append ('0');
+ when others =>
+ raise Internal_Error;
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end loop;
+ when Iir_Predefined_TF_Array_Or =>
+ for I in 1 .. Len loop
+ case L_Str (I) is
+ when '1' =>
+ Append ('1');
+ when '0' =>
+ Append (R_Str (I));
+ when others =>
+ raise Internal_Error;
+ end case;
+ end loop;
+ when Iir_Predefined_TF_Array_Nor =>
+ for I in 1 .. Len loop
+ case L_Str (I) is
+ when '1' =>
+ Append ('0');
+ when '0' =>
+ case R_Str (I) is
+ when '0' =>
+ Append ('1');
+ when '1' =>
+ Append ('0');
+ when others =>
+ raise Internal_Error;
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end loop;
+ when Iir_Predefined_TF_Array_Xor =>
+ for I in 1 .. Len loop
+ case L_Str (I) is
+ when '1' =>
+ case R_Str (I) is
+ when '0' =>
+ Append ('1');
+ when '1' =>
+ Append ('0');
+ when others =>
+ raise Internal_Error;
+ end case;
+ when '0' =>
+ case R_Str (I) is
+ when '0' =>
+ Append ('0');
+ when '1' =>
+ Append ('1');
+ when others =>
+ raise Internal_Error;
+ end case;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end loop;
+ when others =>
+ Error_Internal (Expr, "eval_dyadic_bit_array_functions: " &
+ Iir_Predefined_Functions'Image (Func));
+ end case;
+ Finish;
+ Res := Build_String (Id, Len, Expr);
+
+ -- The unconstrained type is replaced by the constrained one.
+ Set_Type (Res, Get_Type (Left));
+ return Res;
+ end if;
+ end Eval_Dyadic_Bit_Array_Operator;
+
+ -- Return TRUE if VAL /= 0.
+ function Check_Integer_Division_By_Zero (Expr : Iir; Val : Iir)
+ return Boolean
+ is
+ begin
+ if Get_Value (Val) = 0 then
+ Warning_Msg_Sem ("division by 0", Expr);
+ return False;
+ else
+ return True;
+ end if;
+ end Check_Integer_Division_By_Zero;
+
+ function Eval_Shift_Operator
+ (Left, Right : Iir; Origin : Iir; Func : Iir_Predefined_Shift_Functions)
+ return Iir
+ is
+ Count : Iir_Int64;
+ Cnt : Natural;
+ Len : Natural;
+ Arr_List : Iir_List;
+ Res_List : Iir_List;
+ Dir_Left : Boolean;
+ E : Iir;
+ begin
+ Count := Get_Value (Right);
+ Arr_List := Get_Simple_Aggregate_List (Left);
+ Len := Get_Nbr_Elements (Arr_List);
+ -- LRM93 7.2.3
+ -- That is, if R is 0 or if L is a null array, the return value is L.
+ if Count = 0 or Len = 0 then
+ return Build_Simple_Aggregate (Arr_List, Origin, Get_Type (Left));
+ end if;
+ case Func is
+ when Iir_Predefined_Array_Sll
+ | Iir_Predefined_Array_Sla
+ | Iir_Predefined_Array_Rol =>
+ Dir_Left := True;
+ when Iir_Predefined_Array_Srl
+ | Iir_Predefined_Array_Sra
+ | Iir_Predefined_Array_Ror =>
+ Dir_Left := False;
+ end case;
+ if Count < 0 then
+ Cnt := Natural (-Count);
+ Dir_Left := not Dir_Left;
+ else
+ Cnt := Natural (Count);
+ end if;
+
+ case Func is
+ when Iir_Predefined_Array_Sll
+ | Iir_Predefined_Array_Srl =>
+ declare
+ Enum_List : Iir_List;
+ begin
+ Enum_List := Get_Enumeration_Literal_List
+ (Get_Base_Type (Get_Element_Subtype (Get_Type (Left))));
+ E := Get_Nth_Element (Enum_List, 0);
+ end;
+ when Iir_Predefined_Array_Sla
+ | Iir_Predefined_Array_Sra =>
+ if Dir_Left then
+ E := Get_Nth_Element (Arr_List, Len - 1);
+ else
+ E := Get_Nth_Element (Arr_List, 0);
+ end if;
+ when Iir_Predefined_Array_Rol
+ | Iir_Predefined_Array_Ror =>
+ Cnt := Cnt mod Len;
+ if not Dir_Left then
+ Cnt := (Len - Cnt) mod Len;
+ end if;
+ end case;
+
+ Res_List := Create_Iir_List;
+
+ case Func is
+ when Iir_Predefined_Array_Sll
+ | Iir_Predefined_Array_Srl
+ | Iir_Predefined_Array_Sla
+ | Iir_Predefined_Array_Sra =>
+ if Dir_Left then
+ if Cnt < Len then
+ for I in Cnt .. Len - 1 loop
+ Append_Element
+ (Res_List, Get_Nth_Element (Arr_List, I));
+ end loop;
+ else
+ Cnt := Len;
+ end if;
+ for I in 0 .. Cnt - 1 loop
+ Append_Element (Res_List, E);
+ end loop;
+ else
+ if Cnt > Len then
+ Cnt := Len;
+ end if;
+ for I in 0 .. Cnt - 1 loop
+ Append_Element (Res_List, E);
+ end loop;
+ for I in Cnt .. Len - 1 loop
+ Append_Element
+ (Res_List, Get_Nth_Element (Arr_List, I - Cnt));
+ end loop;
+ end if;
+ when Iir_Predefined_Array_Rol
+ | Iir_Predefined_Array_Ror =>
+ for I in 1 .. Len loop
+ Append_Element
+ (Res_List, Get_Nth_Element (Arr_List, Cnt));
+ Cnt := Cnt + 1;
+ if Cnt = Len then
+ Cnt := 0;
+ end if;
+ end loop;
+ end case;
+ return Build_Simple_Aggregate (Res_List, Origin, Get_Type (Left));
+ end Eval_Shift_Operator;
+
+ -- Note: operands must be locally static.
+ function Eval_Concatenation
+ (Left, Right : Iir; Orig : Iir; Func : Iir_Predefined_Concat_Functions)
+ return Iir
+ is
+ Res_List : Iir_List;
+ L : Natural;
+ Res_Type : Iir;
+ Origin_Type : Iir;
+ Left_Aggr, Right_Aggr : Iir;
+ Left_List, Right_List : Iir_List;
+ Left_Len : Natural;
+ begin
+ Res_List := Create_Iir_List;
+ -- Do the concatenation.
+ -- Left:
+ case Func is
+ when Iir_Predefined_Element_Array_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ Append_Element (Res_List, Left);
+ Left_Len := 1;
+ when Iir_Predefined_Array_Element_Concat
+ | Iir_Predefined_Array_Array_Concat =>
+ Left_Aggr := Eval_String_Literal (Left);
+ Left_List := Get_Simple_Aggregate_List (Left_Aggr);
+ Left_Len := Get_Nbr_Elements (Left_List);
+ for I in 0 .. Left_Len - 1 loop
+ Append_Element (Res_List, Get_Nth_Element (Left_List, I));
+ end loop;
+ Free_Eval_String_Literal (Left_Aggr, Left);
+ end case;
+ -- Right:
+ case Func is
+ when Iir_Predefined_Array_Element_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ Append_Element (Res_List, Right);
+ when Iir_Predefined_Element_Array_Concat
+ | Iir_Predefined_Array_Array_Concat =>
+ Right_Aggr := Eval_String_Literal (Right);
+ Right_List := Get_Simple_Aggregate_List (Right_Aggr);
+ L := Get_Nbr_Elements (Right_List);
+ for I in 0 .. L - 1 loop
+ Append_Element (Res_List, Get_Nth_Element (Right_List, I));
+ end loop;
+ Free_Eval_String_Literal (Right_Aggr, Right);
+ end case;
+ L := Get_Nbr_Elements (Res_List);
+
+ -- Compute subtype...
+ Origin_Type := Get_Type (Orig);
+ Res_Type := Null_Iir;
+ if Func = Iir_Predefined_Array_Array_Concat
+ and then Left_Len = 0
+ then
+ if Flags.Vhdl_Std = Vhdl_87 then
+ -- LRM87 7.2.4
+ -- [...], unless the left operand is a null array, in which case
+ -- the result of the concatenation is the right operand.
+ Res_Type := Get_Type (Right);
+ else
+ -- LRM93 7.2.4
+ -- If both operands are null arrays, then the result of the
+ -- concatenation is the right operand.
+ if Get_Nbr_Elements (Right_List) = 0 then
+ Res_Type := Get_Type (Right);
+ end if;
+ end if;
+ end if;
+ if Res_Type = Null_Iir then
+ if Flags.Vhdl_Std = Vhdl_87
+ and then (Func = Iir_Predefined_Array_Array_Concat
+ or Func = Iir_Predefined_Array_Element_Concat)
+ then
+ -- LRM87 7.2.4
+ -- The left bound of the result is the left operand, [...]
+ --
+ -- LRM87 7.2.4
+ -- The direction of the result is the direction of the left
+ -- operand, [...]
+ declare
+ Left_Index : constant Iir :=
+ Get_Index_Type (Get_Type (Left), 0);
+ Left_Range : constant Iir :=
+ Get_Range_Constraint (Left_Index);
+ Ret_Type : constant Iir :=
+ Get_Return_Type (Get_Implementation (Orig));
+ A_Range : Iir;
+ Index_Type : Iir;
+ begin
+ A_Range := Create_Iir (Iir_Kind_Range_Expression);
+ Set_Type (A_Range, Get_Index_Type (Ret_Type, 0));
+ Set_Expr_Staticness (A_Range, Locally);
+ Set_Left_Limit (A_Range, Get_Left_Limit (Left_Range));
+ Set_Direction (A_Range, Get_Direction (Left_Range));
+ Location_Copy (A_Range, Orig);
+ Set_Right_Limit_By_Length (A_Range, Iir_Int64 (L));
+ Index_Type := Create_Range_Subtype_From_Type
+ (Left_Index, Get_Location (Orig));
+ Set_Range_Constraint (Index_Type, A_Range);
+ Res_Type := Create_Unidim_Array_From_Index
+ (Origin_Type, Index_Type, Orig);
+ end;
+ else
+ -- LRM93 7.2.4
+ -- Otherwise, the direction and bounds of the result are
+ -- determined as follows: let S be the index subtype of the base
+ -- type of the result. The direction of the result of the
+ -- concatenation is the direction of S, and the left bound of the
+ -- result is S'LEFT.
+ Res_Type := Create_Unidim_Array_By_Length
+ (Origin_Type, Iir_Int64 (L), Orig);
+ end if;
+ end if;
+ -- FIXME: this is not necessarily a string, it may be an aggregate if
+ -- element type is not a character type.
+ return Build_Simple_Aggregate (Res_List, Orig, Res_Type);
+ end Eval_Concatenation;
+
+ function Eval_Array_Equality (Left, Right : Iir) return Boolean
+ is
+ Left_Val, Right_Val : Iir;
+ L_List : Iir_List;
+ R_List : Iir_List;
+ N : Natural;
+ Res : Boolean;
+ begin
+ Left_Val := Eval_String_Literal (Left);
+ Right_Val := Eval_String_Literal (Right);
+
+ L_List := Get_Simple_Aggregate_List (Left_Val);
+ R_List := Get_Simple_Aggregate_List (Right_Val);
+ N := Get_Nbr_Elements (L_List);
+ if N /= Get_Nbr_Elements (R_List) then
+ -- Cannot be equal if not the same length.
+ Res := False;
+ else
+ Res := True;
+ for I in 0 .. N - 1 loop
+ -- FIXME: this is wrong: (eg: evaluated lit)
+ if Get_Nth_Element (L_List, I) /= Get_Nth_Element (R_List, I) then
+ Res := False;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ Free_Eval_Static_Expr (Left_Val, Left);
+ Free_Eval_Static_Expr (Right_Val, Right);
+
+ return Res;
+ end Eval_Array_Equality;
+
+ -- ORIG is either a dyadic operator or a function call.
+ function Eval_Dyadic_Operator (Orig : Iir; Imp : Iir; Left, Right : Iir)
+ return Iir
+ is
+ pragma Unsuppress (Overflow_Check);
+ Func : constant Iir_Predefined_Functions :=
+ Get_Implicit_Definition (Imp);
+ begin
+ if Get_Kind (Left) = Iir_Kind_Overflow_Literal
+ or else Get_Kind (Right) = Iir_Kind_Overflow_Literal
+ then
+ return Build_Overflow (Orig);
+ end if;
+
+ case Func is
+ when Iir_Predefined_Integer_Plus =>
+ return Build_Integer (Get_Value (Left) + Get_Value (Right), Orig);
+ when Iir_Predefined_Integer_Minus =>
+ return Build_Integer (Get_Value (Left) - Get_Value (Right), Orig);
+ when Iir_Predefined_Integer_Mul =>
+ return Build_Integer (Get_Value (Left) * Get_Value (Right), Orig);
+ when Iir_Predefined_Integer_Div =>
+ if Check_Integer_Division_By_Zero (Orig, Right) then
+ return Build_Integer
+ (Get_Value (Left) / Get_Value (Right), Orig);
+ else
+ return Build_Overflow (Orig);
+ end if;
+ when Iir_Predefined_Integer_Mod =>
+ if Check_Integer_Division_By_Zero (Orig, Right) then
+ return Build_Integer
+ (Get_Value (Left) mod Get_Value (Right), Orig);
+ else
+ return Build_Overflow (Orig);
+ end if;
+ when Iir_Predefined_Integer_Rem =>
+ if Check_Integer_Division_By_Zero (Orig, Right) then
+ return Build_Integer
+ (Get_Value (Left) rem Get_Value (Right), Orig);
+ else
+ return Build_Overflow (Orig);
+ end if;
+ when Iir_Predefined_Integer_Exp =>
+ return Build_Integer
+ (Get_Value (Left) ** Integer (Get_Value (Right)), Orig);
+
+ when Iir_Predefined_Integer_Equality =>
+ return Build_Boolean (Get_Value (Left) = Get_Value (Right));
+ when Iir_Predefined_Integer_Inequality =>
+ return Build_Boolean (Get_Value (Left) /= Get_Value (Right));
+ when Iir_Predefined_Integer_Greater_Equal =>
+ return Build_Boolean (Get_Value (Left) >= Get_Value (Right));
+ when Iir_Predefined_Integer_Greater =>
+ return Build_Boolean (Get_Value (Left) > Get_Value (Right));
+ when Iir_Predefined_Integer_Less_Equal =>
+ return Build_Boolean (Get_Value (Left) <= Get_Value (Right));
+ when Iir_Predefined_Integer_Less =>
+ return Build_Boolean (Get_Value (Left) < Get_Value (Right));
+
+ when Iir_Predefined_Integer_Minimum =>
+ if Get_Value (Left) < Get_Value (Right) then
+ return Left;
+ else
+ return Right;
+ end if;
+ when Iir_Predefined_Integer_Maximum =>
+ if Get_Value (Left) > Get_Value (Right) then
+ return Left;
+ else
+ return Right;
+ end if;
+
+ when Iir_Predefined_Floating_Equality =>
+ return Build_Boolean (Get_Fp_Value (Left) = Get_Fp_Value (Right));
+ when Iir_Predefined_Floating_Inequality =>
+ return Build_Boolean (Get_Fp_Value (Left) /= Get_Fp_Value (Right));
+ when Iir_Predefined_Floating_Greater =>
+ return Build_Boolean (Get_Fp_Value (Left) > Get_Fp_Value (Right));
+ when Iir_Predefined_Floating_Greater_Equal =>
+ return Build_Boolean (Get_Fp_Value (Left) >= Get_Fp_Value (Right));
+ when Iir_Predefined_Floating_Less =>
+ return Build_Boolean (Get_Fp_Value (Left) < Get_Fp_Value (Right));
+ when Iir_Predefined_Floating_Less_Equal =>
+ return Build_Boolean (Get_Fp_Value (Left) <= Get_Fp_Value (Right));
+
+ when Iir_Predefined_Floating_Minus =>
+ return Build_Floating
+ (Get_Fp_Value (Left) - Get_Fp_Value (Right), Orig);
+ when Iir_Predefined_Floating_Plus =>
+ return Build_Floating
+ (Get_Fp_Value (Left) + Get_Fp_Value (Right), Orig);
+ when Iir_Predefined_Floating_Mul =>
+ return Build_Floating
+ (Get_Fp_Value (Left) * Get_Fp_Value (Right), Orig);
+ when Iir_Predefined_Floating_Div =>
+ if Get_Fp_Value (Right) = 0.0 then
+ Warning_Msg_Sem ("right operand of division is 0", Orig);
+ return Build_Overflow (Orig);
+ else
+ return Build_Floating
+ (Get_Fp_Value (Left) / Get_Fp_Value (Right), Orig);
+ end if;
+ when Iir_Predefined_Floating_Exp =>
+ declare
+ Exp : Iir_Int64;
+ Res : Iir_Fp64;
+ Val : Iir_Fp64;
+ begin
+ Res := 1.0;
+ Val := Get_Fp_Value (Left);
+ Exp := abs Get_Value (Right);
+ while Exp /= 0 loop
+ if Exp mod 2 = 1 then
+ Res := Res * Val;
+ end if;
+ Exp := Exp / 2;
+ Val := Val * Val;
+ end loop;
+ if Get_Value (Right) < 0 then
+ Res := 1.0 / Res;
+ end if;
+ return Build_Floating (Res, Orig);
+ end;
+
+ when Iir_Predefined_Floating_Minimum =>
+ if Get_Fp_Value (Left) < Get_Fp_Value (Right) then
+ return Left;
+ else
+ return Right;
+ end if;
+ when Iir_Predefined_Floating_Maximum =>
+ if Get_Fp_Value (Left) > Get_Fp_Value (Right) then
+ return Left;
+ else
+ return Right;
+ end if;
+
+ when Iir_Predefined_Physical_Equality =>
+ return Build_Boolean
+ (Get_Physical_Value (Left) = Get_Physical_Value (Right));
+ when Iir_Predefined_Physical_Inequality =>
+ return Build_Boolean
+ (Get_Physical_Value (Left) /= Get_Physical_Value (Right));
+ when Iir_Predefined_Physical_Greater_Equal =>
+ return Build_Boolean
+ (Get_Physical_Value (Left) >= Get_Physical_Value (Right));
+ when Iir_Predefined_Physical_Greater =>
+ return Build_Boolean
+ (Get_Physical_Value (Left) > Get_Physical_Value (Right));
+ when Iir_Predefined_Physical_Less_Equal =>
+ return Build_Boolean
+ (Get_Physical_Value (Left) <= Get_Physical_Value (Right));
+ when Iir_Predefined_Physical_Less =>
+ return Build_Boolean
+ (Get_Physical_Value (Left) < Get_Physical_Value (Right));
+
+ when Iir_Predefined_Physical_Physical_Div =>
+ return Build_Integer
+ (Get_Physical_Value (Left) / Get_Physical_Value (Right), Orig);
+ when Iir_Predefined_Physical_Integer_Div =>
+ return Build_Physical
+ (Get_Physical_Value (Left) / Get_Value (Right), Orig);
+ when Iir_Predefined_Physical_Minus =>
+ return Build_Physical
+ (Get_Physical_Value (Left) - Get_Physical_Value (Right), Orig);
+ when Iir_Predefined_Physical_Plus =>
+ return Build_Physical
+ (Get_Physical_Value (Left) + Get_Physical_Value (Right), Orig);
+ when Iir_Predefined_Integer_Physical_Mul =>
+ return Build_Physical
+ (Get_Value (Left) * Get_Physical_Value (Right), Orig);
+ when Iir_Predefined_Physical_Integer_Mul =>
+ return Build_Physical
+ (Get_Physical_Value (Left) * Get_Value (Right), Orig);
+ when Iir_Predefined_Real_Physical_Mul =>
+ -- FIXME: overflow??
+ return Build_Physical
+ (Iir_Int64 (Get_Fp_Value (Left)
+ * Iir_Fp64 (Get_Physical_Value (Right))), Orig);
+ when Iir_Predefined_Physical_Real_Mul =>
+ -- FIXME: overflow??
+ return Build_Physical
+ (Iir_Int64 (Iir_Fp64 (Get_Physical_Value (Left))
+ * Get_Fp_Value (Right)), Orig);
+ when Iir_Predefined_Physical_Real_Div =>
+ -- FIXME: overflow??
+ return Build_Physical
+ (Iir_Int64 (Iir_Fp64 (Get_Physical_Value (Left))
+ / Get_Fp_Value (Right)), Orig);
+
+ when Iir_Predefined_Physical_Minimum =>
+ return Build_Physical (Iir_Int64'Min (Get_Physical_Value (Left),
+ Get_Physical_Value (Right)),
+ Orig);
+ when Iir_Predefined_Physical_Maximum =>
+ return Build_Physical (Iir_Int64'Max (Get_Physical_Value (Left),
+ Get_Physical_Value (Right)),
+ Orig);
+
+ when Iir_Predefined_Element_Array_Concat
+ | Iir_Predefined_Array_Element_Concat
+ | Iir_Predefined_Array_Array_Concat
+ | Iir_Predefined_Element_Element_Concat =>
+ return Eval_Concatenation (Left, Right, Orig, Func);
+
+ when Iir_Predefined_Enum_Equality
+ | Iir_Predefined_Bit_Match_Equality =>
+ return Build_Enumeration
+ (Get_Enum_Pos (Left) = Get_Enum_Pos (Right), Orig);
+ when Iir_Predefined_Enum_Inequality
+ | Iir_Predefined_Bit_Match_Inequality =>
+ return Build_Enumeration
+ (Get_Enum_Pos (Left) /= Get_Enum_Pos (Right), Orig);
+ when Iir_Predefined_Enum_Greater_Equal
+ | Iir_Predefined_Bit_Match_Greater_Equal =>
+ return Build_Enumeration
+ (Get_Enum_Pos (Left) >= Get_Enum_Pos (Right), Orig);
+ when Iir_Predefined_Enum_Greater
+ | Iir_Predefined_Bit_Match_Greater =>
+ return Build_Enumeration
+ (Get_Enum_Pos (Left) > Get_Enum_Pos (Right), Orig);
+ when Iir_Predefined_Enum_Less_Equal
+ | Iir_Predefined_Bit_Match_Less_Equal =>
+ return Build_Enumeration
+ (Get_Enum_Pos (Left) <= Get_Enum_Pos (Right), Orig);
+ when Iir_Predefined_Enum_Less
+ | Iir_Predefined_Bit_Match_Less =>
+ return Build_Enumeration
+ (Get_Enum_Pos (Left) < Get_Enum_Pos (Right), Orig);
+
+ when Iir_Predefined_Enum_Minimum =>
+ if Get_Enum_Pos (Left) < Get_Enum_Pos (Right) then
+ return Left;
+ else
+ return Right;
+ end if;
+ when Iir_Predefined_Enum_Maximum =>
+ if Get_Enum_Pos (Left) > Get_Enum_Pos (Right) then
+ return Left;
+ else
+ return Right;
+ end if;
+
+ when Iir_Predefined_Boolean_And
+ | Iir_Predefined_Bit_And =>
+ return Build_Enumeration
+ (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1, Orig);
+ when Iir_Predefined_Boolean_Nand
+ | Iir_Predefined_Bit_Nand =>
+ return Build_Enumeration
+ (not (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1),
+ Orig);
+ when Iir_Predefined_Boolean_Or
+ | Iir_Predefined_Bit_Or =>
+ return Build_Enumeration
+ (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1, Orig);
+ when Iir_Predefined_Boolean_Nor
+ | Iir_Predefined_Bit_Nor =>
+ return Build_Enumeration
+ (not (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1),
+ Orig);
+ when Iir_Predefined_Boolean_Xor
+ | Iir_Predefined_Bit_Xor =>
+ return Build_Enumeration
+ (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1, Orig);
+ when Iir_Predefined_Boolean_Xnor
+ | Iir_Predefined_Bit_Xnor =>
+ return Build_Enumeration
+ (not (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1),
+ Orig);
+
+ when Iir_Predefined_Dyadic_TF_Array_Functions =>
+ -- FIXME: only for bit ?
+ return Eval_Dyadic_Bit_Array_Operator (Orig, Left, Right, Func);
+
+ when Iir_Predefined_Universal_R_I_Mul =>
+ return Build_Floating
+ (Get_Fp_Value (Left) * Iir_Fp64 (Get_Value (Right)), Orig);
+ when Iir_Predefined_Universal_I_R_Mul =>
+ return Build_Floating
+ (Iir_Fp64 (Get_Value (Left)) * Get_Fp_Value (Right), Orig);
+ when Iir_Predefined_Universal_R_I_Div =>
+ return Build_Floating
+ (Get_Fp_Value (Left) / Iir_Fp64 (Get_Value (Right)), Orig);
+
+ when Iir_Predefined_Array_Equality =>
+ return Build_Boolean (Eval_Array_Equality (Left, Right));
+
+ when Iir_Predefined_Array_Inequality =>
+ return Build_Boolean (not Eval_Array_Equality (Left, Right));
+
+ when Iir_Predefined_Array_Sll
+ | Iir_Predefined_Array_Srl
+ | Iir_Predefined_Array_Sla
+ | Iir_Predefined_Array_Sra
+ | Iir_Predefined_Array_Rol
+ | Iir_Predefined_Array_Ror =>
+ declare
+ Left_Aggr : Iir;
+ Res : Iir;
+ begin
+ Left_Aggr := Eval_String_Literal (Left);
+ Res := Eval_Shift_Operator (Left_Aggr, Right, Orig, Func);
+ Free_Eval_String_Literal (Left_Aggr, Left);
+ return Res;
+ end;
+
+ when Iir_Predefined_Array_Less
+ | Iir_Predefined_Array_Less_Equal
+ | Iir_Predefined_Array_Greater
+ | Iir_Predefined_Array_Greater_Equal =>
+ -- FIXME: todo.
+ Error_Internal (Orig, "eval_dyadic_operator: " &
+ Iir_Predefined_Functions'Image (Func));
+
+ when Iir_Predefined_Boolean_Not
+ | Iir_Predefined_Boolean_Rising_Edge
+ | Iir_Predefined_Boolean_Falling_Edge
+ | Iir_Predefined_Bit_Not
+ | Iir_Predefined_Bit_Rising_Edge
+ | Iir_Predefined_Bit_Falling_Edge
+ | Iir_Predefined_Integer_Absolute
+ | Iir_Predefined_Integer_Identity
+ | Iir_Predefined_Integer_Negation
+ | Iir_Predefined_Floating_Absolute
+ | Iir_Predefined_Floating_Negation
+ | Iir_Predefined_Floating_Identity
+ | Iir_Predefined_Physical_Absolute
+ | Iir_Predefined_Physical_Identity
+ | Iir_Predefined_Physical_Negation
+ | Iir_Predefined_Error
+ | Iir_Predefined_Record_Equality
+ | Iir_Predefined_Record_Inequality
+ | Iir_Predefined_Access_Equality
+ | Iir_Predefined_Access_Inequality
+ | Iir_Predefined_TF_Array_Not
+ | Iir_Predefined_Now_Function
+ | Iir_Predefined_Deallocate
+ | Iir_Predefined_Write
+ | Iir_Predefined_Read
+ | Iir_Predefined_Read_Length
+ | Iir_Predefined_Flush
+ | Iir_Predefined_File_Open
+ | Iir_Predefined_File_Open_Status
+ | Iir_Predefined_File_Close
+ | Iir_Predefined_Endfile
+ | Iir_Predefined_Attribute_Image
+ | Iir_Predefined_Attribute_Value
+ | Iir_Predefined_Attribute_Pos
+ | Iir_Predefined_Attribute_Val
+ | Iir_Predefined_Attribute_Succ
+ | Iir_Predefined_Attribute_Pred
+ | Iir_Predefined_Attribute_Rightof
+ | Iir_Predefined_Attribute_Leftof
+ | Iir_Predefined_Attribute_Left
+ | Iir_Predefined_Attribute_Right
+ | Iir_Predefined_Attribute_Event
+ | Iir_Predefined_Attribute_Active
+ | Iir_Predefined_Attribute_Last_Value
+ | Iir_Predefined_Attribute_Last_Event
+ | Iir_Predefined_Attribute_Last_Active
+ | Iir_Predefined_Attribute_Driving
+ | Iir_Predefined_Attribute_Driving_Value
+ | Iir_Predefined_Array_Char_To_String
+ | Iir_Predefined_Bit_Vector_To_Ostring
+ | Iir_Predefined_Bit_Vector_To_Hstring =>
+ -- Not binary or never locally static.
+ Error_Internal (Orig, "eval_dyadic_operator: " &
+ Iir_Predefined_Functions'Image (Func));
+
+ when Iir_Predefined_Bit_Condition =>
+ raise Internal_Error;
+
+ when Iir_Predefined_Array_Minimum
+ | Iir_Predefined_Array_Maximum
+ | Iir_Predefined_Vector_Minimum
+ | Iir_Predefined_Vector_Maximum =>
+ raise Internal_Error;
+
+ when Iir_Predefined_Std_Ulogic_Match_Equality
+ | Iir_Predefined_Std_Ulogic_Match_Inequality
+ | Iir_Predefined_Std_Ulogic_Match_Less
+ | Iir_Predefined_Std_Ulogic_Match_Less_Equal
+ | Iir_Predefined_Std_Ulogic_Match_Greater
+ | Iir_Predefined_Std_Ulogic_Match_Greater_Equal =>
+ -- TODO
+ raise Internal_Error;
+
+ when Iir_Predefined_Enum_To_String
+ | Iir_Predefined_Integer_To_String
+ | Iir_Predefined_Floating_To_String
+ | Iir_Predefined_Real_To_String_Digits
+ | Iir_Predefined_Real_To_String_Format
+ | Iir_Predefined_Physical_To_String
+ | Iir_Predefined_Time_To_String_Unit =>
+ -- TODO
+ raise Internal_Error;
+
+ when Iir_Predefined_TF_Array_Element_And
+ | Iir_Predefined_TF_Element_Array_And
+ | Iir_Predefined_TF_Array_Element_Or
+ | Iir_Predefined_TF_Element_Array_Or
+ | Iir_Predefined_TF_Array_Element_Nand
+ | Iir_Predefined_TF_Element_Array_Nand
+ | Iir_Predefined_TF_Array_Element_Nor
+ | Iir_Predefined_TF_Element_Array_Nor
+ | Iir_Predefined_TF_Array_Element_Xor
+ | Iir_Predefined_TF_Element_Array_Xor
+ | Iir_Predefined_TF_Array_Element_Xnor
+ | Iir_Predefined_TF_Element_Array_Xnor =>
+ -- TODO
+ raise Internal_Error;
+
+ when Iir_Predefined_TF_Reduction_And
+ | Iir_Predefined_TF_Reduction_Or
+ | Iir_Predefined_TF_Reduction_Nand
+ | Iir_Predefined_TF_Reduction_Nor
+ | Iir_Predefined_TF_Reduction_Xor
+ | Iir_Predefined_TF_Reduction_Xnor
+ | Iir_Predefined_TF_Reduction_Not =>
+ -- TODO
+ raise Internal_Error;
+
+ when Iir_Predefined_Bit_Array_Match_Equality
+ | Iir_Predefined_Bit_Array_Match_Inequality
+ | Iir_Predefined_Std_Ulogic_Array_Match_Equality
+ | Iir_Predefined_Std_Ulogic_Array_Match_Inequality =>
+ -- TODO
+ raise Internal_Error;
+ end case;
+ exception
+ when Constraint_Error =>
+ Warning_Msg_Sem ("arithmetic overflow in static expression", Orig);
+ return Build_Overflow (Orig);
+ end Eval_Dyadic_Operator;
+
+ -- Evaluate any array attribute, return the type for the prefix.
+ function Eval_Array_Attribute (Attr : Iir) return Iir
+ is
+ Prefix : Iir;
+ Prefix_Type : Iir;
+ begin
+ Prefix := Get_Prefix (Attr);
+ case Get_Kind (Prefix) is
+ when Iir_Kinds_Object_Declaration -- FIXME: remove
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Implicit_Dereference =>
+ Prefix_Type := Get_Type (Prefix);
+ when Iir_Kind_Attribute_Value =>
+ -- The type of the attribute declaration may be unconstrained.
+ Prefix_Type := Get_Type
+ (Get_Expression (Get_Attribute_Specification (Prefix)));
+ when Iir_Kinds_Subtype_Definition =>
+ Prefix_Type := Prefix;
+ when Iir_Kinds_Denoting_Name =>
+ Prefix_Type := Get_Type (Prefix);
+ when others =>
+ Error_Kind ("eval_array_attribute", Prefix);
+ end case;
+ if Get_Kind (Prefix_Type) /= Iir_Kind_Array_Subtype_Definition then
+ Error_Kind ("eval_array_attribute(2)", Prefix_Type);
+ end if;
+ return Get_Nth_Element (Get_Index_Subtype_List (Prefix_Type),
+ Natural (Get_Value (Get_Parameter (Attr)) - 1));
+ end Eval_Array_Attribute;
+
+ function Eval_Integer_Image (Val : Iir_Int64; Orig : Iir) return Iir
+ is
+ use Str_Table;
+ Img : String (1 .. 24); -- 23 is enough, 24 is rounded.
+ L : Natural;
+ V : Iir_Int64;
+ Id : String_Id;
+ begin
+ V := Val;
+ L := Img'Last;
+ loop
+ Img (L) := Character'Val (Character'Pos ('0') + abs (V rem 10));
+ V := V / 10;
+ L := L - 1;
+ exit when V = 0;
+ end loop;
+ if Val < 0 then
+ Img (L) := '-';
+ L := L - 1;
+ end if;
+ Id := Start;
+ for I in L + 1 .. Img'Last loop
+ Append (Img (I));
+ end loop;
+ Finish;
+ return Build_String (Id, Int32 (Img'Last - L), Orig);
+ end Eval_Integer_Image;
+
+ function Eval_Floating_Image (Val : Iir_Fp64; Orig : Iir) return Iir
+ is
+ use Str_Table;
+ Id : String_Id;
+
+ -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1)
+ -- + exp_digits (4) -> 24.
+ Str : String (1 .. 25);
+ P : Natural;
+ V : Iir_Fp64;
+ Vd : Iir_Fp64;
+ Exp : Integer;
+ D : Integer;
+ B : Boolean;
+
+ Res : Iir;
+ begin
+ -- Handle sign.
+ if Val < 0.0 then
+ Str (1) := '-';
+ P := 1;
+ V := -Val;
+ else
+ P := 0;
+ V := Val;
+ end if;
+
+ -- Compute the mantissa.
+ -- FIXME: should do a dichotomy.
+ if V = 0.0 then
+ Exp := 0;
+ elsif V < 1.0 then
+ Exp := -1;
+ while V * (10.0 ** (-Exp)) < 1.0 loop
+ Exp := Exp - 1;
+ end loop;
+ else
+ Exp := 0;
+ while V / (10.0 ** Exp) >= 10.0 loop
+ Exp := Exp + 1;
+ end loop;
+ end if;
+
+ -- Normalize VAL: in [0; 10[
+ if Exp >= 0 then
+ V := V / (10.0 ** Exp);
+ else
+ V := V * 10.0 ** (-Exp);
+ end if;
+
+ for I in 0 .. 15 loop
+ Vd := Iir_Fp64'Truncation (V);
+ P := P + 1;
+ Str (P) := Character'Val (48 + Integer (Vd));
+ V := (V - Vd) * 10.0;
+
+ if I = 0 then
+ P := P + 1;
+ Str (P) := '.';
+ end if;
+ exit when I > 0 and V < 10.0 ** (I + 1 - 15);
+ end loop;
+
+ if Exp /= 0 then
+ -- LRM93 14.3
+ -- if the exponent is present, the `e' is written as a lower case
+ -- character.
+ P := P + 1;
+ Str (P) := 'e';
+
+ if Exp < 0 then
+ P := P + 1;
+ Str (P) := '-';
+ 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
+ P := P + 1;
+ Str (P) := Character'Val (48 + D);
+ B := True;
+ end if;
+ Exp := (Exp - D * 10000) * 10;
+ end loop;
+ end if;
+
+ Id := Start;
+ for I in 1 .. P loop
+ Append (Str (I));
+ end loop;
+ Finish;
+ Res := Build_String (Id, Int32 (P), Orig);
+ -- FIXME: this is not correct since the type is *not* constrained.
+ Set_Type (Res, Create_Unidim_Array_By_Length
+ (Get_Type (Orig), Iir_Int64 (P), Orig));
+ return Res;
+ end Eval_Floating_Image;
+
+ function Eval_Enumeration_Image (Enum, Expr : Iir) return Iir
+ is
+ Name : constant String := Image_Identifier (Enum);
+ Image_Id : constant String_Id := Str_Table.Start;
+ begin
+ for i in Name'range loop
+ Str_Table.Append(Name(i));
+ end loop;
+ Str_Table.Finish;
+ return Build_String (Image_Id, Nat32(Name'Length), Expr);
+ end Eval_Enumeration_Image;
+
+ function Build_Enumeration_Value (Val : String; Enum, Expr : Iir) return Iir
+ is
+ Value : String (Val'range);
+ List : constant Iir_List := Get_Enumeration_Literal_List (Enum);
+ begin
+ for I in Val'range loop
+ Value (I) := Ada.Characters.Handling.To_Lower (Val (I));
+ end loop;
+ for I in 0 .. Get_Nbr_Elements (List) - 1 loop
+ if Value = Image_Identifier (Get_Nth_Element (List, I)) then
+ return Build_Enumeration (Iir_Index32 (I), Expr);
+ end if;
+ end loop;
+ Warning_Msg_Sem ("value """ & Value & """ not in enumeration", Expr);
+ return Build_Overflow (Expr);
+ end Build_Enumeration_Value;
+
+ function Eval_Physical_Image (Phys, Expr: Iir) return Iir
+ is
+ -- Reduces to the base unit (e.g. femtoseconds).
+ Value : constant String := Iir_Int64'Image (Get_Physical_Value (Phys));
+ Unit : constant Iir :=
+ Get_Primary_Unit (Get_Base_Type (Get_Type (Phys)));
+ UnitName : constant String := Image_Identifier (Unit);
+ Image_Id : constant String_Id := Str_Table.Start;
+ Length : Nat32 := Value'Length + UnitName'Length + 1;
+ begin
+ for I in Value'range loop
+ -- Suppress the Ada +ve integer'image leading space
+ if I > Value'first or else Value (I) /= ' ' then
+ Str_Table.Append (Value (I));
+ else
+ Length := Length - 1;
+ end if;
+ end loop;
+ Str_Table.Append (' ');
+ for I in UnitName'range loop
+ Str_Table.Append (UnitName (I));
+ end loop;
+ Str_Table.Finish;
+
+ return Build_String (Image_Id, Length, Expr);
+ end Eval_Physical_Image;
+
+ function Build_Physical_Value (Val: String; Phys_Type, Expr: Iir) return Iir
+ is
+ function White (C : in Character) return Boolean is
+ NBSP : constant Character := Character'Val (160);
+ HT : constant Character := Character'Val (9);
+ begin
+ return C = ' ' or C = NBSP or C = HT;
+ end White;
+
+ UnitName : String (Val'range);
+ Mult : Iir_Int64;
+ Sep : Natural;
+ Found_Unit : Boolean := false;
+ Found_Real : Boolean := false;
+ Unit : Iir := Get_Primary_Unit (Phys_Type);
+ begin
+ -- Separate string into numeric value and make lowercase unit.
+ for I in reverse Val'range loop
+ UnitName (I) := Ada.Characters.Handling.To_Lower (Val (I));
+ if White (Val (I)) and Found_Unit then
+ Sep := I;
+ exit;
+ else
+ Found_Unit := true;
+ end if;
+ end loop;
+
+ -- Unit name is UnitName(Sep+1..Unit'Last)
+ for I in Val'First .. Sep loop
+ if Val (I) = '.' then
+ Found_Real := true;
+ end if;
+ end loop;
+
+ -- Chain down the units looking for matching one
+ Unit := Get_Primary_Unit (Phys_Type);
+ while Unit /= Null_Iir loop
+ exit when (UnitName (Sep + 1 .. UnitName'Last)
+ = Image_Identifier (Unit));
+ Unit := Get_Chain (Unit);
+ end loop;
+ if Unit = Null_Iir then
+ Warning_Msg_Sem ("Unit """ & UnitName (Sep + 1 .. UnitName'Last)
+ & """ not in physical type", Expr);
+ return Build_Overflow (Expr);
+ end if;
+
+ Mult := Get_Value (Get_Physical_Unit_Value (Unit));
+ if Found_Real then
+ return Build_Physical
+ (Iir_Int64 (Iir_Fp64'Value (Val (Val'First .. Sep))
+ * Iir_Fp64 (Mult)),
+ Expr);
+ else
+ return Build_Physical
+ (Iir_Int64'Value (Val (Val'First .. Sep)) * Mult, Expr);
+ end if;
+ end Build_Physical_Value;
+
+ function Eval_Incdec (Expr : Iir; N : Iir_Int64; Origin : Iir) return Iir
+ is
+ P : Iir_Int64;
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Integer_Literal =>
+ return Build_Integer (Get_Value (Expr) + N, Origin);
+ when Iir_Kind_Enumeration_Literal =>
+ P := Iir_Int64 (Get_Enum_Pos (Expr)) + N;
+ if P < 0 then
+ Warning_Msg_Sem ("static constant violates bounds", Expr);
+ return Build_Overflow (Origin);
+ else
+ return Build_Enumeration (Iir_Index32 (P), Origin);
+ end if;
+ when Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Unit_Declaration =>
+ return Build_Physical (Get_Physical_Value (Expr) + N, Origin);
+ when others =>
+ Error_Kind ("eval_incdec", Expr);
+ end case;
+ end Eval_Incdec;
+
+ function Convert_Range (Rng : Iir; Res_Type : Iir; Loc : Iir) return Iir
+ is
+ Res_Btype : Iir;
+
+ function Create_Bound (Val : Iir) return Iir
+ is
+ R : Iir;
+ begin
+ R := Create_Iir (Iir_Kind_Integer_Literal);
+ Location_Copy (R, Loc);
+ Set_Value (R, Get_Value (Val));
+ Set_Type (R, Res_Btype);
+ Set_Expr_Staticness (R, Locally);
+ return R;
+ end Create_Bound;
+
+ Res : Iir;
+ begin
+ Res_Btype := Get_Base_Type (Res_Type);
+ Res := Create_Iir (Iir_Kind_Range_Expression);
+ Location_Copy (Res, Loc);
+ Set_Type (Res, Res_Btype);
+ Set_Left_Limit (Res, Create_Bound (Get_Left_Limit (Rng)));
+ Set_Right_Limit (Res, Create_Bound (Get_Right_Limit (Rng)));
+ Set_Direction (Res, Get_Direction (Rng));
+ Set_Expr_Staticness (Res, Locally);
+ return Res;
+ end Convert_Range;
+
+ function Eval_Array_Type_Conversion (Conv : Iir; Val : Iir) return Iir
+ is
+ Conv_Type : constant Iir := Get_Type (Conv);
+ Val_Type : constant Iir := Get_Type (Val);
+ Conv_Index_Type : constant Iir := Get_Index_Type (Conv_Type, 0);
+ Val_Index_Type : constant Iir := Get_Index_Type (Val_Type, 0);
+ Index_Type : Iir;
+ Res_Type : Iir;
+ Res : Iir;
+ Rng : Iir;
+ begin
+ -- The expression is either a simple aggregate or a (bit) string.
+ Res := Build_Constant (Val, Conv);
+ case Get_Kind (Conv_Type) is
+ when Iir_Kind_Array_Subtype_Definition =>
+ Set_Type (Res, Conv_Type);
+ if Eval_Discrete_Type_Length (Conv_Index_Type)
+ /= Eval_Discrete_Type_Length (Val_Index_Type)
+ then
+ Warning_Msg_Sem
+ ("non matching length in type conversion", Conv);
+ return Build_Overflow (Conv);
+ end if;
+ return Res;
+ when Iir_Kind_Array_Type_Definition =>
+ if Get_Base_Type (Conv_Index_Type) = Get_Base_Type (Val_Index_Type)
+ then
+ Index_Type := Val_Index_Type;
+ else
+ -- Convert the index range.
+ -- It is an integer type.
+ Rng := Convert_Range (Get_Range_Constraint (Val_Index_Type),
+ Conv_Index_Type, Conv);
+ Index_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition);
+ Location_Copy (Index_Type, Conv);
+ Set_Range_Constraint (Index_Type, Rng);
+ Set_Base_Type (Index_Type, Get_Base_Type (Conv_Index_Type));
+ Set_Type_Staticness (Index_Type, Locally);
+ end if;
+ Res_Type := Create_Unidim_Array_From_Index
+ (Get_Base_Type (Conv_Type), Index_Type, Conv);
+ Set_Type (Res, Res_Type);
+ Set_Type_Conversion_Subtype (Conv, Res_Type);
+ return Res;
+ when others =>
+ Error_Kind ("eval_array_type_conversion", Conv_Type);
+ end case;
+ end Eval_Array_Type_Conversion;
+
+ function Eval_Type_Conversion (Expr : Iir) return Iir
+ is
+ Val : Iir;
+ Val_Type : Iir;
+ Conv_Type : Iir;
+ begin
+ Val := Eval_Static_Expr (Get_Expression (Expr));
+ Val_Type := Get_Base_Type (Get_Type (Val));
+ Conv_Type := Get_Base_Type (Get_Type (Expr));
+ if Conv_Type = Val_Type then
+ return Build_Constant (Val, Expr);
+ end if;
+ case Get_Kind (Conv_Type) is
+ when Iir_Kind_Integer_Type_Definition =>
+ case Get_Kind (Val_Type) is
+ when Iir_Kind_Integer_Type_Definition =>
+ return Build_Integer (Get_Value (Val), Expr);
+ when Iir_Kind_Floating_Type_Definition =>
+ return Build_Integer (Iir_Int64 (Get_Fp_Value (Val)), Expr);
+ when others =>
+ Error_Kind ("eval_type_conversion(1)", Val_Type);
+ end case;
+ when Iir_Kind_Floating_Type_Definition =>
+ case Get_Kind (Val_Type) is
+ when Iir_Kind_Integer_Type_Definition =>
+ return Build_Floating (Iir_Fp64 (Get_Value (Val)), Expr);
+ when Iir_Kind_Floating_Type_Definition =>
+ return Build_Floating (Get_Fp_Value (Val), Expr);
+ when others =>
+ Error_Kind ("eval_type_conversion(2)", Val_Type);
+ end case;
+ when Iir_Kind_Array_Type_Definition =>
+ return Eval_Array_Type_Conversion (Expr, Val);
+ when others =>
+ Error_Kind ("eval_type_conversion(3)", Conv_Type);
+ end case;
+ end Eval_Type_Conversion;
+
+ function Eval_Physical_Literal (Expr : Iir) return Iir
+ is
+ Val : Iir;
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Physical_Fp_Literal =>
+ Val := Expr;
+ when Iir_Kind_Physical_Int_Literal =>
+ if Get_Named_Entity (Get_Unit_Name (Expr))
+ = Get_Primary_Unit (Get_Base_Type (Get_Type (Expr)))
+ then
+ return Expr;
+ else
+ Val := Expr;
+ end if;
+ when Iir_Kind_Unit_Declaration =>
+ Val := Expr;
+ when Iir_Kinds_Denoting_Name =>
+ Val := Get_Named_Entity (Expr);
+ pragma Assert (Get_Kind (Val) = Iir_Kind_Unit_Declaration);
+ when others =>
+ Error_Kind ("eval_physical_literal", Expr);
+ end case;
+ return Build_Physical (Get_Physical_Value (Val), Expr);
+ end Eval_Physical_Literal;
+
+ function Eval_Static_Expr (Expr: Iir) return Iir
+ is
+ Res : Iir;
+ Val : Iir;
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kinds_Denoting_Name =>
+ return Eval_Static_Expr (Get_Named_Entity (Expr));
+
+ when Iir_Kind_Integer_Literal
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Floating_Point_Literal
+ | Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal
+ | Iir_Kind_Overflow_Literal
+ | Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal =>
+ return Expr;
+ when Iir_Kind_Constant_Declaration =>
+ Val := Eval_Static_Expr (Get_Default_Value (Expr));
+ -- Type of the expression should be type of the constant
+ -- declaration at least in case of array subtype.
+ -- If the constant is declared as an unconstrained array, get type
+ -- from the default value.
+ -- FIXME: handle this during semantisation of the declaration:
+ -- add an implicit subtype conversion node ?
+ -- FIXME: this currently creates a node at each evalation.
+ if Get_Kind (Get_Type (Val)) = Iir_Kind_Array_Type_Definition then
+ Res := Build_Constant (Val, Expr);
+ Set_Type (Res, Get_Type (Val));
+ return Res;
+ else
+ return Val;
+ end if;
+ when Iir_Kind_Object_Alias_Declaration =>
+ return Eval_Static_Expr (Get_Name (Expr));
+ when Iir_Kind_Unit_Declaration =>
+ return Get_Physical_Unit_Value (Expr);
+ when Iir_Kind_Simple_Aggregate =>
+ return Expr;
+
+ when Iir_Kind_Parenthesis_Expression =>
+ return Eval_Static_Expr (Get_Expression (Expr));
+ when Iir_Kind_Qualified_Expression =>
+ return Eval_Static_Expr (Get_Expression (Expr));
+ when Iir_Kind_Type_Conversion =>
+ return Eval_Type_Conversion (Expr);
+
+ when Iir_Kinds_Monadic_Operator =>
+ declare
+ Operand : Iir;
+ begin
+ Operand := Eval_Static_Expr (Get_Operand (Expr));
+ return Eval_Monadic_Operator (Expr, Operand);
+ end;
+ when Iir_Kinds_Dyadic_Operator =>
+ declare
+ Left : constant Iir := Get_Left (Expr);
+ Right : constant Iir := Get_Right (Expr);
+ Left_Val, Right_Val : Iir;
+ Res : Iir;
+ begin
+ Left_Val := Eval_Static_Expr (Left);
+ Right_Val := Eval_Static_Expr (Right);
+
+ Res := Eval_Dyadic_Operator
+ (Expr, Get_Implementation (Expr), Left_Val, Right_Val);
+
+ Free_Eval_Static_Expr (Left_Val, Left);
+ Free_Eval_Static_Expr (Right_Val, Right);
+
+ return Res;
+ end;
+
+ when Iir_Kind_Attribute_Name =>
+ -- An attribute name designates an attribute value.
+ declare
+ Attr_Val : constant Iir := Get_Named_Entity (Expr);
+ Attr_Expr : constant Iir :=
+ Get_Expression (Get_Attribute_Specification (Attr_Val));
+ Val : Iir;
+ begin
+ Val := Eval_Static_Expr (Attr_Expr);
+ -- FIXME: see constant_declaration.
+ -- Currently, this avoids weird nodes, such as a string literal
+ -- whose type is an unconstrained array type.
+ Res := Build_Constant (Val, Expr);
+ Set_Type (Res, Get_Type (Val));
+ return Res;
+ end;
+
+ when Iir_Kind_Pos_Attribute =>
+ declare
+ Param : constant Iir := Get_Parameter (Expr);
+ Val : Iir;
+ Res : Iir;
+ begin
+ Val := Eval_Static_Expr (Param);
+ -- FIXME: check bounds, handle overflow.
+ Res := Build_Integer (Eval_Pos (Val), Expr);
+ Free_Eval_Static_Expr (Val, Param);
+ return Res;
+ end;
+ when Iir_Kind_Val_Attribute =>
+ declare
+ Expr_Type : constant Iir := Get_Type (Expr);
+ Val_Expr : Iir;
+ Val : Iir_Int64;
+ begin
+ Val_Expr := Eval_Static_Expr (Get_Parameter (Expr));
+ Val := Eval_Pos (Val_Expr);
+ -- Note: the type of 'val is a base type.
+ -- FIXME: handle VHDL93 restrictions.
+ if Get_Kind (Expr_Type) = Iir_Kind_Enumeration_Type_Definition
+ and then
+ not Eval_Int_In_Range (Val, Get_Range_Constraint (Expr_Type))
+ then
+ Warning_Msg_Sem
+ ("static argument out of the type range", Expr);
+ return Build_Overflow (Expr);
+ end if;
+ if Get_Kind (Get_Base_Type (Get_Type (Expr)))
+ = Iir_Kind_Physical_Type_Definition
+ then
+ return Build_Physical (Val, Expr);
+ else
+ return Build_Discrete (Val, Expr);
+ end if;
+ end;
+ when Iir_Kind_Image_Attribute =>
+ declare
+ Param : Iir;
+ Param_Type : Iir;
+ begin
+ Param := Get_Parameter (Expr);
+ Param := Eval_Static_Expr (Param);
+ Set_Parameter (Expr, Param);
+ Param_Type := Get_Base_Type (Get_Type (Param));
+ case Get_Kind (Param_Type) is
+ when Iir_Kind_Integer_Type_Definition =>
+ return Eval_Integer_Image (Get_Value (Param), Expr);
+ when Iir_Kind_Floating_Type_Definition =>
+ return Eval_Floating_Image (Get_Fp_Value (Param), Expr);
+ when Iir_Kind_Enumeration_Type_Definition =>
+ return Eval_Enumeration_Image (Param, Expr);
+ when Iir_Kind_Physical_Type_Definition =>
+ return Eval_Physical_Image (Param, Expr);
+ when others =>
+ Error_Kind ("eval_static_expr('image)", Param);
+ end case;
+ end;
+ when Iir_Kind_Value_Attribute =>
+ declare
+ Param : Iir;
+ Param_Type : Iir;
+ begin
+ Param := Get_Parameter (Expr);
+ Param := Eval_Static_Expr (Param);
+ Set_Parameter (Expr, Param);
+ if Get_Kind (Param) /= Iir_Kind_String_Literal then
+ -- FIXME: Isn't it an implementation restriction.
+ Warning_Msg_Sem ("'value argument not a string", Expr);
+ return Build_Overflow (Expr);
+ else
+ -- what type are we converting the string to?
+ Param_Type := Get_Base_Type (Get_Type (Expr));
+ declare
+ Value : constant String := Image_String_Lit (Param);
+ begin
+ case Get_Kind (Param_Type) is
+ when Iir_Kind_Integer_Type_Definition =>
+ return Build_Discrete (Iir_Int64'Value (Value), Expr);
+ when Iir_Kind_Enumeration_Type_Definition =>
+ return Build_Enumeration_Value (Value, Param_Type,
+ Expr);
+ when Iir_Kind_Floating_Type_Definition =>
+ return Build_Floating (Iir_Fp64'value (Value), Expr);
+ when Iir_Kind_Physical_Type_Definition =>
+ return Build_Physical_Value (Value, Param_Type, Expr);
+ when others =>
+ Error_Kind ("eval_static_expr('value)", Param);
+ end case;
+ end;
+ end if;
+ end;
+
+ when Iir_Kind_Left_Type_Attribute =>
+ return Eval_Static_Expr
+ (Get_Left_Limit (Eval_Static_Range (Get_Prefix (Expr))));
+ when Iir_Kind_Right_Type_Attribute =>
+ return Eval_Static_Expr
+ (Get_Right_Limit (Eval_Static_Range (Get_Prefix (Expr))));
+ when Iir_Kind_High_Type_Attribute =>
+ return Eval_Static_Expr
+ (Get_High_Limit (Eval_Static_Range (Get_Prefix (Expr))));
+ when Iir_Kind_Low_Type_Attribute =>
+ return Eval_Static_Expr
+ (Get_Low_Limit (Eval_Static_Range (Get_Prefix (Expr))));
+ when Iir_Kind_Ascending_Type_Attribute =>
+ return Build_Boolean
+ (Get_Direction (Eval_Static_Range (Get_Prefix (Expr))) = Iir_To);
+
+ when Iir_Kind_Length_Array_Attribute =>
+ declare
+ Index : Iir;
+ begin
+ Index := Eval_Array_Attribute (Expr);
+ return Build_Discrete (Eval_Discrete_Type_Length (Index), Expr);
+ end;
+ when Iir_Kind_Left_Array_Attribute =>
+ declare
+ Index : Iir;
+ begin
+ Index := Eval_Array_Attribute (Expr);
+ return Eval_Static_Expr
+ (Get_Left_Limit (Get_Range_Constraint (Index)));
+ end;
+ when Iir_Kind_Right_Array_Attribute =>
+ declare
+ Index : Iir;
+ begin
+ Index := Eval_Array_Attribute (Expr);
+ return Eval_Static_Expr
+ (Get_Right_Limit (Get_Range_Constraint (Index)));
+ end;
+ when Iir_Kind_Low_Array_Attribute =>
+ declare
+ Index : Iir;
+ begin
+ Index := Eval_Array_Attribute (Expr);
+ return Eval_Static_Expr
+ (Get_Low_Limit (Get_Range_Constraint (Index)));
+ end;
+ when Iir_Kind_High_Array_Attribute =>
+ declare
+ Index : Iir;
+ begin
+ Index := Eval_Array_Attribute (Expr);
+ return Eval_Static_Expr
+ (Get_High_Limit (Get_Range_Constraint (Index)));
+ end;
+ when Iir_Kind_Ascending_Array_Attribute =>
+ declare
+ Index : Iir;
+ begin
+ Index := Eval_Array_Attribute (Expr);
+ return Build_Boolean
+ (Get_Direction (Get_Range_Constraint (Index)) = Iir_To);
+ end;
+
+ when Iir_Kind_Pred_Attribute =>
+ Res := Eval_Incdec
+ (Eval_Static_Expr (Get_Parameter (Expr)), -1, Expr);
+ Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr)));
+ return Res;
+ when Iir_Kind_Succ_Attribute =>
+ Res := Eval_Incdec
+ (Eval_Static_Expr (Get_Parameter (Expr)), +1, Expr);
+ Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr)));
+ return Res;
+ when Iir_Kind_Leftof_Attribute
+ | Iir_Kind_Rightof_Attribute =>
+ declare
+ Rng : Iir;
+ N : Iir_Int64;
+ Prefix_Type : Iir;
+ Res : Iir;
+ begin
+ Prefix_Type := Get_Type (Get_Prefix (Expr));
+ Rng := Eval_Static_Range (Prefix_Type);
+ case Get_Direction (Rng) is
+ when Iir_To =>
+ N := 1;
+ when Iir_Downto =>
+ N := -1;
+ end case;
+ case Get_Kind (Expr) is
+ when Iir_Kind_Leftof_Attribute =>
+ N := -N;
+ when Iir_Kind_Rightof_Attribute =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ Res := Eval_Incdec
+ (Eval_Static_Expr (Get_Parameter (Expr)), N, Expr);
+ Eval_Check_Bound (Res, Prefix_Type);
+ return Res;
+ end;
+
+ when Iir_Kind_Simple_Name_Attribute =>
+ declare
+ use Str_Table;
+ Id : String_Id;
+ begin
+ Id := Start;
+ Image (Get_Simple_Name_Identifier (Expr));
+ for I in 1 .. Name_Length loop
+ Append (Name_Buffer (I));
+ end loop;
+ Finish;
+ return Build_String (Id, Nat32 (Name_Length), Expr);
+ end;
+
+ when Iir_Kind_Null_Literal =>
+ return Expr;
+
+ when Iir_Kind_Function_Call =>
+ declare
+ Imp : constant Iir := Get_Implementation (Expr);
+ Left, Right : Iir;
+ begin
+ -- Note: there can't be association by name.
+ Left := Get_Parameter_Association_Chain (Expr);
+ Right := Get_Chain (Left);
+
+ Left := Eval_Static_Expr (Get_Actual (Left));
+ if Right = Null_Iir then
+ return Eval_Monadic_Operator (Expr, Left);
+ else
+ Right := Eval_Static_Expr (Get_Actual (Right));
+ return Eval_Dyadic_Operator (Expr, Imp, Left, Right);
+ end if;
+ end;
+
+ when Iir_Kind_Error =>
+ return Expr;
+ when others =>
+ Error_Kind ("eval_static_expr", Expr);
+ end case;
+ end Eval_Static_Expr;
+
+ -- If FORCE is true, always return a literal.
+ function Eval_Expr_Keep_Orig (Expr : Iir; Force : Boolean) return Iir
+ is
+ Res : Iir;
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kinds_Denoting_Name =>
+ declare
+ Orig : constant Iir := Get_Named_Entity (Expr);
+ begin
+ Res := Eval_Static_Expr (Orig);
+ if Res /= Orig or else Force then
+ return Build_Constant (Res, Expr);
+ else
+ return Expr;
+ end if;
+ end;
+ when others =>
+ Res := Eval_Static_Expr (Expr);
+ if Res /= Expr
+ and then Get_Literal_Origin (Res) /= Expr
+ then
+ -- Need to build a constant if the result is a different
+ -- literal not tied to EXPR.
+ return Build_Constant (Res, Expr);
+ else
+ return Res;
+ end if;
+ end case;
+ end Eval_Expr_Keep_Orig;
+
+ function Eval_Expr (Expr: Iir) return Iir is
+ begin
+ if Get_Expr_Staticness (Expr) /= Locally then
+ Error_Msg_Sem ("expression must be locally static", Expr);
+ return Expr;
+ else
+ return Eval_Expr_Keep_Orig (Expr, False);
+ end if;
+ end Eval_Expr;
+
+ function Eval_Expr_If_Static (Expr : Iir) return Iir is
+ begin
+ if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then
+ return Eval_Expr_Keep_Orig (Expr, False);
+ else
+ return Expr;
+ end if;
+ end Eval_Expr_If_Static;
+
+ function Eval_Expr_Check (Expr : Iir; Sub_Type : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Eval_Expr_Keep_Orig (Expr, False);
+ Eval_Check_Bound (Res, Sub_Type);
+ return Res;
+ end Eval_Expr_Check;
+
+ function Eval_Expr_Check_If_Static (Expr : Iir; Atype : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then
+ -- Expression is static and can be evaluated.
+ Res := Eval_Expr_Keep_Orig (Expr, False);
+
+ if Res /= Null_Iir
+ and then Get_Type_Staticness (Atype) = Locally
+ and then Get_Kind (Atype) in Iir_Kinds_Range_Type_Definition
+ then
+ -- Check bounds (as this can be done).
+ -- FIXME: create overflow_expr ?
+ Eval_Check_Bound (Res, Atype);
+ end if;
+
+ return Res;
+ else
+ return Expr;
+ end if;
+ end Eval_Expr_Check_If_Static;
+
+ function Eval_Int_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean is
+ begin
+ case Get_Kind (Bound) is
+ when Iir_Kind_Range_Expression =>
+ case Get_Direction (Bound) is
+ when Iir_To =>
+ if Val < Eval_Pos (Get_Left_Limit (Bound))
+ or else Val > Eval_Pos (Get_Right_Limit (Bound))
+ then
+ return False;
+ end if;
+ when Iir_Downto =>
+ if Val > Eval_Pos (Get_Left_Limit (Bound))
+ or else Val < Eval_Pos (Get_Right_Limit (Bound))
+ then
+ return False;
+ end if;
+ end case;
+ when others =>
+ Error_Kind ("eval_int_in_range", Bound);
+ end case;
+ return True;
+ end Eval_Int_In_Range;
+
+ function Eval_Phys_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean
+ is
+ Left, Right : Iir_Int64;
+ begin
+ case Get_Kind (Bound) is
+ when Iir_Kind_Range_Expression =>
+ case Get_Kind (Get_Type (Get_Left_Limit (Bound))) is
+ when Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition =>
+ Left := Get_Value (Get_Left_Limit (Bound));
+ Right := Get_Value (Get_Right_Limit (Bound));
+ when Iir_Kind_Physical_Type_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ Left := Get_Physical_Value (Get_Left_Limit (Bound));
+ Right := Get_Physical_Value (Get_Right_Limit (Bound));
+ when others =>
+ Error_Kind ("eval_phys_in_range(1)", Get_Type (Bound));
+ end case;
+ case Get_Direction (Bound) is
+ when Iir_To =>
+ if Val < Left or else Val > Right then
+ return False;
+ end if;
+ when Iir_Downto =>
+ if Val > Left or else Val < Right then
+ return False;
+ end if;
+ end case;
+ when others =>
+ Error_Kind ("eval_phys_in_range", Bound);
+ end case;
+ return True;
+ end Eval_Phys_In_Range;
+
+ function Eval_Fp_In_Range (Val : Iir_Fp64; Bound : Iir) return Boolean is
+ begin
+ case Get_Kind (Bound) is
+ when Iir_Kind_Range_Expression =>
+ case Get_Direction (Bound) is
+ when Iir_To =>
+ if Val < Get_Fp_Value (Get_Left_Limit (Bound))
+ or else Val > Get_Fp_Value (Get_Right_Limit (Bound))
+ then
+ return False;
+ end if;
+ when Iir_Downto =>
+ if Val > Get_Fp_Value (Get_Left_Limit (Bound))
+ or else Val < Get_Fp_Value (Get_Right_Limit (Bound))
+ then
+ return False;
+ end if;
+ end case;
+ when others =>
+ Error_Kind ("eval_fp_in_range", Bound);
+ end case;
+ return True;
+ end Eval_Fp_In_Range;
+
+ -- Return TRUE if literal EXPR is in SUB_TYPE bounds.
+ function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir) return Boolean
+ is
+ Type_Range : Iir;
+ Val : Iir;
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Error =>
+ -- Ignore errors.
+ return True;
+ when Iir_Kind_Overflow_Literal =>
+ -- Never within bounds
+ return False;
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Selected_Name =>
+ Val := Get_Named_Entity (Expr);
+ when others =>
+ Val := Expr;
+ end case;
+
+ case Get_Kind (Sub_Type) is
+ when Iir_Kind_Integer_Subtype_Definition =>
+ Type_Range := Get_Range_Constraint (Sub_Type);
+ return Eval_Int_In_Range (Get_Value (Val), Type_Range);
+ when Iir_Kind_Floating_Subtype_Definition =>
+ Type_Range := Get_Range_Constraint (Sub_Type);
+ return Eval_Fp_In_Range (Get_Fp_Value (Val), Type_Range);
+ when Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition =>
+ -- A check is required for an enumeration type definition for
+ -- 'val attribute.
+ Type_Range := Get_Range_Constraint (Sub_Type);
+ return Eval_Int_In_Range
+ (Iir_Int64 (Get_Enum_Pos (Val)), Type_Range);
+ when Iir_Kind_Physical_Subtype_Definition =>
+ Type_Range := Get_Range_Constraint (Sub_Type);
+ return Eval_Phys_In_Range (Get_Physical_Value (Val), Type_Range);
+
+ when Iir_Kind_Base_Attribute =>
+ return Eval_Is_In_Bound (Val, Get_Type (Sub_Type));
+
+ when Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Record_Type_Definition =>
+ -- FIXME: do it.
+ return True;
+
+ when others =>
+ Error_Kind ("eval_is_in_bound", Sub_Type);
+ end case;
+ end Eval_Is_In_Bound;
+
+ procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir) is
+ begin
+ if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then
+ -- Nothing to check, and a message was already generated.
+ return;
+ end if;
+
+ if not Eval_Is_In_Bound (Expr, Sub_Type) then
+ Error_Msg_Sem ("static constant violates bounds", Expr);
+ end if;
+ end Eval_Check_Bound;
+
+ function Eval_Is_Range_In_Bound
+ (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean)
+ return Boolean
+ is
+ Type_Range : Iir;
+ Range_Constraint : constant Iir := Eval_Static_Range (A_Range);
+ begin
+ Type_Range := Get_Range_Constraint (Sub_Type);
+ if not Any_Dir
+ and then Get_Direction (Type_Range) /= Get_Direction (Range_Constraint)
+ then
+ return True;
+ end if;
+
+ case Get_Kind (Sub_Type) is
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition =>
+ declare
+ L, R : Iir_Int64;
+ begin
+ -- Check for null range.
+ L := Eval_Pos (Get_Left_Limit (Range_Constraint));
+ R := Eval_Pos (Get_Right_Limit (Range_Constraint));
+ case Get_Direction (Range_Constraint) is
+ when Iir_To =>
+ if L > R then
+ return True;
+ end if;
+ when Iir_Downto =>
+ if L < R then
+ return True;
+ end if;
+ end case;
+ return Eval_Int_In_Range (L, Type_Range)
+ and then Eval_Int_In_Range (R, Type_Range);
+ end;
+ when Iir_Kind_Floating_Subtype_Definition =>
+ declare
+ L, R : Iir_Fp64;
+ begin
+ -- Check for null range.
+ L := Get_Fp_Value (Get_Left_Limit (Range_Constraint));
+ R := Get_Fp_Value (Get_Right_Limit (Range_Constraint));
+ case Get_Direction (Range_Constraint) is
+ when Iir_To =>
+ if L > R then
+ return True;
+ end if;
+ when Iir_Downto =>
+ if L < R then
+ return True;
+ end if;
+ end case;
+ return Eval_Fp_In_Range (L, Type_Range)
+ and then Eval_Fp_In_Range (R, Type_Range);
+ end;
+ when others =>
+ Error_Kind ("eval_is_range_in_bound", Sub_Type);
+ end case;
+
+ -- Should check L <= R or L >= R according to direction.
+ --return Eval_Is_In_Bound (Get_Left_Limit (A_Range), Sub_Type)
+ -- and then Eval_Is_In_Bound (Get_Right_Limit (A_Range), Sub_Type);
+ end Eval_Is_Range_In_Bound;
+
+ procedure Eval_Check_Range
+ (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean)
+ is
+ begin
+ if not Eval_Is_Range_In_Bound (A_Range, Sub_Type, Any_Dir) then
+ Error_Msg_Sem ("static range violates bounds", A_Range);
+ end if;
+ end Eval_Check_Range;
+
+ function Eval_Discrete_Range_Length (Constraint : Iir) return Iir_Int64
+ is
+ Res : Iir_Int64;
+ Left, Right : Iir_Int64;
+ begin
+ Left := Eval_Pos (Get_Left_Limit (Constraint));
+ Right := Eval_Pos (Get_Right_Limit (Constraint));
+ case Get_Direction (Constraint) is
+ when Iir_To =>
+ if Right < Left then
+ -- Null range.
+ return 0;
+ else
+ Res := Right - Left + 1;
+ end if;
+ when Iir_Downto =>
+ if Left < Right then
+ -- Null range
+ return 0;
+ else
+ Res := Left - Right + 1;
+ end if;
+ end case;
+ return Res;
+ end Eval_Discrete_Range_Length;
+
+ function Eval_Discrete_Type_Length (Sub_Type : Iir) return Iir_Int64
+ is
+ begin
+ case Get_Kind (Sub_Type) is
+ when Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition =>
+ return Eval_Discrete_Range_Length
+ (Get_Range_Constraint (Sub_Type));
+ when others =>
+ Error_Kind ("eval_discrete_type_length", Sub_Type);
+ end case;
+ end Eval_Discrete_Type_Length;
+
+ function Eval_Pos (Expr : Iir) return Iir_Int64 is
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Integer_Literal =>
+ return Get_Value (Expr);
+ when Iir_Kind_Enumeration_Literal =>
+ return Iir_Int64 (Get_Enum_Pos (Expr));
+ when Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal
+ | Iir_Kind_Unit_Declaration =>
+ return Get_Physical_Value (Expr);
+ when Iir_Kinds_Denoting_Name =>
+ return Eval_Pos (Get_Named_Entity (Expr));
+ when others =>
+ Error_Kind ("eval_pos", Expr);
+ end case;
+ end Eval_Pos;
+
+ function Eval_Static_Range (Rng : Iir) return Iir
+ is
+ Expr : Iir;
+ Kind : Iir_Kind;
+ begin
+ Expr := Rng;
+ loop
+ Kind := Get_Kind (Expr);
+ case Kind is
+ when Iir_Kind_Range_Expression =>
+ if Get_Expr_Staticness (Expr) /= Locally then
+ return Null_Iir;
+ end if;
+
+ -- Normalize the range expression.
+ Set_Left_Limit
+ (Expr, Eval_Expr_Keep_Orig (Get_Left_Limit (Expr), True));
+ Set_Right_Limit
+ (Expr, Eval_Expr_Keep_Orig (Get_Right_Limit (Expr), True));
+ return Expr;
+ when Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ Expr := Get_Range_Constraint (Expr);
+ when Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ declare
+ Prefix : Iir;
+ Res : Iir;
+ begin
+ Prefix := Get_Prefix (Expr);
+ if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition
+ then
+ Prefix := Get_Type (Prefix);
+ end if;
+ if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition
+ then
+ -- Unconstrained object.
+ return Null_Iir;
+ end if;
+ Expr := Get_Nth_Element
+ (Get_Index_Subtype_List (Prefix),
+ Natural (Eval_Pos (Get_Parameter (Expr))) - 1);
+ if Kind = Iir_Kind_Reverse_Range_Array_Attribute then
+ Expr := Eval_Static_Range (Expr);
+
+ Res := Create_Iir (Iir_Kind_Range_Expression);
+ Location_Copy (Res, Expr);
+ Set_Type (Res, Get_Type (Expr));
+ case Get_Direction (Expr) is
+ when Iir_To =>
+ Set_Direction (Res, Iir_Downto);
+ when Iir_Downto =>
+ Set_Direction (Res, Iir_To);
+ end case;
+ Set_Left_Limit (Res, Get_Right_Limit (Expr));
+ Set_Right_Limit (Res, Get_Left_Limit (Expr));
+ Set_Range_Origin (Res, Rng);
+ Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr));
+ return Res;
+ end if;
+ end;
+
+ when Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Base_Attribute =>
+ Expr := Get_Type (Expr);
+ when Iir_Kind_Type_Declaration =>
+ Expr := Get_Type_Definition (Expr);
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ Expr := Get_Named_Entity (Expr);
+ when others =>
+ Error_Kind ("eval_static_range", Expr);
+ end case;
+ end loop;
+ end Eval_Static_Range;
+
+ function Eval_Range (Arange : Iir) return Iir is
+ Res : Iir;
+ begin
+ Res := Eval_Static_Range (Arange);
+ if Res /= Arange
+ and then Get_Range_Origin (Res) /= Arange
+ then
+ return Build_Constant_Range (Res, Arange);
+ else
+ return Res;
+ end if;
+ end Eval_Range;
+
+ function Eval_Range_If_Static (Arange : Iir) return Iir is
+ begin
+ if Get_Expr_Staticness (Arange) /= Locally then
+ return Arange;
+ else
+ return Eval_Range (Arange);
+ end if;
+ end Eval_Range_If_Static;
+
+ -- Return the range constraint of a discrete range.
+ function Eval_Discrete_Range_Expression (Constraint : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Eval_Static_Range (Constraint);
+ if Res = Null_Iir then
+ Error_Kind ("eval_discrete_range_expression", Constraint);
+ else
+ return Res;
+ end if;
+ end Eval_Discrete_Range_Expression;
+
+ function Eval_Discrete_Range_Left (Constraint : Iir) return Iir
+ is
+ Range_Expr : Iir;
+ begin
+ Range_Expr := Eval_Discrete_Range_Expression (Constraint);
+ return Get_Left_Limit (Range_Expr);
+ end Eval_Discrete_Range_Left;
+
+ procedure Eval_Operator_Symbol_Name (Id : Name_Id)
+ is
+ begin
+ Image (Id);
+ Name_Buffer (2 .. Name_Length + 1) := Name_Buffer (1 .. Name_Length);
+ Name_Buffer (1) := '"'; --"
+ Name_Length := Name_Length + 2;
+ Name_Buffer (Name_Length) := '"'; --"
+ end Eval_Operator_Symbol_Name;
+
+ procedure Eval_Simple_Name (Id : Name_Id)
+ is
+ begin
+ -- LRM 14.1
+ -- E'SIMPLE_NAME
+ -- Result: [...] but with apostrophes (in the case of a character
+ -- literal)
+ if Is_Character (Id) then
+ Name_Buffer (1) := ''';
+ Name_Buffer (2) := Get_Character (Id);
+ Name_Buffer (3) := ''';
+ Name_Length := 3;
+ return;
+ end if;
+ case Id is
+ when Std_Names.Name_Word_Operators
+ | Std_Names.Name_First_Operator .. Std_Names.Name_Last_Operator =>
+ Eval_Operator_Symbol_Name (Id);
+ return;
+ when Std_Names.Name_Xnor
+ | Std_Names.Name_Shift_Operators =>
+ if Flags.Vhdl_Std > Vhdl_87 then
+ Eval_Operator_Symbol_Name (Id);
+ return;
+ end if;
+ when others =>
+ null;
+ end case;
+ Image (Id);
+-- if Name_Buffer (1) = '\' then
+-- declare
+-- I : Natural;
+-- begin
+-- I := 2;
+-- while I <= Name_Length loop
+-- if Name_Buffer (I) = '\' then
+-- Name_Length := Name_Length + 1;
+-- Name_Buffer (I + 1 .. Name_Length) :=
+-- Name_Buffer (I .. Name_Length - 1);
+-- I := I + 1;
+-- end if;
+-- I := I + 1;
+-- end loop;
+-- Name_Length := Name_Length + 1;
+-- Name_Buffer (Name_Length) := '\';
+-- end;
+-- end if;
+ end Eval_Simple_Name;
+
+ function Compare_String_Literals (L, R : Iir) return Compare_Type
+ is
+ type Str_Info is record
+ El : Iir;
+ Ptr : String_Fat_Acc;
+ Len : Nat32;
+ Lit_0 : Iir;
+ Lit_1 : Iir;
+ List : Iir_List;
+ end record;
+
+ Literal_List : Iir_List;
+
+ -- Fill Res from EL. This is used to speed up Lt and Eq operations.
+ procedure Get_Info (Expr : Iir; Res : out Str_Info) is
+ begin
+ case Get_Kind (Expr) is
+ when Iir_Kind_Simple_Aggregate =>
+ Res := Str_Info'(El => Expr,
+ Ptr => null,
+ Len => 0,
+ Lit_0 | Lit_1 => Null_Iir,
+ List => Get_Simple_Aggregate_List (Expr));
+ Res.Len := Nat32 (Get_Nbr_Elements (Res.List));
+ when Iir_Kind_Bit_String_Literal =>
+ Res := Str_Info'(El => Expr,
+ Ptr => Get_String_Fat_Acc (Expr),
+ Len => Get_String_Length (Expr),
+ Lit_0 => Get_Bit_String_0 (Expr),
+ Lit_1 => Get_Bit_String_1 (Expr),
+ List => Null_Iir_List);
+ when Iir_Kind_String_Literal =>
+ Res := Str_Info'(El => Expr,
+ Ptr => Get_String_Fat_Acc (Expr),
+ Len => Get_String_Length (Expr),
+ Lit_0 | Lit_1 => Null_Iir,
+ List => Null_Iir_List);
+ when others =>
+ Error_Kind ("sem_string_choice_range.get_info", Expr);
+ end case;
+ end Get_Info;
+
+ -- Return the position of element IDX of STR.
+ function Get_Pos (Str : Str_Info; Idx : Nat32) return Iir_Int32
+ is
+ S : Iir;
+ C : Character;
+ begin
+ case Get_Kind (Str.El) is
+ when Iir_Kind_Simple_Aggregate =>
+ S := Get_Nth_Element (Str.List, Natural (Idx));
+ when Iir_Kind_String_Literal =>
+ C := Str.Ptr (Idx + 1);
+ -- FIXME: build a table from character to position.
+ -- This linear search is O(n)!
+ S := Find_Name_In_List (Literal_List,
+ Name_Table.Get_Identifier (C));
+ if S = Null_Iir then
+ return -1;
+ end if;
+ when Iir_Kind_Bit_String_Literal =>
+ C := Str.Ptr (Idx + 1);
+ case C is
+ when '0' =>
+ S := Str.Lit_0;
+ when '1' =>
+ S := Str.Lit_1;
+ when others =>
+ raise Internal_Error;
+ end case;
+ when others =>
+ Error_Kind ("sem_string_choice_range.get_pos", Str.El);
+ end case;
+ return Get_Enum_Pos (S);
+ end Get_Pos;
+
+ L_Info, R_Info : Str_Info;
+ L_Pos, R_Pos : Iir_Int32;
+ begin
+ Get_Info (L, L_Info);
+ Get_Info (R, R_Info);
+
+ if L_Info.Len /= R_Info.Len then
+ raise Internal_Error;
+ end if;
+
+ Literal_List := Get_Enumeration_Literal_List
+ (Get_Base_Type (Get_Element_Subtype (Get_Type (L))));
+
+ for I in 0 .. L_Info.Len - 1 loop
+ L_Pos := Get_Pos (L_Info, I);
+ R_Pos := Get_Pos (R_Info, I);
+ if L_Pos /= R_Pos then
+ if L_Pos < R_Pos then
+ return Compare_Lt;
+ else
+ return Compare_Gt;
+ end if;
+ end if;
+ end loop;
+ return Compare_Eq;
+ end Compare_String_Literals;
+
+ function Get_Path_Instance_Name_Suffix (Attr : Iir)
+ return Path_Instance_Name_Type
+ is
+ -- Current path for name attributes.
+ Path_Str : String_Acc := null;
+ Path_Maxlen : Natural := 0;
+ Path_Len : Natural;
+ Path_Instance : Iir;
+
+ procedure Deallocate is new Ada.Unchecked_Deallocation
+ (Name => String_Acc, Object => String);
+
+ procedure Path_Reset is
+ begin
+ Path_Len := 0;
+ Path_Instance := Null_Iir;
+ if Path_Maxlen = 0 then
+ Path_Maxlen := 256;
+ Path_Str := new String (1 .. Path_Maxlen);
+ end if;
+ end Path_Reset;
+
+ procedure Path_Add (Str : String)
+ is
+ N_Len : Natural;
+ N_Path : String_Acc;
+ begin
+ N_Len := Path_Maxlen;
+ loop
+ exit when Path_Len + Str'Length <= N_Len;
+ N_Len := N_Len * 2;
+ end loop;
+ if N_Len /= Path_Maxlen then
+ N_Path := new String (1 .. N_Len);
+ N_Path (1 .. Path_Len) := Path_Str (1 .. Path_Len);
+ Deallocate (Path_Str);
+ Path_Str := N_Path;
+ Path_Maxlen := N_Len;
+ end if;
+ Path_Str (Path_Len + 1 .. Path_Len + Str'Length) := Str;
+ Path_Len := Path_Len + Str'Length;
+ end Path_Add;
+
+ procedure Path_Add_Type_Name (Atype : Iir)
+ is
+ Adecl : Iir;
+ begin
+ Adecl := Get_Type_Declarator (Atype);
+ Image (Get_Identifier (Adecl));
+ Path_Add (Name_Buffer (1 .. Name_Length));
+ end Path_Add_Type_Name;
+
+ procedure Path_Add_Signature (Subprg : Iir)
+ is
+ Chain : Iir;
+ begin
+ Path_Add ("[");
+ Chain := Get_Interface_Declaration_Chain (Subprg);
+ while Chain /= Null_Iir loop
+ Path_Add_Type_Name (Get_Type (Chain));
+ Chain := Get_Chain (Chain);
+ if Chain /= Null_Iir then
+ Path_Add (",");
+ end if;
+ end loop;
+
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration =>
+ Path_Add (" return ");
+ Path_Add_Type_Name (Get_Return_Type (Subprg));
+ when others =>
+ null;
+ end case;
+ Path_Add ("]");
+ end Path_Add_Signature;
+
+ procedure Path_Add_Name (N : Iir) is
+ begin
+ Eval_Simple_Name (Get_Identifier (N));
+ if Name_Buffer (1) /= 'P' then
+ -- Skip anonymous processes.
+ Path_Add (Name_Buffer (1 .. Name_Length));
+ end if;
+ end Path_Add_Name;
+
+ procedure Path_Add_Element (El : Iir; Is_Instance : Boolean) is
+ begin
+ -- LRM 14.1
+ -- E'INSTANCE_NAME
+ -- There is one full path instance element for each component
+ -- instantiation, block statement, generate statemenent, process
+ -- statement, or subprogram body in the design hierarchy between
+ -- the top design entity and the named entity denoted by the
+ -- prefix.
+ --
+ -- E'PATH_NAME
+ -- There is one path instance element for each component
+ -- instantiation, block statement, generate statement, process
+ -- statement, or subprogram body in the design hierarchy between
+ -- the root design entity and the named entity denoted by the
+ -- prefix.
+ case Get_Kind (El) is
+ when Iir_Kind_Library_Declaration =>
+ Path_Add (":");
+ Path_Add_Name (El);
+ Path_Add (":");
+ when Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Body =>
+ Path_Add_Element
+ (Get_Library (Get_Design_File (Get_Design_Unit (El))),
+ Is_Instance);
+ Path_Add_Name (El);
+ Path_Add (":");
+ when Iir_Kind_Entity_Declaration =>
+ Path_Instance := El;
+ when Iir_Kind_Architecture_Body =>
+ Path_Instance := El;
+ when Iir_Kind_Design_Unit =>
+ Path_Add_Element (Get_Library_Unit (El), Is_Instance);
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Block_Statement =>
+ Path_Add_Element (Get_Parent (El), Is_Instance);
+ Path_Add_Name (El);
+ Path_Add (":");
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ Path_Add_Element (Get_Parent (El), Is_Instance);
+ Path_Add_Name (El);
+ if Flags.Vhdl_Std >= Vhdl_02 then
+ -- Add signature.
+ Path_Add_Signature (El);
+ end if;
+ Path_Add (":");
+ when Iir_Kind_Procedure_Body =>
+ Path_Add_Element (Get_Subprogram_Specification (El),
+ Is_Instance);
+ when Iir_Kind_Generate_Statement =>
+ declare
+ Scheme : Iir;
+ begin
+ Scheme := Get_Generation_Scheme (El);
+ if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
+ Path_Instance := El;
+ else
+ Path_Add_Element (Get_Parent (El), Is_Instance);
+ Path_Add_Name (El);
+ Path_Add (":");
+ end if;
+ end;
+ when Iir_Kinds_Sequential_Statement =>
+ Path_Add_Element (Get_Parent (El), Is_Instance);
+ when others =>
+ Error_Kind ("path_add_element", El);
+ end case;
+ end Path_Add_Element;
+
+ Prefix : constant Iir := Get_Named_Entity (Get_Prefix (Attr));
+ Is_Instance : constant Boolean :=
+ Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute;
+ begin
+ Path_Reset;
+
+ -- LRM 14.1
+ -- E'PATH_NAME
+ -- The local item name in E'PATH_NAME equals E'SIMPLE_NAME, unless
+ -- E denotes a library, package, subprogram or label. In this
+ -- latter case, the package based path or instance based path,
+ -- as appropriate, will not contain a local item name.
+ --
+ -- E'INSTANCE_NAME
+ -- The local item name in E'INSTANCE_NAME equals E'SIMPLE_NAME,
+ -- unless E denotes a library, package, subprogram, or label. In
+ -- this latter case, the package based path or full instance based
+ -- path, as appropriate, will not contain a local item name.
+ case Get_Kind (Prefix) is
+ when Iir_Kind_Constant_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration =>
+ Path_Add_Element (Get_Parent (Prefix), Is_Instance);
+ Path_Add_Name (Prefix);
+ when Iir_Kind_Library_Declaration
+ | Iir_Kinds_Library_Unit_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kinds_Concurrent_Statement
+ | Iir_Kinds_Sequential_Statement =>
+ Path_Add_Element (Prefix, Is_Instance);
+ when others =>
+ Error_Kind ("get_path_instance_name_suffix", Prefix);
+ end case;
+
+ declare
+ Result : constant Path_Instance_Name_Type :=
+ (Len => Path_Len,
+ Path_Instance => Path_Instance,
+ Suffix => Path_Str (1 .. Path_Len));
+ begin
+ Deallocate (Path_Str);
+ return Result;
+ end;
+ end Get_Path_Instance_Name_Suffix;
+
+end Evaluation;
diff --git a/src/evaluation.ads b/src/evaluation.ads
new file mode 100644
index 000000000..66ec2a1cc
--- /dev/null
+++ b/src/evaluation.ads
@@ -0,0 +1,161 @@
+-- Evaluation of static expressions.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with Iirs; use Iirs;
+
+package Evaluation is
+
+ -- Evaluation is about compile-time computation of expressions, such as
+ -- 2 + 1 --> 3. This is (of course) possible only with locally (and some
+ -- globally) static expressions. Evaluation is required during semantic
+ -- analysis at many places (in fact those where locally static expression
+ -- are required by the language). For example, the type of O'Range (N)
+ -- depends on N, so we need to evaluate N.
+ --
+ -- The result of evaluation is a literal (integer, enumeration, real,
+ -- physical), a string or a simple aggregate. For scalar types, the
+ -- result is therefore normalized (there is only one kind of result), but
+ -- for array types, the result isn't: in general it will be a string, but
+ -- it may be a simple aggregate. Strings are preferred (because they are
+ -- more compact), but aren't possible in some cases. For example, the
+ -- evaluation of "Text" & NUL cannot be a string.
+ --
+ -- Some functions (like Eval_Static_Expr) simply returns a result (which
+ -- may be a node of the expression), others returns a result and set the
+ -- origin (Literal_Origin or Range_Origin) to remember the original
+ -- expression that was evaluation. The original expression is kept so that
+ -- it is possible to print the original tree.
+
+ -- Get the value of a physical integer literal or unit.
+ function Get_Physical_Value (Expr : Iir) return Iir_Int64;
+
+ -- Evaluate the locally static expression EXPR (without checking that EXPR
+ -- is locally static). Return a literal or an aggregate, without setting
+ -- the origin, and do not modify EXPR. This can be used only to get the
+ -- value of an expression, without replacing it.
+ function Eval_Static_Expr (Expr: Iir) return Iir;
+
+ -- Evaluate (ie compute) expression EXPR.
+ -- EXPR is required to be a locally static expression, otherwise an error
+ -- message is generated.
+ -- The result is a literal with the origin set.
+ function Eval_Expr (Expr: Iir) return Iir;
+
+ -- Same as Eval_Expr, but if EXPR is not locally static, the result is
+ -- EXPR. Also, if EXPR is null_iir, then null_iir is returned.
+ -- The purpose of this function is to evaluate an expression only if it
+ -- is locally static.
+ function Eval_Expr_If_Static (Expr : Iir) return Iir;
+
+ -- Evaluate a physical literal and return a normalized literal (using
+ -- the primary unit as unit).
+ function Eval_Physical_Literal (Expr : Iir) return Iir;
+
+ -- Return TRUE if literal EXPR is in SUB_TYPE bounds.
+ function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir) return Boolean;
+
+ -- Emit an error if EXPR violates SUB_TYPE bounds.
+ procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir);
+
+ -- Same as Eval_Expr, but a range check with SUB_TYPE is performed after
+ -- computation.
+ function Eval_Expr_Check (Expr : Iir; Sub_Type : Iir) return Iir;
+
+ -- Call Eval_Expr_Check only if EXPR is static.
+ function Eval_Expr_Check_If_Static (Expr : Iir; Atype : Iir) return Iir;
+
+ -- For a locally static range RNG (a range expression, a range attribute
+ -- or a name that denotes a type or a subtype) returns its corresponding
+ -- locally static range_expression. The bounds of the results are also
+ -- literals.
+ -- Return a range_expression or NULL_IIR for a non locally static range.
+ function Eval_Static_Range (Rng : Iir) return Iir;
+
+ -- Return a locally static range expression with the origin set for ARANGE.
+ function Eval_Range (Arange : Iir) return Iir;
+
+ -- If ARANGE is a locally static range, return locally static range
+ -- expression (with the origin set), else return ARANGE.
+ function Eval_Range_If_Static (Arange : Iir) return Iir;
+
+ -- Emit an error if A_RANGE is not included in SUB_TYPE. A_RANGE can be
+ -- a range expression, a range attribute or a name that denotes a discrete
+ -- type or subtype. A_RANGE must be a locally static range.
+ procedure Eval_Check_Range (A_Range : Iir; Sub_Type : Iir;
+ Any_Dir : Boolean);
+
+ -- Return TRUE if range expression A_RANGE is not included in SUB_TYPE.
+ function Eval_Is_Range_In_Bound
+ (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean)
+ return Boolean;
+
+ -- Return TRUE iff VAL belongs to BOUND.
+ function Eval_Int_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean;
+
+ -- Return the length of the discrete range CONSTRAINT.
+ function Eval_Discrete_Range_Length (Constraint : Iir) return Iir_Int64;
+
+ -- Return the length of SUB_TYPE.
+ function Eval_Discrete_Type_Length (Sub_Type : Iir) return Iir_Int64;
+
+ -- Get the left bound of a range constraint.
+ -- Note: the range constraint may be an attribute or a subtype.
+ function Eval_Discrete_Range_Left (Constraint : Iir) return Iir;
+
+ -- Return the position of EXPR, ie the result of sub_type'pos (EXPR), where
+ -- sub_type is the type of expr.
+ -- EXPR must be of a discrete subtype.
+ function Eval_Pos (Expr : Iir) return Iir_Int64;
+
+ -- Replace ORIGIN (an overflow literal) with extreme positive value (if
+ -- IS_POS is true) or extreme negative value.
+ function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir;
+
+ -- Create an array subtype from LEN and BASE_TYPE, according to rules
+ -- of LRM93 7.3.2.2. (which are the same as LRM93 7.2.4).
+ function Create_Unidim_Array_By_Length
+ (Base_Type : Iir; Len : Iir_Int64; Loc : Iir)
+ return Iir_Array_Subtype_Definition;
+
+ -- Create a subtype of A_TYPE whose length is LEN.
+ -- This is used to create subtypes for strings or aggregates.
+ function Create_Range_Subtype_By_Length
+ (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type)
+ return Iir;
+
+ -- Store into NAME_BUFFER, NAME_LENGTH the simple name, character literal
+ -- or operator sumbol of ID, using the same format as SIMPLE_NAME
+ -- attribute.
+ procedure Eval_Simple_Name (Id : Name_Id);
+
+ -- Compare two string literals (of same length).
+ type Compare_Type is (Compare_Lt, Compare_Eq, Compare_Gt);
+ function Compare_String_Literals (L, R : Iir) return Compare_Type;
+
+ -- Return the local part of 'Instance_Name or 'Path_Name.
+ type Path_Instance_Name_Type (Len : Natural) is record
+ -- The node before suffix (entity, architecture or generate iterator).
+ Path_Instance : Iir;
+
+ -- The suffix
+ Suffix : String (1 .. Len);
+ end record;
+
+ function Get_Path_Instance_Name_Suffix (Attr : Iir)
+ return Path_Instance_Name_Type;
+end Evaluation;
diff --git a/src/files_map.adb b/src/files_map.adb
new file mode 100644
index 000000000..f4927e8db
--- /dev/null
+++ b/src/files_map.adb
@@ -0,0 +1,857 @@
+-- Loading of source files.
+-- 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 GHDL; 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 Ada.Characters.Latin_1;
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Unchecked_Deallocation;
+with GNAT.Table;
+with GNAT.OS_Lib;
+with GNAT.Directory_Operations;
+with Name_Table; use Name_Table;
+with Str_Table;
+with Ada.Calendar;
+with Ada.Calendar.Time_Zones;
+
+package body Files_Map is
+
+ -- Check validity of FILE.
+ -- Raise an exception in case of error.
+ procedure Check_File (File: in Source_File_Entry);
+
+ type Lines_Table_Type is array (Positive) of Source_Ptr;
+ type Lines_Table_Ptr is access all Lines_Table_Type;
+
+ -- Data associed with a file.
+ type Source_File_Record is record
+ -- All location between first and last belong to this file.
+ First_Location : Location_Type;
+ Last_Location : Location_Type;
+
+ -- The name_id that identify this file.
+ -- FIXME: what about file aliasing (links) ?
+ File_Name: Name_Id;
+
+ Directory : Name_Id;
+
+ -- The buffer containing the file.
+ Source: File_Buffer_Acc;
+
+ -- Length of the file, which is also the length of the buffer.
+ File_Length: Natural;
+
+ Time_Stamp: Time_Stamp_Id;
+
+ -- Current number of line in Lines_Table.
+ Nbr_Lines: Natural;
+
+ Lines_Table: Lines_Table_Ptr;
+
+ -- Current size of Lines_Table.
+ Lines_Table_Max: Natural;
+
+ -- Cache.
+ Cache_Line : Natural;
+ Cache_Pos : Source_Ptr;
+ end record;
+
+ -- Next location to use.
+ Next_Location : Location_Type := Location_Nil + 1;
+
+ package Source_Files is new GNAT.Table
+ (Table_Index_Type => Source_File_Entry,
+ Table_Component_Type => Source_File_Record,
+ Table_Low_Bound => No_Source_File_Entry + 1,
+ Table_Initial => 16,
+ Table_Increment => 100);
+
+ function Get_Last_Source_File_Entry return Source_File_Entry is
+ begin
+ return Source_Files.Last;
+ end Get_Last_Source_File_Entry;
+
+ Home_Dir : Name_Id := Null_Identifier;
+
+ function Get_Home_Directory return Name_Id is
+ begin
+ if Home_Dir = Null_Identifier then
+ GNAT.Directory_Operations.Get_Current_Dir (Name_Buffer, Name_Length);
+ Home_Dir := Get_Identifier;
+ end if;
+ return Home_Dir;
+ end Get_Home_Directory;
+
+ procedure Location_To_File_Pos (Location : Location_Type;
+ File : out Source_File_Entry;
+ Pos : out Source_Ptr)
+ is
+ begin
+ -- FIXME: use a cache
+ -- FIXME: dicotomy
+ for I in Source_Files.First .. Source_Files.Last loop
+ declare
+ F : Source_File_Record renames Source_Files.Table (I);
+ begin
+ if Location >= F.First_Location
+ and then Location <= F.Last_Location
+ then
+ File := I;
+ Pos := Source_Ptr (Location - F.First_Location);
+ return;
+ end if;
+ end;
+ end loop;
+ -- File not found, location must be bad...
+ raise Internal_Error;
+ end Location_To_File_Pos;
+
+ function File_Pos_To_Location (File : Source_File_Entry; Pos : Source_Ptr)
+ return Location_Type
+ is
+ begin
+ if Source_Files.Table (File).Source = null then
+ raise Internal_Error;
+ else
+ return Source_Files.Table (File).First_Location + Location_Type (Pos);
+ end if;
+ end File_Pos_To_Location;
+
+ function Source_File_To_Location (File : Source_File_Entry)
+ return Location_Type
+ is
+ begin
+ return Source_Files.Table (File).First_Location;
+ end Source_File_To_Location;
+
+ procedure Reallocate_Lines_Table
+ (File: in out Source_File_Record; New_Size: Natural) is
+ use Interfaces.C;
+
+ function realloc
+ (memblock : Lines_Table_Ptr;
+ size : size_t)
+ return Lines_Table_Ptr;
+ pragma Import (C, realloc);
+
+ function malloc
+ (size : size_t)
+ return Lines_Table_Ptr;
+ pragma Import (C, malloc);
+
+ New_Table: Lines_Table_Ptr;
+ New_Byte_Size : size_t;
+ begin
+ New_Byte_Size :=
+ size_t(New_Size *
+ Lines_Table_Type'Component_Size / System.Storage_Unit);
+ if File.Lines_Table = null then
+ New_Table := malloc (New_Byte_Size);
+ else
+ New_Table := realloc (File.Lines_Table, New_Byte_Size);
+ end if;
+ if New_Table = null then
+ raise Storage_Error;
+ else
+ File.Lines_Table := New_Table;
+ File.Lines_Table (File.Lines_Table_Max + 1 .. New_Size) :=
+ (others => Source_Ptr_Bad);
+ File.Lines_Table_Max := New_Size;
+ end if;
+ end Reallocate_Lines_Table;
+
+ -- Add a new entry in the lines_table.
+ -- The new entry must be the next one after the last entry.
+ procedure File_Add_Line_Number
+ (File: Source_File_Entry; Line: Natural; Pos: Source_Ptr) is
+ Source_File: Source_File_Record renames Source_Files.Table (File);
+ begin
+ -- Just check File is not out of bounds.
+ if File > Source_Files.Last then
+ raise Internal_Error;
+ end if;
+
+ if Line = 1 then
+ -- The position of the first line is well-known.
+ if Pos /= Source_Ptr_Org then
+ raise Internal_Error;
+ end if;
+ else
+ -- The position of a non first line is not the well-known value.
+ if Pos <= Source_Ptr_Org then
+ raise Internal_Error;
+ end if;
+ -- Take care of scan backtracking.
+ if Line <= Source_File.Nbr_Lines then
+ if Source_File.Lines_Table (Line) = Source_Ptr_Bad then
+ Source_File.Lines_Table (Line) := Pos;
+ elsif Pos /= Source_File.Lines_Table (Line) then
+ Put_Line ("file" & Source_File_Entry'Image (File)
+ & " for line" & Natural'Image (Line)
+ & " pos =" & Source_Ptr'Image (Pos)
+ & ", lines_table = "
+ & Source_Ptr'Image (Source_File.Lines_Table (Line)));
+ raise Internal_Error;
+ end if;
+ return;
+ end if;
+ -- The new entry must just follow the last entry.
+-- if Line /= Source_File.Nbr_Lines + 1 then
+-- raise Internal_Error;
+-- end if;
+ end if;
+ if Line > Source_File.Lines_Table_Max then
+ Reallocate_Lines_Table (Source_File, (Line / 128 + 1) * 128);
+ end if;
+ Source_File.Lines_Table (Line) := Pos;
+ if Line > Source_File.Nbr_Lines then
+ Source_File.Nbr_Lines := Line;
+ end if;
+ -- Source_File.Nbr_Lines := Source_File.Nbr_Lines + 1;
+ if False then
+ Put_Line ("file" & Source_File_Entry'Image (File)
+ & " line" & Natural'Image (Line)
+ & " at position" & Source_Ptr'Image (Pos));
+ end if;
+ end File_Add_Line_Number;
+
+ -- Convert a physical column to a logical column.
+ -- A physical column is the offset in byte from the first byte of the line.
+ -- A logical column is the position of the character when displayed.
+ -- A HT (tabulation) moves the cursor to the next position multiple of 8.
+ -- The first character is at position 1 and at offset 0.
+ procedure Coord_To_Position
+ (File : Source_File_Entry;
+ Line_Pos : Source_Ptr;
+ Offset : Natural;
+ Name : out Name_Id;
+ Col : out Natural)
+ is
+ Source_File: Source_File_Record renames Source_Files.Table (File);
+ Res : Positive := 1;
+ begin
+ Name := Source_File.File_Name;
+ for I in Line_Pos .. Line_Pos + Source_Ptr (Offset) - 1 loop
+ if Source_File.Source (I) = Ada.Characters.Latin_1.HT then
+ Res := Res + 8 - Res mod 8;
+ else
+ Res := Res + 1;
+ end if;
+ end loop;
+ Col := Res;
+ end Coord_To_Position;
+
+ -- Should only be called by Location_To_Coord.
+ function Location_To_Line
+ (Source_File : Source_File_Record; Pos : Source_Ptr)
+ return Natural
+ is
+ Low, Hi, Mid : Natural;
+ Mid1 : Natural;
+ Lines_Table : constant Lines_Table_Ptr := Source_File.Lines_Table;
+ begin
+ -- Look in the cache.
+ if Pos >= Source_File.Cache_Pos then
+ Low := Source_File.Cache_Line;
+ Hi := Source_File.Nbr_Lines;
+ else
+ Low := 1;
+ Hi := Source_File.Cache_Line;
+ end if;
+
+ loop
+ << Again >> null;
+ Mid := (Hi + Low) / 2;
+ if Lines_Table (Mid) = Source_Ptr_Bad then
+ -- There is a hole: no position for this line.
+ -- Set MID1 to a line which has a position.
+ -- Try downward.
+ Mid1 := Mid;
+ while Lines_Table (Mid1) = Source_Ptr_Bad loop
+ -- Note: Low may have no line.
+ exit when Mid1 = Low;
+ Mid1 := Mid1 - 1;
+ end loop;
+ if Mid1 /= Low then
+ -- Mid1 has a line.
+ if Pos < Lines_Table (Mid1) then
+ Hi := Mid1;
+ goto Again;
+ end if;
+ if Pos > Lines_Table (Mid1) then
+ Low := Mid1;
+ goto Again;
+ end if;
+ -- Found, handled just below.
+ else
+ -- Failed (downward is LOW): try upward.
+ Mid1 := Mid;
+ while Lines_Table (Mid1) = Source_Ptr_Bad loop
+ Mid1 := Mid1 + 1;
+ end loop;
+ if Mid1 = Hi then
+ -- Failed: no lines between LOW and HI.
+ if Pos >= Lines_Table (Hi) then
+ Mid1 := Hi;
+ else
+ Mid1 := Low;
+ end if;
+ return Mid1;
+ end if;
+ -- Mid1 has a line.
+ if Pos < Lines_Table (Mid1) then
+ Hi := Mid1;
+ goto Again;
+ end if;
+ if Pos > Lines_Table (Mid1) then
+ Low := Mid1;
+ goto Again;
+ end if;
+ end if;
+ Mid := Mid1;
+ end if;
+ if Pos >= Lines_Table (Mid) then
+ if Mid = Source_File.Nbr_Lines
+ or else Pos < Lines_Table (Mid + 1)
+ or else Pos = Lines_Table (Mid)
+ or else (Hi <= Mid + 1
+ and Lines_Table (Mid + 1) = Source_Ptr_Bad)
+ then
+ return Mid;
+ end if;
+ end if;
+ if Pos < Lines_Table (Mid) then
+ Hi := Mid - 1;
+ else
+ if Lines_Table (Mid + 1) /= Source_Ptr_Bad then
+ Low := Mid + 1;
+ else
+ Low := Mid;
+ end if;
+ end if;
+ end loop;
+ end Location_To_Line;
+
+ procedure Location_To_Coord
+ (Source_File : in out Source_File_Record;
+ Pos : Source_Ptr;
+ Line_Pos : out Source_Ptr;
+ Line : out Natural;
+ Offset : out Natural)
+ is
+ Line_P : Source_Ptr;
+ Line_Threshold : constant Natural := 4;
+ Low, Hi : Natural;
+ begin
+ -- Look in the cache.
+ if Pos >= Source_File.Cache_Pos then
+ Low := Source_File.Cache_Line;
+ Hi := Source_File.Nbr_Lines;
+
+ -- Maybe adjust the threshold.
+ -- Quick look.
+ if Pos - Source_File.Cache_Pos <= 120
+ and then Low + Line_Threshold <= Hi
+ then
+ for I in 1 .. Line_Threshold loop
+ Line_P := Source_File.Lines_Table (Low + I);
+ if Line_P > Pos then
+ Line := Low + I - 1;
+ goto Found;
+ else
+ exit when Line_P = Source_Ptr_Bad;
+ end if;
+ end loop;
+ end if;
+ end if;
+
+ Line := Location_To_Line (Source_File, Pos);
+
+ << Found >> null;
+
+ Line_Pos := Source_File.Lines_Table (Line);
+ Offset := Natural (Pos - Source_File.Lines_Table (Line));
+
+ -- Update cache.
+ Source_File.Cache_Pos := Pos;
+ Source_File.Cache_Line := Line;
+ end Location_To_Coord;
+
+ procedure Location_To_Position
+ (Location : Location_Type;
+ Name : out Name_Id;
+ Line : out Natural;
+ Col : out Natural)
+ is
+ File : Source_File_Entry;
+ Line_Pos : Source_Ptr;
+ Offset : Natural;
+ begin
+ Location_To_Coord (Location, File, Line_Pos, Line, Offset);
+ Coord_To_Position (File, Line_Pos, Offset, Name, Col);
+ end Location_To_Position;
+
+ procedure Location_To_Coord
+ (Location : Location_Type;
+ File : out Source_File_Entry;
+ Line_Pos : out Source_Ptr;
+ Line : out Natural;
+ Offset : out Natural)
+ is
+ Pos : Source_Ptr;
+ begin
+ Location_To_File_Pos (Location, File, Pos);
+ Location_To_Coord (Source_Files.Table (File), Pos,
+ Line_Pos, Line, Offset);
+ end Location_To_Coord;
+
+ -- Convert the first digit of VAL into a character (base 10).
+ function Digit_To_Char (Val: Natural) return Character is
+ begin
+ return Character'Val (Character'Pos ('0') + Val mod 10);
+ end Digit_To_Char;
+
+ -- Format: YYYYMMDDHHmmsscc
+ -- Y: year, M: month, D: day, H: hour, m: minute, s: second, cc:100th sec
+ function Os_Time_To_Time_Stamp_Id (Time: GNAT.OS_Lib.OS_Time)
+ return Time_Stamp_Id
+ is
+ use GNAT.OS_Lib;
+ use Str_Table;
+ Res: Time_Stamp_Id;
+ Year: Year_Type;
+ Month: Month_Type;
+ Day: Day_Type;
+ Hour: Hour_Type;
+ Minute: Minute_Type;
+ Second: Second_Type;
+ begin
+ GM_Split (Time, Year, Month, Day, Hour, Minute, Second);
+ Res := Time_Stamp_Id (Start);
+ Append (Digit_To_Char (Year / 1000));
+ Append (Digit_To_Char (Year / 100));
+ Append (Digit_To_Char (Year / 10));
+ Append (Digit_To_Char (Year / 1));
+ Append (Digit_To_Char (Month / 10));
+ Append (Digit_To_Char (Month / 1));
+ Append (Digit_To_Char (Day / 10));
+ Append (Digit_To_Char (Day / 1));
+ Append (Digit_To_Char (Hour / 10));
+ Append (Digit_To_Char (Hour / 1));
+ Append (Digit_To_Char (Minute / 10));
+ Append (Digit_To_Char (Minute / 1));
+ Append (Digit_To_Char (Second / 10));
+ Append (Digit_To_Char (Second / 1));
+ Append ('.');
+ Append ('0');
+ Append ('0');
+ Append ('0');
+ Finish;
+ return Res;
+ end Os_Time_To_Time_Stamp_Id;
+
+ function Get_File_Time_Stamp (Filename : System.Address)
+ return Time_Stamp_Id
+ is
+ use GNAT.OS_Lib;
+ Fd : File_Descriptor;
+ Res : Time_Stamp_Id;
+ begin
+ Fd := Open_Read (Filename, Binary);
+ if Fd = Invalid_FD then
+ return Null_Time_Stamp;
+ end if;
+ Res := Os_Time_To_Time_Stamp_Id (File_Time_Stamp (Fd));
+ Close (Fd);
+ return Res;
+ end Get_File_Time_Stamp;
+
+ function Get_File_Time_Stamp (FD : GNAT.OS_Lib.File_Descriptor)
+ return Time_Stamp_Id
+ is
+ begin
+ return Os_Time_To_Time_Stamp_Id (GNAT.OS_Lib.File_Time_Stamp (FD));
+ end Get_File_Time_Stamp;
+
+ function Get_Os_Time_Stamp return Time_Stamp_Id
+ is
+ use Ada.Calendar;
+ use Ada.Calendar.Time_Zones;
+ use Str_Table;
+
+ Now : constant Time := Clock;
+ Now_UTC : constant Time := Now - Duration (UTC_Time_Offset (Now) * 60);
+ Year : Year_Number;
+ Month : Month_Number;
+ Day : Day_Number;
+ Sec : Day_Duration;
+ S : Integer;
+ S1 : Integer;
+ M : Integer;
+ Res: Time_Stamp_Id;
+ begin
+ -- Use UTC time (like file time stamp).
+ Split (Now_UTC, Year, Month, Day, Sec);
+
+ Res := Time_Stamp_Id (Start);
+ Append (Digit_To_Char (Year / 1000));
+ Append (Digit_To_Char (Year / 100));
+ Append (Digit_To_Char (Year / 10));
+ Append (Digit_To_Char (Year / 1));
+ Append (Digit_To_Char (Month / 10));
+ Append (Digit_To_Char (Month / 1));
+ Append (Digit_To_Char (Day / 10));
+ Append (Digit_To_Char (Day / 1));
+ S := Integer (Sec);
+ if Day_Duration (S) > Sec then
+ -- We need a truncation.
+ S := S - 1;
+ end if;
+ S1 := S / 3600;
+ Append (Digit_To_Char (S1 / 10));
+ Append (Digit_To_Char (S1));
+ S1 := (S / 60) mod 60;
+ Append (Digit_To_Char (S1 / 10));
+ Append (Digit_To_Char (S1));
+ S1 := S mod 60;
+ Append (Digit_To_Char (S1 / 10));
+ Append (Digit_To_Char (S1));
+
+ Append ('.');
+ Sec := Sec - Day_Duration (S);
+ M := Integer (Sec * 1000);
+ if M = 1000 then
+ -- We need truncation.
+ M := 999;
+ end if;
+ Append (Digit_To_Char (M / 100));
+ Append (Digit_To_Char (M / 10));
+ Append (Digit_To_Char (M));
+ Finish;
+ return Res;
+ end Get_Os_Time_Stamp;
+
+ function Get_Pathname (Directory : Name_Id;
+ Name: Name_Id;
+ Add_Nul : Boolean)
+ return String
+ is
+ L : Natural;
+ begin
+ Image (Name);
+ if not GNAT.OS_Lib.Is_Absolute_Path (Name_Buffer (1 .. Name_Length)) then
+ L := Name_Length;
+ Image (Directory);
+ Name_Buffer (Name_Length + 1 .. Name_Length + L) := Image (Name);
+ Name_Length := Name_Length + L;
+ end if;
+ if Add_Nul then
+ Name_Length := Name_Length + 1;
+ Name_Buffer (Name_Length) := Character'Val (0);
+ end if;
+ return Name_Buffer (1 .. Name_Length);
+ end Get_Pathname;
+
+ -- Find a source_file by DIRECTORY and NAME.
+ -- Return NO_SOURCE_FILE_ENTRY if not already opened.
+ function Find_Source_File (Directory : Name_Id; Name: Name_Id)
+ return Source_File_Entry
+ is
+ begin
+ for I in Source_Files.First .. Source_Files.Last loop
+ if Source_Files.Table (I).File_Name = Name
+ and then Source_Files.Table (I).Directory = Directory
+ then
+ return I;
+ end if;
+ end loop;
+ return No_Source_File_Entry;
+ end Find_Source_File;
+
+ -- Return an entry for a filename.
+ -- The file is not loaded.
+ function Create_Source_File_Entry (Directory : Name_Id; Name: Name_Id)
+ return Source_File_Entry
+ is
+ Res: Source_File_Entry;
+ begin
+ if Find_Source_File (Directory, Name) /= No_Source_File_Entry then
+ raise Internal_Error;
+ end if;
+
+ -- Create a new entry.
+ Res := Source_Files.Allocate;
+ Source_Files.Table (Res) := (First_Location => Next_Location,
+ Last_Location => Next_Location,
+ File_Name => Name,
+ Directory => Directory,
+ Time_Stamp => Null_Time_Stamp,
+ Source => null,
+ File_Length => 0,
+ Nbr_Lines => 0,
+ Lines_Table_Max => 0,
+ Lines_Table => null,
+ Cache_Pos => Source_Ptr_Org,
+ Cache_Line => 1);
+ File_Add_Line_Number (Res, 1, Source_Ptr_Org);
+ return Res;
+ end Create_Source_File_Entry;
+
+ function Create_Source_File_From_String (Name: Name_Id; Content : String)
+ return Source_File_Entry
+ is
+ Res : Source_File_Entry;
+ Buffer: File_Buffer_Acc;
+ Len : constant Source_Ptr := Source_Ptr (Content'Length);
+ begin
+ Res := Create_Source_File_Entry (Null_Identifier, Name);
+
+ Buffer := new File_Buffer
+ (Source_Ptr_Org .. Source_Ptr_Org + Len + 1);
+
+ Buffer (Source_Ptr_Org .. Source_Ptr_Org + Len - 1) :=
+ File_Buffer (Content);
+ Buffer (Source_Ptr_Org + Len) := EOT;
+ Buffer (Source_Ptr_Org + Len + 1) := EOT;
+
+ Source_Files.Table (Res).Last_Location :=
+ Next_Location + Location_Type (Len) + 1;
+ Next_Location := Source_Files.Table (Res).Last_Location + 1;
+ Source_Files.Table (Res).Source := Buffer;
+ Source_Files.Table (Res).File_Length := Natural (Len);
+
+ return Res;
+ end Create_Source_File_From_String;
+
+ function Create_Virtual_Source_File (Name: Name_Id)
+ return Source_File_Entry
+ is
+ begin
+ return Create_Source_File_From_String (Name, "");
+ end Create_Virtual_Source_File;
+
+ -- Return an entry for a filename.
+ -- Load the filename if necessary.
+ function Load_Source_File (Directory : Name_Id; Name: Name_Id)
+ return Source_File_Entry
+ is
+ use GNAT.OS_Lib;
+ Fd: File_Descriptor;
+
+ Res: Source_File_Entry;
+
+ Length: Source_Ptr;
+ Buffer: File_Buffer_Acc;
+ begin
+ -- If the file is already loaded, nothing to do!
+ Res := Find_Source_File (Directory, Name);
+ if Res /= No_Source_File_Entry then
+ if Source_Files.Table (Res).Source = null then
+ raise Internal_Error;
+ end if;
+ return Res;
+ end if;
+
+ -- Open the file (punt on non regular files).
+ declare
+ Filename : String := Get_Pathname (Directory, Name, True);
+ begin
+ if not Is_Regular_File(Filename) then
+ return No_Source_File_Entry;
+ end if;
+ Fd := Open_Read (Filename'Address, Binary);
+ if Fd = Invalid_FD then
+ return No_Source_File_Entry;
+ end if;
+ end;
+
+ Res := Create_Source_File_Entry (Directory, Name);
+
+ Source_Files.Table (Res).Time_Stamp := Get_File_Time_Stamp (Fd);
+
+ Length := Source_Ptr (File_Length (Fd));
+
+ Buffer :=
+ new File_Buffer (Source_Ptr_Org .. Source_Ptr_Org + Length + 1);
+
+ if Read (Fd, Buffer (Source_Ptr_Org)'Address, Integer (Length))
+ /= Integer (Length)
+ then
+ Close (Fd);
+ raise Internal_Error;
+ end if;
+ Buffer (Length) := EOT;
+ Buffer (Length + 1) := EOT;
+
+ if Source_Files.Table (Res).First_Location /= Next_Location then
+ -- Load_Source_File call must follow its Create_Source_File.
+ raise Internal_Error;
+ end if;
+
+ Source_Files.Table (Res).Last_Location :=
+ Next_Location + Location_Type (Length) + 1;
+ Next_Location := Source_Files.Table (Res).Last_Location + 1;
+ Source_Files.Table (Res).Source := Buffer;
+ Source_Files.Table (Res).File_Length := Integer (Length);
+
+ Close (Fd);
+
+ return Res;
+ end Load_Source_File;
+
+ -- Check validity of FILE.
+ -- Raise an exception in case of error.
+ procedure Check_File (File: in Source_File_Entry) is
+ begin
+ if File > Source_Files.Last then
+ raise Internal_Error;
+ end if;
+ end Check_File;
+
+ -- Return a buffer (access to the contents of the file) for a file entry.
+ function Get_File_Source (File: Source_File_Entry)
+ return File_Buffer_Acc is
+ begin
+ Check_File (File);
+ return Source_Files.Table (File).Source;
+ end Get_File_Source;
+
+ -- Return the length of the file (which is the size of the file buffer).
+ function Get_File_Length (File: Source_File_Entry) return Source_Ptr is
+ begin
+ Check_File (File);
+ return Source_Ptr (Source_Files.Table (File).File_Length);
+ end Get_File_Length;
+
+ -- Return the name of the file.
+ function Get_File_Name (File: Source_File_Entry) return Name_Id is
+ begin
+ Check_File (File);
+ return Source_Files.Table (File).File_Name;
+ end Get_File_Name;
+
+ -- Return the date of the file (last modification date) as a string.
+ function Get_File_Time_Stamp (File: Source_File_Entry)
+ return Time_Stamp_Id is
+ begin
+ Check_File (File);
+ return Source_Files.Table (File).Time_Stamp;
+ end Get_File_Time_Stamp;
+
+ function Get_Source_File_Directory (File : Source_File_Entry)
+ return Name_Id is
+ begin
+ Check_File (File);
+ return Source_Files.Table (File).Directory;
+ end Get_Source_File_Directory;
+
+ function Line_To_Position (File : Source_File_Entry; Line : Natural)
+ return Source_Ptr
+ is
+ begin
+ Check_File (File);
+ if Line > Source_Files.Table (File).Nbr_Lines then
+ return Source_Ptr_Bad;
+ else
+ return Source_Files.Table (File).Lines_Table (Line);
+ end if;
+ end Line_To_Position;
+
+ function Is_Eq (L : Time_Stamp_Id; R : Time_Stamp_Id) return Boolean
+ is
+ use Str_Table;
+ L_Str : constant String_Fat_Acc := Get_String_Fat_Acc (String_Id (L));
+ R_Str : constant String_Fat_Acc := Get_String_Fat_Acc (String_Id (R));
+ begin
+ return L_Str (1 .. Time_Stamp_String'Length)
+ = R_Str (1 .. Time_Stamp_String'Length);
+ end Is_Eq;
+
+ function Is_Gt (L : Time_Stamp_Id; R : Time_Stamp_Id) return Boolean
+ is
+ use Str_Table;
+ L_Str : constant String_Fat_Acc := Get_String_Fat_Acc (String_Id (L));
+ R_Str : constant String_Fat_Acc := Get_String_Fat_Acc (String_Id (R));
+ begin
+ return L_Str (1 .. Time_Stamp_String'Length)
+ > R_Str (1 .. Time_Stamp_String'Length);
+ end Is_Gt;
+
+ function Get_Time_Stamp_String (Ts : Time_Stamp_Id) return String is
+ begin
+ if Ts = Null_Time_Stamp then
+ return "NULL_TS";
+ else
+ return String (Str_Table.Get_String_Fat_Acc (String_Id (Ts))
+ (1 .. Time_Stamp_String'Length));
+ end if;
+ end Get_Time_Stamp_String;
+
+ -- Debug procedures.
+ procedure Debug_Source_Lines (File: Source_File_Entry);
+ pragma Unreferenced (Debug_Source_Lines);
+
+ procedure Debug_Source_File;
+ pragma Unreferenced (Debug_Source_File);
+
+ -- Disp sources lines of a file.
+ procedure Debug_Source_Lines (File: Source_File_Entry) is
+ Source_File: Source_File_Record renames Source_Files.Table (File);
+ begin
+ Check_File (File);
+ for I in Positive'First .. Source_File.Nbr_Lines loop
+ Put_Line ("line" & Natural'Image (I) & " at offset"
+ & Source_Ptr'Image (Source_File.Lines_Table (I)));
+ end loop;
+ end Debug_Source_Lines;
+
+ procedure Debug_Source_File is
+ begin
+ for I in Source_Files.First .. Source_Files.Last loop
+ declare
+ F : Source_File_Record renames Source_Files.Table(I);
+ begin
+ Put ("file" & Source_File_Entry'Image (I));
+ Put (" name: " & Image (F.File_Name));
+ Put (" dir:" & Image (F.Directory));
+ Put (" length:" & Natural'Image (F.File_Length));
+ New_Line;
+ if F.Time_Stamp /= Null_Time_Stamp then
+ Put (" time_stamp: " & Get_Time_Stamp_String (F.Time_Stamp));
+ end if;
+ Put (" nbr lines:" & Natural'Image (F.Nbr_Lines));
+ Put (" lines_table_max:" & Natural'Image (F.Lines_Table_Max));
+ New_Line;
+ end;
+ end loop;
+ end Debug_Source_File;
+
+ procedure Initialize
+ is
+ procedure free (Ptr : Lines_Table_Ptr);
+ pragma Import (C, free);
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (File_Buffer, File_Buffer_Acc);
+ begin
+ for I in Source_Files.First .. Source_Files.Last loop
+ free (Source_Files.Table (I).Lines_Table);
+ Free (Source_Files.Table (I).Source);
+ end loop;
+ Source_Files.Free;
+ Source_Files.Init;
+ end Initialize;
+end Files_Map;
diff --git a/src/files_map.ads b/src/files_map.ads
new file mode 100644
index 000000000..c360995c3
--- /dev/null
+++ b/src/files_map.ads
@@ -0,0 +1,152 @@
+-- Loading of source files.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with System;
+
+package Files_Map is
+
+ -- Source file handling
+ -----------------------
+
+ -- Create the path from DIRECTORY and NAME:
+ -- If NAME is an absolute pathname, then return NAME.
+ -- Otherwise, return the concatenation of DIRECTORY and NAME.
+ -- If ADD_NUL is TRUE, then a trailing '\0' is appended.
+ function Get_Pathname (Directory : Name_Id;
+ Name: Name_Id;
+ Add_Nul : Boolean)
+ return String;
+
+ -- Return an entry for a filename.
+ -- Load the filename if necessary.
+ -- Return No_Source_File_Entry if the file does not exist.
+ function Load_Source_File (Directory : Name_Id; Name: Name_Id)
+ return Source_File_Entry;
+
+ -- Each file in memory has two terminal EOT.
+ EOT : constant Character := Character'Val (4);
+
+ -- Create a Source_File for a virtual file name. Used for implicit,
+ -- command-line and std.standard library.
+ function Create_Virtual_Source_File (Name: Name_Id)
+ return Source_File_Entry;
+
+ -- Create a Source_File for a possible virtual file NAME using CONTENT
+ -- as content of the file. The file must not already exist.
+ function Create_Source_File_From_String (Name: Name_Id; Content : String)
+ return Source_File_Entry;
+
+ -- Return a buffer (access to the contents of the file) for a file entry.
+ function Get_File_Source (File: Source_File_Entry)
+ return File_Buffer_Acc;
+
+ -- Return the length of the file (which is the size of the file buffer).
+ function Get_File_Length (File: Source_File_Entry) return Source_Ptr;
+
+ -- Return the entry of the last known file.
+ -- This allow the user to create a table of Source_File_Entry.
+ function Get_Last_Source_File_Entry return Source_File_Entry;
+
+ -- Time stamp handling.
+ function Is_Eq (L : Time_Stamp_Id; R : Time_Stamp_Id) return Boolean;
+ function Is_Gt (L : Time_Stamp_Id; R : Time_Stamp_Id) return Boolean;
+ function Get_Time_Stamp_String (Ts : Time_Stamp_Id) return String;
+
+ -- Return the date of the file (last modification date) as a string.
+ function Get_File_Time_Stamp (File: Source_File_Entry)
+ return Time_Stamp_Id;
+ function Get_File_Time_Stamp (Filename : System.Address)
+ return Time_Stamp_Id;
+
+ -- Return the current date of the system.
+ function Get_Os_Time_Stamp return Time_Stamp_Id;
+
+ -- Return the home directory (current directory).
+ function Get_Home_Directory return Name_Id;
+
+ -- Return the directory of the file.
+ function Get_Source_File_Directory (File : Source_File_Entry)
+ return Name_Id;
+
+ -- Return the name of the file.
+ function Get_File_Name (File: Source_File_Entry) return Name_Id;
+
+ -- Get the path of directory DIR.
+ --function Get_Directory_Path (Dir : Directory_Index) return String;
+
+ -- Add a new entry in the lines_table.
+ -- The new entry must be the next one after the last entry.
+ procedure File_Add_Line_Number
+ (File: Source_File_Entry; Line: Natural; Pos: Source_Ptr);
+
+ -- Convert LOCATION into a source file FILE and an offset POS in the
+ -- file.
+ procedure Location_To_File_Pos (Location : Location_Type;
+ File : out Source_File_Entry;
+ Pos : out Source_Ptr);
+ -- Convert a FILE and an offset POS in the file into a location.
+ function File_Pos_To_Location (File : Source_File_Entry; Pos : Source_Ptr)
+ return Location_Type;
+ -- Convert a FILE into a location.
+ function Source_File_To_Location (File : Source_File_Entry)
+ return Location_Type;
+
+ -- Convert a FILE+LINE into a position.
+ -- Return Source_Ptr_Bad in case of error (LINE out of bounds).
+ function Line_To_Position (File : Source_File_Entry; Line : Natural)
+ return Source_Ptr;
+
+ -- Translate LOCATION into coordinate (physical position).
+ -- FILE identifies the filename.
+ -- LINE_POS is the offset in the file of the first character of the line,
+ -- LINE is the line number (first line is 1),
+ -- OFFSET is the offset of the location in the line (first character is 0,
+ -- a tabulation is one character),
+ procedure Location_To_Coord
+ (Location : Location_Type;
+ File : out Source_File_Entry;
+ Line_Pos : out Source_Ptr;
+ Line : out Natural;
+ Offset : out Natural);
+
+ -- Translate coordinate into logical position.
+ -- NAME is the name of the file,
+ -- COL is the column (first character is 1, tabulation are at every 8
+ -- positions).
+ procedure Coord_To_Position
+ (File : Source_File_Entry;
+ Line_Pos : Source_Ptr;
+ Offset : Natural;
+ Name : out Name_Id;
+ Col : out Natural);
+
+ -- Translate LOCATION to NAME, LINE and COL.
+ -- It is like to two procedures above.
+ procedure Location_To_Position
+ (Location : Location_Type;
+ Name : out Name_Id;
+ Line : out Natural;
+ Col : out Natural);
+
+ -- Get LINE and COL from LOCATION.
+ --procedure Get_Source_File_Line_And_Column
+ -- (Location: Location_Type; Line, Col: out Natural; Name : out Name_Id);
+
+ -- Free all memory and reinitialize.
+ procedure Initialize;
+end Files_Map;
diff --git a/src/flags.adb b/src/flags.adb
new file mode 100644
index 000000000..fc00368a5
--- /dev/null
+++ b/src/flags.adb
@@ -0,0 +1,53 @@
+-- Global flags.
+-- Copyright (C) 2002, 2003, 2004, 2005, 2008 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package body Flags is
+ procedure Create_Flag_String is
+ begin
+ case Vhdl_Std is
+ when Vhdl_87 =>
+ Flag_String (1 .. 2) := "87";
+ when Vhdl_93c
+ | Vhdl_93
+ | Vhdl_00
+ | Vhdl_02 =>
+ Flag_String (1 .. 2) := "93";
+ when Vhdl_08 =>
+ Flag_String (1 .. 2) := "08";
+ end case;
+ if Flag_Integer_64 then
+ Flag_String (3) := 'I';
+ else
+ Flag_String (3) := 'i';
+ end if;
+ if Flag_Time_64 then
+ Flag_String (4) := 'T';
+ else
+ Flag_String (4) := 't';
+ end if;
+ if not Flag_Time_64 and Vhdl_Std = Vhdl_87 then
+ Flag_String (5) := Time_Resolution;
+ else
+ if Flag_Time_64 then
+ Flag_String (5) := '-';
+ else
+ Flag_String (5) := '?';
+ end if;
+ end if;
+ end Create_Flag_String;
+end Flags;
diff --git a/src/flags.ads b/src/flags.ads
new file mode 100644
index 000000000..03e9fe959
--- /dev/null
+++ b/src/flags.ads
@@ -0,0 +1,190 @@
+-- Global flags.
+-- Copyright (C) 2002, 2003, 2004, 2005, 2008 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+-- All the variables declared in this package are set by Parse_Option function
+-- and can by read as soon as the command line is parsed.
+--
+-- Since the names are not prefixed, this package is expected to be with'ed
+-- but not to be use'd.
+
+package Flags is
+ -- List of vhdl standards.
+ -- VHDL_93c is vhdl_93 with backward compatibility with 87 (file).
+ type Vhdl_Std_Type is
+ (Vhdl_87, Vhdl_93c, Vhdl_93, Vhdl_00, Vhdl_02, Vhdl_08);
+
+ -- Standard accepted.
+ Vhdl_Std: Vhdl_Std_Type := Vhdl_93c;
+
+ -- Enable AMS-VHDL extensions.
+ AMS_Vhdl : Boolean := False;
+
+ -- Some flags (such as vhdl version) must be the same for every design
+ -- units of a hierarchy.
+ -- The Flag_String is a signature of all these flags.
+ Flag_String : String (1 .. 5);
+ procedure Create_Flag_String;
+
+ -- If set, a multi-bytes sequence can appear in a comment, ie, all
+ -- characters except VT, CR, LF and FF are allowed in a comment.
+ -- Set by -C and --mb-comments
+ Mb_Comment: Boolean := False;
+
+ -- If set, relax rules about std library: working library can be std.
+ Bootstrap : Boolean := False;
+
+ -- Options -dX
+ -- -dp: disp tree after parsing
+ Dump_Parse: Boolean := False;
+
+ -- -ds: disp tree after semantic
+ Dump_Sem: Boolean := False;
+
+ -- -dc: disp tree after canon
+ Dump_Canon : Boolean := False;
+
+ -- -da: disp tree after annotation
+ Dump_Annotate: Boolean := False;
+
+ -- --dall: makes -dX options to apply to all files.
+ Dump_All: Boolean := False;
+
+ -- -dstats: disp statistics.
+ Dump_Stats : Boolean := False;
+
+ -- -lX options: list tree as a vhdl file.
+
+ -- --lall option: makes -lX options to apply to all files
+ List_All: Boolean := False;
+
+ -- -lv: list verbose
+ List_Verbose: Boolean := False;
+
+ -- -ls: list tree after semantic.
+ List_Sem: Boolean := False;
+
+ -- -lc: list tree after canon.
+ List_Canon: Boolean := False;
+
+ -- -la: list tree after back-end annotation.
+ List_Annotate: Boolean := False;
+
+ -- -v: disp phase of compilation.
+ Verbose : Boolean := False;
+
+ -- If set to true, it means that analyze is done for elaboration.
+ -- The purpose is to avoid spurious warning "will be checked
+ -- at elaboration"
+ Flag_Elaborate : Boolean := False;
+
+ -- If set, a default aspect entity aspect might be an outdated unit.
+ -- Used by ghdldrv.
+ Flag_Elaborate_With_Outdated : Boolean := False;
+
+ -- Do not display parse and sem warnings. Used during elaboration.
+ Flag_Only_Elab_Warnings : Boolean := False;
+
+ -- If set, explicit subprogram declarations take precedence over
+ -- implicit declarations, even through use clauses.
+ Flag_Explicit : Boolean := False;
+
+ -- If set, use 'L.C' rule from VHDL02 to do default component binding.
+ Flag_Syn_Binding : Boolean := False;
+
+ -- If set, performs VITAL checks.
+ Flag_Vital_Checks : Boolean := True;
+
+ -- --time-resolution=X
+ -- Where X corresponds to:
+ -- fs => 'f'
+ -- ps => 'p'
+ -- ns => 'n'
+ -- us => 'u'
+ -- ms => 'm'
+ -- sec => 's'
+ -- min => 'M'
+ -- hr => 'h'
+ Time_Resolution: Character := 'f';
+
+ -- Integer and time types can be either 32 bits or 64 bits values.
+ -- The default is 32 bits for Integer and 64 bits for Time.
+ -- Be very careful: if you don't use the default sizes, you may have to
+ -- change other parts of your systems (such as GRT).
+ Flag_Integer_64 : Boolean := False;
+ Flag_Time_64 : Boolean := True;
+
+ -- If set, generate cross-references during sem.
+ Flag_Xref : Boolean := False;
+
+ -- If set, all the design units are analyzed in whole to do the simulation.
+ Flag_Whole_Analyze : Boolean := False;
+
+ -- If true, relax some rules:
+ -- * the scope of an object declaration names start after the declaration,
+ -- so that it is possible to use the old name in the default expression:
+ -- constant x : xtype := x;
+ Flag_Relaxed_Rules : Boolean := False;
+
+ -- --warn-undriven
+ --Warn_Undriven : Boolean := False;
+
+ -- --warn-default-binding
+ -- Should emit a warning when there is no default binding for a component
+ -- instantiation.
+ Warn_Default_Binding : Boolean := False;
+
+ -- --warn-binding
+ -- Emit a warning at elaboration for unbound component.
+ Warn_Binding : Boolean := True;
+
+ -- --warn-reserved
+ -- Emit a warning when a vhdl93 reserved word is used as a
+ -- vhdl87 identifier.
+ Warn_Reserved_Word : Boolean := False;
+
+ -- --warn-library
+ -- Emit a warning when a design unit redefines another design unit.
+ Warn_Library : Boolean := False;
+
+ -- --warn-vital-generic
+ -- Emit a warning when a generic of a vital entity is not a vital name.
+ Warn_Vital_Generic : Boolean := True;
+
+ -- --warn-delayed-checks
+ -- Emit warnings about delayed checks (checks performed at elaboration
+ -- time).
+ Warn_Delayed_Checks : Boolean := False;
+
+ -- --warn-body
+ -- Emit a warning when a package body is not required but is analyzed.
+ Warn_Body : Boolean := True;
+
+ -- --warn-specs
+ -- Emit a warning when an all/others specification does not apply, because
+ -- there is no such named entities.
+ Warn_Specs : Boolean := True;
+
+ -- --warn-unused
+ -- Emit a warning when a declaration is never used.
+ -- FIXME: currently only subprograms are handled.
+ Warn_Unused : Boolean := True;
+
+ -- --warn-error
+ -- Turns warnings into errors.
+ Warn_Error : Boolean := False;
+end Flags;
diff --git a/src/ieee-std_logic_1164.adb b/src/ieee-std_logic_1164.adb
new file mode 100644
index 000000000..ee58fe7a5
--- /dev/null
+++ b/src/ieee-std_logic_1164.adb
@@ -0,0 +1,170 @@
+-- Nodes recognizer for ieee.std_logic_1164.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with Std_Names; use Std_Names;
+with Errorout; use Errorout;
+with Std_Package;
+
+package body Ieee.Std_Logic_1164 is
+ function Skip_Implicit (Decl : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Decl;
+ loop
+ exit when Res = Null_Iir;
+ exit when Get_Kind (Res) /= Iir_Kind_Implicit_Function_Declaration;
+ Res := Get_Chain (Res);
+ end loop;
+ return Res;
+ end Skip_Implicit;
+
+ procedure Extract_Declarations (Pkg : Iir_Package_Declaration)
+ is
+ Error : exception;
+
+ Decl : Iir;
+ Def : Iir;
+ begin
+ Std_Logic_1164_Pkg := Pkg;
+
+ Decl := Get_Declaration_Chain (Pkg);
+
+ -- Skip a potential copyright constant.
+ if Decl /= Null_Iir
+ and then Get_Kind (Decl) = Iir_Kind_Constant_Declaration
+ and then (Get_Base_Type (Get_Type (Decl))
+ = Std_Package.String_Type_Definition)
+ then
+ Decl := Get_Chain (Decl);
+ end if;
+
+ -- The first declaration should be type std_ulogic.
+ if Decl = Null_Iir
+ or else Get_Kind (Decl) /= Iir_Kind_Type_Declaration
+ or else Get_Identifier (Decl) /= Name_Std_Ulogic
+ then
+ raise Error;
+ end if;
+
+ Def := Get_Type_Definition (Decl);
+ if Get_Kind (Def) /= Iir_Kind_Enumeration_Type_Definition then
+ raise Error;
+ end if;
+ Std_Ulogic_Type := Def;
+
+ -- The second declaration should be std_ulogic_vector.
+ Decl := Get_Chain (Decl);
+ Decl := Skip_Implicit (Decl);
+ if Decl = Null_Iir
+ or else Get_Kind (Decl) /= Iir_Kind_Type_Declaration
+ or else Get_Identifier (Decl) /= Name_Std_Ulogic_Vector
+ then
+ raise Error;
+ end if;
+ Def := Get_Type_Definition (Decl);
+ if Get_Kind (Def) /= Iir_Kind_Array_Type_Definition then
+ raise Error;
+ end if;
+ Std_Ulogic_Vector_Type := Def;
+
+ -- The third declaration should be resolved.
+ Decl := Get_Chain (Decl);
+ Decl := Skip_Implicit (Decl);
+ if Decl = Null_Iir
+ or else Get_Kind (Decl) /= Iir_Kind_Function_Declaration
+ then
+ -- FIXME: check name ?
+ raise Error;
+ end if;
+ Resolved := Decl;
+
+ -- The fourth declaration should be std_logic.
+ Decl := Get_Chain (Decl);
+ Decl := Skip_Implicit (Decl);
+ if Decl = Null_Iir
+ or else Get_Kind (Decl) /= Iir_Kind_Subtype_Declaration
+ or else Get_Identifier (Decl) /= Name_Std_Logic
+ then
+ raise Error;
+ end if;
+ Def := Get_Type (Decl);
+ if Get_Kind (Def) /= Iir_Kind_Enumeration_Subtype_Definition then
+ raise Error;
+ end if;
+ Std_Logic_Type := Def;
+
+ -- The fifth declaration should be std_logic_vector.
+ Decl := Get_Chain (Decl);
+ Decl := Skip_Implicit (Decl);
+ if Decl = Null_Iir
+ or else (Get_Kind (Decl) /= Iir_Kind_Type_Declaration
+ and then Get_Kind (Decl) /= Iir_Kind_Subtype_Declaration)
+ or else Get_Identifier (Decl) /= Name_Std_Logic_Vector
+ then
+ raise Error;
+ end if;
+ Def := Get_Type (Decl);
+-- if Get_Kind (Def) /= Iir_Kind_Array_Type_Definition then
+-- raise Error;
+-- end if;
+ Std_Logic_Vector_Type := Def;
+
+ -- Skip any declarations but functions.
+ loop
+ Decl := Get_Chain (Decl);
+ exit when Decl = Null_Iir;
+
+ if Get_Kind (Decl) = Iir_Kind_Function_Declaration then
+ if Get_Identifier (Decl) = Name_Rising_Edge then
+ Rising_Edge := Decl;
+ elsif Get_Identifier (Decl) = Name_Falling_Edge then
+ Falling_Edge := Decl;
+ end if;
+ end if;
+ end loop;
+
+ -- Since rising_edge and falling_edge do not read activity of its
+ -- parameter, clear the flag to allow more optimizations.
+ if Rising_Edge /= Null_Iir then
+ Set_Has_Active_Flag
+ (Get_Interface_Declaration_Chain (Rising_Edge), False);
+ else
+ raise Error;
+ end if;
+ if Falling_Edge /= Null_Iir then
+ Set_Has_Active_Flag
+ (Get_Interface_Declaration_Chain (Falling_Edge), False);
+ else
+ raise Error;
+ end if;
+
+ exception
+ when Error =>
+ Error_Msg_Sem ("package ieee.std_logic_1164 is ill-formed", Pkg);
+
+ -- Clear all definitions.
+ Std_Logic_1164_Pkg := Null_Iir;
+ Std_Ulogic_Type := Null_Iir;
+ Std_Ulogic_Vector_Type := Null_Iir;
+ Std_Logic_Type := Null_Iir;
+ Std_Logic_Vector_Type := Null_Iir;
+ Rising_Edge := Null_Iir;
+ Falling_Edge := Null_Iir;
+ end Extract_Declarations;
+end Ieee.Std_Logic_1164;
diff --git a/src/ieee-std_logic_1164.ads b/src/ieee-std_logic_1164.ads
new file mode 100644
index 000000000..b1f14f272
--- /dev/null
+++ b/src/ieee-std_logic_1164.ads
@@ -0,0 +1,35 @@
+-- Nodes recognizer for ieee.std_logic_1164.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Iirs; use Iirs;
+
+package Ieee.Std_Logic_1164 is
+ -- Nodes corresponding to declarations in the package.
+ Std_Logic_1164_Pkg : Iir_Package_Declaration := Null_Iir;
+ Std_Ulogic_Type : Iir_Enumeration_Type_Definition := Null_Iir;
+ Std_Ulogic_Vector_Type : Iir_Array_Type_Definition := Null_Iir;
+ Std_Logic_Type : Iir_Enumeration_Subtype_Definition := Null_Iir;
+ Std_Logic_Vector_Type : Iir_Array_Type_Definition := Null_Iir;
+ Resolved : Iir_Function_Declaration := Null_Iir;
+ Rising_Edge : Iir_Function_Declaration := Null_Iir;
+ Falling_Edge : Iir_Function_Declaration := Null_Iir;
+
+ -- Extract declarations from PKG.
+ -- PKG is the package declaration for ieee.std_logic_1164 package.
+ -- Fills the node aboves.
+ procedure Extract_Declarations (Pkg : Iir_Package_Declaration);
+end Ieee.Std_Logic_1164;
diff --git a/src/ieee-vital_timing.adb b/src/ieee-vital_timing.adb
new file mode 100644
index 000000000..d6429e251
--- /dev/null
+++ b/src/ieee-vital_timing.adb
@@ -0,0 +1,1377 @@
+-- Nodes recognizer for ieee.vital_timing.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with Std_Names;
+with Errorout; use Errorout;
+with Std_Package; use Std_Package;
+with Tokens; use Tokens;
+with Name_Table;
+with Ieee.Std_Logic_1164; use Ieee.Std_Logic_1164;
+with Sem_Scopes;
+with Evaluation;
+with Sem;
+with Iirs_Utils;
+with Flags;
+
+package body Ieee.Vital_Timing is
+ -- This package is based on IEEE 1076.4 1995.
+
+ -- Control generics identifier.
+ InstancePath_Id : Name_Id;
+ TimingChecksOn_Id : Name_Id;
+ XOn_Id : Name_Id;
+ MsgOn_Id : Name_Id;
+
+ -- Extract declarations from package IEEE.VITAL_Timing.
+ procedure Extract_Declarations (Pkg : Iir_Package_Declaration)
+ is
+ use Name_Table;
+
+ Ill_Formed : exception;
+
+ Decl : Iir;
+ Id : Name_Id;
+
+ VitalDelayType_Id : Name_Id;
+ VitalDelayType01_Id : Name_Id;
+ VitalDelayType01Z_Id : Name_Id;
+ VitalDelayType01ZX_Id : Name_Id;
+
+ VitalDelayArrayType_Id : Name_Id;
+ VitalDelayArrayType01_Id : Name_Id;
+ VitalDelayArrayType01Z_Id : Name_Id;
+ VitalDelayArrayType01ZX_Id : Name_Id;
+ begin
+ -- Get Vital delay type identifiers.
+ Name_Buffer (1 .. 18) := "vitaldelaytype01zx";
+ Name_Length := 14;
+ VitalDelayType_Id := Get_Identifier_No_Create;
+ if VitalDelayType_Id = Null_Identifier then
+ raise Ill_Formed;
+ end if;
+ Name_Length := 16;
+ VitalDelayType01_Id := Get_Identifier_No_Create;
+ if VitalDelayType01_Id = Null_Identifier then
+ raise Ill_Formed;
+ end if;
+ Name_Length := 17;
+ VitalDelayType01Z_Id := Get_Identifier_No_Create;
+ if VitalDelayType01Z_Id = Null_Identifier then
+ raise Ill_Formed;
+ end if;
+ Name_Length := 18;
+ VitalDelayType01ZX_Id := Get_Identifier_No_Create;
+ if VitalDelayType01ZX_Id = Null_Identifier then
+ raise Ill_Formed;
+ end if;
+
+ Name_Buffer (1 .. 23) := "vitaldelayarraytype01zx";
+ Name_Length := 19;
+ VitalDelayArrayType_Id := Get_Identifier_No_Create;
+ if VitalDelayArrayType_Id = Null_Identifier then
+ raise Ill_Formed;
+ end if;
+ Name_Length := 21;
+ VitalDelayArrayType01_Id := Get_Identifier_No_Create;
+ if VitalDelayArrayType01_Id = Null_Identifier then
+ raise Ill_Formed;
+ end if;
+ Name_Length := 22;
+ VitalDelayArrayType01Z_Id := Get_Identifier_No_Create;
+ if VitalDelayArrayType01Z_Id = Null_Identifier then
+ raise Ill_Formed;
+ end if;
+ Name_Length := 23;
+ VitalDelayArrayType01ZX_Id := Get_Identifier_No_Create;
+ if VitalDelayArrayType01ZX_Id = Null_Identifier then
+ raise Ill_Formed;
+ end if;
+
+ -- Iterate on every declaration.
+ -- Do name-matching.
+ Decl := Get_Declaration_Chain (Pkg);
+ while Decl /= Null_Iir loop
+ case Get_Kind (Decl) is
+ when Iir_Kind_Attribute_Declaration =>
+ Id := Get_Identifier (Decl);
+ if Id = Std_Names.Name_VITAL_Level0 then
+ Vital_Level0_Attribute := Decl;
+ elsif Id = Std_Names.Name_VITAL_Level1 then
+ Vital_Level1_Attribute := Decl;
+ end if;
+ when Iir_Kind_Subtype_Declaration =>
+ Id := Get_Identifier (Decl);
+ if Id = VitalDelayType_Id then
+ VitalDelayType := Get_Type (Decl);
+ end if;
+ when Iir_Kind_Type_Declaration =>
+ Id := Get_Identifier (Decl);
+ if Id = VitalDelayArrayType_Id then
+ VitalDelayArrayType := Get_Type_Definition (Decl);
+ elsif Id = VitalDelayArrayType01_Id then
+ VitalDelayArrayType01 := Get_Type_Definition (Decl);
+ elsif Id = VitalDelayArrayType01Z_Id then
+ VitalDelayArrayType01Z := Get_Type_Definition (Decl);
+ elsif Id = VitalDelayArrayType01ZX_Id then
+ VitalDelayArrayType01ZX := Get_Type_Definition (Decl);
+ end if;
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ Id := Get_Identifier (Decl);
+ if Id = VitalDelayType01_Id then
+ VitalDelayType01 := Get_Type_Definition (Decl);
+ elsif Id = VitalDelayType01Z_Id then
+ VitalDelayType01Z := Get_Type_Definition (Decl);
+ elsif Id = VitalDelayType01ZX_Id then
+ VitalDelayType01ZX := Get_Type_Definition (Decl);
+ end if;
+ when others =>
+ null;
+ end case;
+ Decl := Get_Chain (Decl);
+ end loop;
+
+ -- If a declaration was not found, then the package is not the expected
+ -- one.
+ if Vital_Level0_Attribute = Null_Iir
+ or Vital_Level1_Attribute = Null_Iir
+ or VitalDelayType = Null_Iir
+ or VitalDelayType01 = Null_Iir
+ or VitalDelayType01Z = Null_Iir
+ or VitalDelayType01ZX = Null_Iir
+ or VitalDelayArrayType = Null_Iir
+ or VitalDelayArrayType01 = Null_Iir
+ or VitalDelayArrayType01Z = Null_Iir
+ or VitalDelayArrayType01ZX = Null_Iir
+ then
+ raise Ill_Formed;
+ end if;
+
+ -- Create identifier for control generics.
+ InstancePath_Id := Get_Identifier ("instancepath");
+ TimingChecksOn_Id := Get_Identifier ("timingcheckson");
+ XOn_Id := Get_Identifier ("xon");
+ MsgOn_Id := Get_Identifier ("msgon");
+
+ exception
+ when Ill_Formed =>
+ Error_Msg_Sem ("package ieee.vital_timing is ill-formed", Pkg);
+
+ Vital_Level0_Attribute := Null_Iir;
+ Vital_Level1_Attribute := Null_Iir;
+
+ VitalDelayType := Null_Iir;
+ VitalDelayType01 := Null_Iir;
+ VitalDelayType01Z := Null_Iir;
+ VitalDelayType01ZX := Null_Iir;
+
+ VitalDelayArrayType := Null_Iir;
+ VitalDelayArrayType01 := Null_Iir;
+ VitalDelayArrayType01Z := Null_Iir;
+ VitalDelayArrayType01ZX := Null_Iir;
+ end Extract_Declarations;
+
+ procedure Error_Vital (Msg : String; Loc : Iir) renames Error_Msg_Sem;
+ procedure Error_Vital (Msg : String; Loc : Location_Type)
+ renames Error_Msg_Sem;
+ procedure Warning_Vital (Msg : String; Loc : Iir) renames Warning_Msg_Sem;
+
+ -- Check DECL is the VITAL level 0 attribute specification.
+ procedure Check_Level0_Attribute_Specification (Decl : Iir)
+ is
+ Expr : Iir;
+ begin
+ if Get_Kind (Decl) /= Iir_Kind_Attribute_Specification
+ or else (Get_Named_Entity (Get_Attribute_Designator (Decl))
+ /= Vital_Level0_Attribute)
+ then
+ Error_Vital
+ ("first declaration must be the VITAL attribute specification",
+ Decl);
+ return;
+ end if;
+
+ -- IEEE 1076.4 4.1
+ -- The expression in the VITAL_Level0 attribute specification shall be
+ -- the Boolean literal TRUE.
+ Expr := Get_Expression (Decl);
+ if Get_Kind (Expr) not in Iir_Kinds_Denoting_Name
+ or else Get_Named_Entity (Expr) /= Boolean_True
+ then
+ Error_Vital
+ ("the expression in the VITAL_Level0 attribute specification shall "
+ & "be the Boolean literal TRUE", Decl);
+ end if;
+
+ -- IEEE 1076.4 4.1
+ -- The entity specification of the decorating attribute specification
+ -- shall be such that the enclosing entity or architecture inherits the
+ -- VITAL_Level0 attribute.
+ case Get_Entity_Class (Decl) is
+ when Tok_Entity
+ | Tok_Architecture =>
+ null;
+ when others =>
+ Error_Vital ("VITAL attribute specification does not decorate the "
+ & "enclosing entity or architecture", Decl);
+ end case;
+ end Check_Level0_Attribute_Specification;
+
+ procedure Check_Entity_Port_Declaration
+ (Decl : Iir_Interface_Signal_Declaration)
+ is
+ use Name_Table;
+
+ Atype : Iir;
+ Base_Type : Iir;
+ Type_Decl : Iir;
+ begin
+ -- IEEE 1076.4 4.3.1
+ -- The identifiers in an entity port declaration shall not contain
+ -- underscore characters.
+ Image (Get_Identifier (Decl));
+ if Name_Buffer (1) = '/' then
+ Error_Vital ("VITAL entity port shall not be an extended identifier",
+ Decl);
+ end if;
+ for I in 1 .. Name_Length loop
+ if Name_Buffer (I) = '_' then
+ Error_Vital
+ ("VITAL entity port shall not contain underscore", Decl);
+ exit;
+ end if;
+ end loop;
+
+ -- IEEE 1076.4 4.3.1
+ -- A port that is declared in an entity port declaration shall not be
+ -- of mode LINKAGE.
+ if Get_Mode (Decl) = Iir_Linkage_Mode then
+ Error_Vital ("VITAL entity port shall not be of mode LINKAGE", Decl);
+ end if;
+
+ -- IEEE 1076.4 4.3.1
+ -- The type mark in an entity port declaration shall denote a type or
+ -- a subtype that is declared in package Std_Logic_1164. The type
+ -- mark in the declaration of a scalar port shall denote the subtype
+ -- Std_Ulogic or a subtype of Std_Ulogic. The type mark in the
+ -- declaration of an array port shall denote the type Std_Logic_Vector.
+ Atype := Get_Type (Decl);
+ Base_Type := Get_Base_Type (Atype);
+ Type_Decl := Get_Type_Declarator (Atype);
+ if Base_Type = Std_Logic_Vector_Type then
+ if Get_Resolution_Indication (Atype) /= Null_Iir then
+ Error_Vital
+ ("VITAL array port type cannot override resolution function",
+ Decl);
+ end if;
+ -- FIXME: is an unconstrained array port allowed ?
+ -- FIXME: what about staticness of the index_constraint ?
+ elsif Base_Type = Std_Ulogic_Type then
+ if Type_Decl = Null_Iir
+ or else Get_Parent (Type_Decl) /= Std_Logic_1164_Pkg
+ then
+ Error_Vital
+ ("VITAL entity port type mark shall be one of Std_Logic_1164",
+ Decl);
+ end if;
+ else
+ Error_Vital ("VITAL port type must be Std_Logic_Vector or Std_Ulogic",
+ Decl);
+ end if;
+
+ if Get_Signal_Kind (Decl) /= Iir_No_Signal_Kind then
+ Error_Vital ("VITAL entity port cannot be guarded", Decl);
+ end if;
+ end Check_Entity_Port_Declaration;
+
+ -- Current position in the generic name, stored into
+ -- name_table.name_buffer.
+ Gen_Name_Pos : Natural;
+
+ -- Length of the generic name.
+ Gen_Name_Length : Natural;
+
+ -- The generic being analyzed.
+ Gen_Decl : Iir;
+ Gen_Chain : Iir;
+
+ procedure Error_Vital_Name (Str : String)
+ is
+ Loc : Location_Type;
+ begin
+ Loc := Get_Location (Gen_Decl);
+ Error_Vital (Str, Loc + Location_Type (Gen_Name_Pos - 1));
+ end Error_Vital_Name;
+
+ -- Check the next sub-string in the generic name is a port.
+ -- Returns the port.
+ function Check_Port return Iir
+ is
+ use Sem_Scopes;
+ use Name_Table;
+
+ C : Character;
+ Res : Iir;
+ Id : Name_Id;
+ Inter : Name_Interpretation_Type;
+ begin
+ Name_Length := 0;
+ while Gen_Name_Pos <= Gen_Name_Length loop
+ C := Name_Buffer (Gen_Name_Pos);
+ Gen_Name_Pos := Gen_Name_Pos + 1;
+ exit when C = '_';
+ Name_Length := Name_Length + 1;
+ Name_Buffer (Name_Length) := C;
+ end loop;
+
+ if Name_Length = 0 then
+ Error_Vital_Name ("port expected in VITAL generic name");
+ return Null_Iir;
+ end if;
+
+ Id := Get_Identifier_No_Create;
+ Res := Null_Iir;
+ if Id /= Null_Identifier then
+ Inter := Get_Interpretation (Id);
+ if Valid_Interpretation (Inter) then
+ Res := Get_Declaration (Inter);
+ end if;
+ end if;
+ if Res = Null_Iir then
+ Warning_Vital ("'" & Name_Buffer (1 .. Name_Length)
+ & "' is not a port name (in VITAL generic name)",
+ Gen_Decl);
+ end if;
+ return Res;
+ end Check_Port;
+
+ -- Checks the port is an input port.
+ function Check_Input_Port return Iir
+ is
+ use Name_Table;
+
+ Res : Iir;
+ begin
+ Res := Check_Port;
+ if Res /= Null_Iir then
+ -- IEEE 1076.4 4.3.2.1.3
+ -- an input port is a VHDL port of mode IN or INOUT.
+ case Get_Mode (Res) is
+ when Iir_In_Mode
+ | Iir_Inout_Mode =>
+ null;
+ when others =>
+ Error_Vital ("'" & Name_Buffer (1 .. Name_Length)
+ & "' must be an input port", Gen_Decl);
+ end case;
+ end if;
+ return Res;
+ end Check_Input_Port;
+
+ -- Checks the port is an output port.
+ function Check_Output_Port return Iir
+ is
+ use Name_Table;
+
+ Res : Iir;
+ begin
+ Res := Check_Port;
+ if Res /= Null_Iir then
+ -- IEEE 1076.4 4.3.2.1.3
+ -- An output port is a VHDL port of mode OUT, INOUT or BUFFER.
+ case Get_Mode (Res) is
+ when Iir_Out_Mode
+ | Iir_Inout_Mode
+ | Iir_Buffer_Mode =>
+ null;
+ when others =>
+ Error_Vital ("'" & Name_Buffer (1 .. Name_Length)
+ & "' must be an output port", Gen_Decl);
+ end case;
+ end if;
+ return Res;
+ end Check_Output_Port;
+
+ -- Extract a suffix from the generic name.
+ type Suffixes_Kind is
+ (
+ Suffix_Name, -- [a-z]*
+ Suffix_Num_Name, -- [0-9]*
+ Suffix_Edge, -- posedge, negedge, 01, 10, 0z, z1, 1z, z0
+ Suffix_Noedge, -- noedge
+ Suffix_Eon -- End of name
+ );
+
+ function Get_Next_Suffix_Kind return Suffixes_Kind
+ is
+ use Name_Table;
+
+ Len : Natural;
+ P : constant Natural := Gen_Name_Pos;
+ C : Character;
+ begin
+ Len := 0;
+ while Gen_Name_Pos <= Gen_Name_Length loop
+ C := Name_Buffer (Gen_Name_Pos);
+ Gen_Name_Pos := Gen_Name_Pos + 1;
+ exit when C = '_';
+ Len := Len + 1;
+ end loop;
+ if Len = 0 then
+ return Suffix_Eon;
+ end if;
+
+ case Name_Buffer (P) is
+ when '0' =>
+ if Len = 2 and then (Name_Buffer (P + 1) = '1'
+ or Name_Buffer (P + 1) = 'z')
+ then
+ return Suffix_Edge;
+ else
+ return Suffix_Num_Name;
+ end if;
+ when '1' =>
+ if Len = 2 and then (Name_Buffer (P + 1) = '0'
+ or Name_Buffer (P + 1) = 'z')
+ then
+ return Suffix_Edge;
+ else
+ return Suffix_Num_Name;
+ end if;
+ when '2' .. '9' =>
+ return Suffix_Num_Name;
+ when 'z' =>
+ if Len = 2 and then (Name_Buffer (P + 1) = '0'
+ or Name_Buffer (P + 1) = '1')
+ then
+ return Suffix_Edge;
+ else
+ return Suffix_Name;
+ end if;
+ when 'p' =>
+ if Len = 7 and then Name_Buffer (P .. P + 6) = "posedge" then
+ return Suffix_Edge;
+ else
+ return Suffix_Name;
+ end if;
+ when 'n' =>
+ if Len = 7 and then Name_Buffer (P .. P + 6) = "negedge" then
+ return Suffix_Edge;
+ elsif Len = 6 and then Name_Buffer (P .. P + 5) = "noedge" then
+ return Suffix_Edge;
+ else
+ return Suffix_Name;
+ end if;
+ when 'a' .. 'm'
+ | 'o'
+ | 'q' .. 'y' =>
+ return Suffix_Name;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Next_Suffix_Kind;
+
+ -- ::=
+ --
+ -- |
+ -- | _
+ procedure Check_Simple_Condition_And_Or_Edge
+ is
+ First : Boolean := True;
+ begin
+ loop
+ case Get_Next_Suffix_Kind is
+ when Suffix_Eon =>
+ -- Simple condition is optional.
+ return;
+ when Suffix_Edge =>
+ if Get_Next_Suffix_Kind /= Suffix_Eon then
+ Error_Vital_Name ("garbage after edge");
+ end if;
+ return;
+ when Suffix_Num_Name =>
+ if First then
+ Error_Vital_Name ("condition is a simple name");
+ end if;
+ when Suffix_Noedge =>
+ Error_Vital_Name ("'noedge' not allowed in simple condition");
+ when Suffix_Name =>
+ null;
+ end case;
+ First := False;
+ end loop;
+ end Check_Simple_Condition_And_Or_Edge;
+
+ -- ::=
+ -- [_]
+ --
+ -- ::=
+ -- [_]
+ -- | [_]noedge
+ procedure Check_Full_Condition_And_Or_Edge
+ is
+ begin
+ case Get_Next_Suffix_Kind is
+ when Suffix_Eon =>
+ -- FullCondition is always optional.
+ return;
+ when Suffix_Edge
+ | Suffix_Noedge =>
+ Check_Simple_Condition_And_Or_Edge;
+ return;
+ when Suffix_Num_Name =>
+ Error_Vital_Name ("condition is a simple name");
+ when Suffix_Name =>
+ null;
+ end case;
+
+ loop
+ case Get_Next_Suffix_Kind is
+ when Suffix_Eon =>
+ Error_Vital_Name ("missing edge or noedge");
+ return;
+ when Suffix_Edge
+ | Suffix_Noedge =>
+ Check_Simple_Condition_And_Or_Edge;
+ return;
+ when Suffix_Num_Name
+ | Suffix_Name =>
+ null;
+ end case;
+ end loop;
+ end Check_Full_Condition_And_Or_Edge;
+
+ procedure Check_End is
+ begin
+ if Get_Next_Suffix_Kind /= Suffix_Eon then
+ Error_Vital_Name ("garbage at end of name");
+ end if;
+ end Check_End;
+
+ -- Return the length of a port P.
+ -- If P is a scalar port, return PORT_LENGTH_SCALAR
+ -- If P is a vector, return the length of the vector (>= 0)
+ -- Otherwise, return PORT_LENGTH_ERROR.
+ Port_Length_Unknown : constant Iir_Int64 := -1;
+ Port_Length_Scalar : constant Iir_Int64 := -2;
+ Port_Length_Error : constant Iir_Int64 := -3;
+ function Get_Port_Length (P : Iir) return Iir_Int64
+ is
+ Ptype : Iir;
+ Itype : Iir;
+ begin
+ Ptype := Get_Type (P);
+ if Get_Base_Type (Ptype) = Std_Ulogic_Type then
+ return Port_Length_Scalar;
+ elsif Get_Kind (Ptype) = Iir_Kind_Array_Subtype_Definition
+ and then Get_Base_Type (Ptype) = Std_Logic_Vector_Type
+ then
+ Itype := Get_First_Element (Get_Index_Subtype_List (Ptype));
+ if Get_Type_Staticness (Itype) /= Locally then
+ return Port_Length_Unknown;
+ end if;
+ return Evaluation.Eval_Discrete_Type_Length (Itype);
+ else
+ return Port_Length_Error;
+ end if;
+ end Get_Port_Length;
+
+ -- IEEE 1076.4 9.1 VITAL delay types and subtypes.
+ -- The transition dependent delay types are
+ -- VitalDelayType01, VitalDelayType01Z, VitalDelayType01ZX,
+ -- VitalDelayArrayType01, VitalDelayArrayType01Z, VitalDelayArrayType01ZX.
+ -- The first three are scalar forms, the last three are vector forms.
+ --
+ -- The simple delay types and subtypes include
+ -- Time, VitalDelayType, and VitalDelayArrayType.
+ -- The first two are scalar forms, and the latter is the vector form.
+ type Timing_Generic_Type_Kind is
+ (
+ Timing_Type_Simple_Scalar,
+ Timing_Type_Simple_Vector,
+ Timing_Type_Trans_Scalar,
+ Timing_Type_Trans_Vector,
+ Timing_Type_Bad
+ );
+
+ function Get_Timing_Generic_Type_Kind return Timing_Generic_Type_Kind
+ is
+ Gtype : Iir;
+ Btype : Iir;
+ begin
+ Gtype := Get_Type (Gen_Decl);
+ Btype := Get_Base_Type (Gtype);
+ case Get_Kind (Gtype) is
+ when Iir_Kind_Array_Subtype_Definition =>
+ if Btype = VitalDelayArrayType then
+ return Timing_Type_Simple_Vector;
+ end if;
+ if Btype = VitalDelayType01
+ or Btype = VitalDelayType01Z
+ or Btype = VitalDelayType01ZX
+ then
+ return Timing_Type_Trans_Scalar;
+ end if;
+ if Btype = VitalDelayArrayType01
+ or Btype = VitalDelayArrayType01Z
+ or Btype = VitalDelayArrayType01ZX
+ then
+ return Timing_Type_Trans_Vector;
+ end if;
+ when Iir_Kind_Physical_Subtype_Definition =>
+ if Gtype = Time_Subtype_Definition
+ or else Gtype = VitalDelayType
+ then
+ return Timing_Type_Simple_Scalar;
+ end if;
+ when others =>
+ null;
+ end case;
+ Error_Vital ("type of timing generic is not a VITAL delay type",
+ Gen_Decl);
+ return Timing_Type_Bad;
+ end Get_Timing_Generic_Type_Kind;
+
+ function Get_Timing_Generic_Type_Length return Iir_Int64
+ is
+ Itype : Iir;
+ begin
+ Itype := Get_First_Element
+ (Get_Index_Subtype_List (Get_Type (Gen_Decl)));
+ if Get_Type_Staticness (Itype) /= Locally then
+ return Port_Length_Unknown;
+ else
+ return Evaluation.Eval_Discrete_Type_Length (Itype);
+ end if;
+ end Get_Timing_Generic_Type_Length;
+
+ -- IEEE 1076.4 4.3.2.1.2 Timing generic subtypes
+ -- * If the timing generic is associated with a single port and that port
+ -- is a scalar, then the type of the timing generic shall be a scalar
+ -- form of delay type.
+ -- * If such a timing generic is associated with a single port and that
+ -- port is a vector, then the type of the timing generic shall be a
+ -- vector form of delay type, and the constraint on the generic shall
+ -- match that on the associated port.
+ procedure Check_Vital_Delay_Type (P : Iir;
+ Is_Simple : Boolean := False;
+ Is_Scalar : Boolean := False)
+ is
+ Kind : Timing_Generic_Type_Kind;
+ Len : Iir_Int64;
+ Len1 : Iir_Int64;
+ begin
+ Kind := Get_Timing_Generic_Type_Kind;
+ if P = Null_Iir or Kind = Timing_Type_Bad then
+ return;
+ end if;
+ Len := Get_Port_Length (P);
+ if Len = Port_Length_Scalar then
+ case Kind is
+ when Timing_Type_Simple_Scalar =>
+ null;
+ when Timing_Type_Trans_Scalar =>
+ if Is_Simple then
+ Error_Vital
+ ("VITAL simple scalar timing type expected", Gen_Decl);
+ return;
+ end if;
+ when others =>
+ Error_Vital ("VITAL scalar timing type expected", Gen_Decl);
+ return;
+ end case;
+ elsif Len >= Port_Length_Unknown then
+ if Is_Scalar then
+ Error_Vital ("VITAL scalar timing type expected", Gen_Decl);
+ return;
+ end if;
+
+ case Kind is
+ when Timing_Type_Simple_Vector =>
+ null;
+ when Timing_Type_Trans_Vector =>
+ if Is_Simple then
+ Error_Vital
+ ("VITAL simple vector timing type expected", Gen_Decl);
+ return;
+ end if;
+ when others =>
+ Error_Vital ("VITAL vector timing type expected", Gen_Decl);
+ return;
+ end case;
+ Len1 := Get_Timing_Generic_Type_Length;
+ if Len1 /= Len then
+ Error_Vital ("length of port and VITAL vector timing subtype "
+ & "does not match", Gen_Decl);
+ end if;
+ end if;
+ end Check_Vital_Delay_Type;
+
+ -- IEEE 1076.4 4.3.2.1.2 Timing generic subtypes
+ -- * If the timing generic is associated with two scalar ports, then the
+ -- type of the timing generic shall be a scalar form of delay type.
+ -- * If the timing generic is associated with two ports, one or more of
+ -- which is a vector, then the type of the timing generic shall be a
+ -- vector form of delay type, and the length of the index range of the
+ -- generic shall be equal to the product of the number of scalar
+ -- subelements in the first port and the number of scalar subelements
+ -- in the second port.
+ procedure Check_Vital_Delay_Type
+ (P1, P2 : Iir;
+ Is_Simple : Boolean := False;
+ Is_Scalar : Boolean := False)
+ is
+ Kind : Timing_Generic_Type_Kind;
+ Len1 : Iir_Int64;
+ Len2 : Iir_Int64;
+ Lenp : Iir_Int64;
+ begin
+ Kind := Get_Timing_Generic_Type_Kind;
+ if P1 = Null_Iir or P2 = Null_Iir or Kind = Timing_Type_Bad then
+ return;
+ end if;
+ Len1 := Get_Port_Length (P1);
+ Len2 := Get_Port_Length (P2);
+ if Len1 = Port_Length_Scalar and Len2 = Port_Length_Scalar then
+ case Kind is
+ when Timing_Type_Simple_Scalar =>
+ null;
+ when Timing_Type_Trans_Scalar =>
+ if Is_Simple then
+ Error_Vital
+ ("VITAL simple scalar timing type expected", Gen_Decl);
+ return;
+ end if;
+ when others =>
+ Error_Vital ("VITAL scalar timing type expected", Gen_Decl);
+ return;
+ end case;
+ elsif Len1 >= Port_Length_Unknown or Len2 >= Port_Length_Unknown then
+ if Is_Scalar then
+ Error_Vital ("VITAL scalar timing type expected", Gen_Decl);
+ return;
+ end if;
+ case Kind is
+ when Timing_Type_Simple_Vector =>
+ null;
+ when Timing_Type_Trans_Vector =>
+ if Is_Simple then
+ Error_Vital
+ ("VITAL simple vector timing type expected", Gen_Decl);
+ return;
+ end if;
+ when others =>
+ Error_Vital ("VITAL vector timing type expected", Gen_Decl);
+ return;
+ end case;
+ if Len1 = Port_Length_Scalar then
+ Len1 := 1;
+ elsif Len1 = Port_Length_Error then
+ return;
+ end if;
+ if Len2 = Port_Length_Scalar then
+ Len2 := 1;
+ elsif Len2 = Port_Length_Error then
+ return;
+ end if;
+ Lenp := Get_Timing_Generic_Type_Length;
+ if Lenp /= Len1 * Len2 then
+ Error_Vital ("length of port and VITAL vector timing subtype "
+ & "does not match", Gen_Decl);
+ end if;
+ end if;
+ end Check_Vital_Delay_Type;
+
+ function Check_Timing_Generic_Prefix
+ (Decl : Iir_Interface_Constant_Declaration; Length : Natural)
+ return Boolean
+ is
+ use Name_Table;
+ begin
+ -- IEEE 1076.4 4.3.1
+ -- It is an error for a model to use a timing generic prefix to begin
+ -- the simple name of an entity generic that is not a timing generic.
+ if Name_Length < Length or Name_Buffer (Length) /= '_' then
+ Error_Vital ("invalid use of a VITAL timing generic prefix", Decl);
+ return False;
+ end if;
+ Gen_Name_Pos := Length + 1;
+ Gen_Name_Length := Name_Length;
+ Gen_Decl := Decl;
+ return True;
+ end Check_Timing_Generic_Prefix;
+
+ -- IEEE 1076.4 4.3.2.1.3.1 Propagation Delay
+ -- ::=
+ -- TPD__[_]
+ procedure Check_Propagation_Delay_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ Iport : Iir;
+ Oport : Iir;
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 4) then
+ return;
+ end if;
+ Iport := Check_Input_Port;
+ Oport := Check_Output_Port;
+ Check_Simple_Condition_And_Or_Edge;
+ Check_Vital_Delay_Type (Iport, Oport);
+ end Check_Propagation_Delay_Name;
+
+ procedure Check_Test_Reference
+ is
+ Tport : Iir;
+ Rport : Iir;
+ begin
+ Tport := Check_Input_Port;
+ Rport := Check_Input_Port;
+ Check_Full_Condition_And_Or_Edge;
+ Check_Vital_Delay_Type (Tport, Rport, Is_Simple => True);
+ end Check_Test_Reference;
+
+ -- tsetup
+ procedure Check_Input_Setup_Time_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 7) then
+ return;
+ end if;
+ Check_Test_Reference;
+ end Check_Input_Setup_Time_Name;
+
+ -- thold
+ procedure Check_Input_Hold_Time_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 6) then
+ return;
+ end if;
+ Check_Test_Reference;
+ end Check_Input_Hold_Time_Name;
+
+ -- trecovery
+ procedure Check_Input_Recovery_Time_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 10) then
+ return;
+ end if;
+ Check_Test_Reference;
+ end Check_Input_Recovery_Time_Name;
+
+ -- tremoval
+ procedure Check_Input_Removal_Time_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 9) then
+ return;
+ end if;
+ Check_Test_Reference;
+ end Check_Input_Removal_Time_Name;
+
+ -- tperiod
+ procedure Check_Input_Period_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ Iport : Iir;
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 8) then
+ return;
+ end if;
+ Iport := Check_Input_Port;
+ Check_Simple_Condition_And_Or_Edge;
+ Check_Vital_Delay_Type (Iport, Is_Simple => True);
+ end Check_Input_Period_Name;
+
+ -- tpw
+ procedure Check_Pulse_Width_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ Iport : Iir;
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 4) then
+ return;
+ end if;
+ Iport := Check_Input_Port;
+ Check_Simple_Condition_And_Or_Edge;
+ Check_Vital_Delay_Type (Iport, Is_Simple => True);
+ end Check_Pulse_Width_Name;
+
+ -- tskew
+ procedure Check_Input_Skew_Time_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ Fport : Iir;
+ Sport : Iir;
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 6) then
+ return;
+ end if;
+ Fport := Check_Port;
+ Sport := Check_Port;
+ Check_Full_Condition_And_Or_Edge;
+ Check_Vital_Delay_Type (Fport, Sport, Is_Simple => True);
+ end Check_Input_Skew_Time_Name;
+
+ -- tncsetup
+ procedure Check_No_Change_Setup_Time_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 9) then
+ return;
+ end if;
+ Check_Test_Reference;
+ end Check_No_Change_Setup_Time_Name;
+
+ -- tnchold
+ procedure Check_No_Change_Hold_Time_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 8) then
+ return;
+ end if;
+ Check_Test_Reference;
+ end Check_No_Change_Hold_Time_Name;
+
+ -- tipd
+ procedure Check_Interconnect_Path_Delay_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ Iport : Iir;
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 5) then
+ return;
+ end if;
+ Iport := Check_Input_Port;
+ Check_End;
+ Check_Vital_Delay_Type (Iport);
+ end Check_Interconnect_Path_Delay_Name;
+
+ -- tdevice
+ procedure Check_Device_Delay_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ Oport : Iir;
+ pragma Unreferenced (Oport);
+ Pos : Natural;
+ Kind : Timing_Generic_Type_Kind;
+ pragma Unreferenced (Kind);
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 8) then
+ return;
+ end if;
+ if Get_Next_Suffix_Kind /= Suffix_Name then
+ Error_Vital_Name ("instance_name expected in VITAL generic name");
+ return;
+ end if;
+ Pos := Gen_Name_Pos;
+ if Get_Next_Suffix_Kind /= Suffix_Eon then
+ Gen_Name_Pos := Pos;
+ Oport := Check_Output_Port;
+ Check_End;
+ end if;
+ Kind := Get_Timing_Generic_Type_Kind;
+ end Check_Device_Delay_Name;
+
+ -- tisd
+ procedure Check_Internal_Signal_Delay_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ Iport : Iir;
+ Cport : Iir;
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 5) then
+ return;
+ end if;
+ Iport := Check_Input_Port;
+ Cport := Check_Input_Port;
+ Check_End;
+ Check_Vital_Delay_Type (Iport, Cport,
+ Is_Simple => True, Is_Scalar => True);
+ end Check_Internal_Signal_Delay_Name;
+
+ -- tbpd
+ procedure Check_Biased_Propagation_Delay_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ Iport : Iir;
+ Oport : Iir;
+ Cport : Iir;
+ pragma Unreferenced (Cport);
+ Clock_Start : Natural;
+ Clock_End : Natural;
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 5) then
+ return;
+ end if;
+ Iport := Check_Input_Port;
+ Oport := Check_Output_Port;
+ Clock_Start := Gen_Name_Pos - 1; -- At the '_'.
+ Cport := Check_Input_Port;
+ Clock_End := Gen_Name_Pos;
+ Check_Simple_Condition_And_Or_Edge;
+ Check_Vital_Delay_Type (Iport, Oport);
+
+ -- IEEE 1076.4 4.3.2.1.3.14 Biased propagation delay
+ -- There shall exist, in the same entity generic clause, a corresponding
+ -- propagation delay generic denoting the same ports, condition name,
+ -- and edge.
+ declare
+ use Name_Table;
+
+ -- '-1' is for the missing 'b' in 'tpd'.
+ Tpd_Name : String
+ (1 .. Gen_Name_Length - 1 - (Clock_End - Clock_Start));
+ Tpd_Decl : Iir;
+ begin
+ Image (Get_Identifier (Decl));
+ Tpd_Name (1) := 't';
+ -- The part before '_'.
+ Tpd_Name (2 .. Clock_Start - 2) := Name_Buffer (3 .. Clock_Start - 1);
+ Tpd_Name (Clock_Start - 1 .. Tpd_Name'Last) :=
+ Name_Buffer (Clock_End .. Name_Length);
+
+ Tpd_Decl := Gen_Chain;
+ loop
+ exit when Tpd_Decl = Null_Iir;
+ Image (Get_Identifier (Tpd_Decl));
+ exit when Name_Length = Tpd_Name'Length
+ and then Name_Buffer (1 .. Name_Length) = Tpd_Name;
+ Tpd_Decl := Get_Chain (Tpd_Decl);
+ end loop;
+
+ if Tpd_Decl = Null_Iir then
+ Error_Vital
+ ("no matching 'tpd' generic for VITAL 'tbpd' timing generic",
+ Decl);
+ else
+ -- IEEE 1076.4 4.3.2.1.3.14 Biased propagation delay
+ -- Furthermore, the type of the biased propagation generic shall
+ -- be the same as the type of the corresponding delay generic.
+ if not Sem.Are_Trees_Equal (Get_Type (Decl), Get_Type (Tpd_Decl))
+ then
+ Error_Vital
+ ("type of VITAL 'tbpd' generic mismatch type of "
+ & "'tpd' generic", Decl);
+ Error_Vital
+ ("(corresponding 'tpd' timing generic)", Tpd_Decl);
+ end if;
+ end if;
+ end;
+ end Check_Biased_Propagation_Delay_Name;
+
+ -- ticd
+ procedure Check_Internal_Clock_Delay_Generic_Name
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ Cport : Iir;
+ P_Start : Natural;
+ P_End : Natural;
+ begin
+ if not Check_Timing_Generic_Prefix (Decl, 5) then
+ return;
+ end if;
+ P_Start := Gen_Name_Pos;
+ Cport := Check_Input_Port;
+ P_End := Gen_Name_Pos;
+ Check_End;
+ Check_Vital_Delay_Type (Cport, Is_Simple => True, Is_Scalar => True);
+
+ -- IEEE 1076.4 4.3.2.1.3.15 Internal clock delay
+ -- It is an error for a clocks signal name to appear as one of the
+ -- following elements in the name of a timing generic:
+ -- * As either the input port in the name of a biased propagation
+ -- delay generic.
+ -- * As the input signal name in an internal delay timing generic.
+ -- * As the test port in a timing check or recovery removal timing
+ -- generic.
+ -- FIXME: recovery OR removal ?
+
+ if P_End - 1 /= Gen_Name_Length then
+ -- Do not check in case of error.
+ return;
+ end if;
+ declare
+ use Name_Table;
+ Port : String (1 .. Name_Length);
+ El : Iir;
+ Offset : Natural;
+
+ procedure Check_Not_Clock
+ is
+ S : Natural;
+ begin
+ S := Offset;
+ loop
+ Offset := Offset + 1;
+ exit when Offset > Name_Length
+ or else Name_Buffer (Offset) = '_';
+ end loop;
+ if Offset - S = Port'Length
+ and then Name_Buffer (S .. Offset - 1) = Port
+ then
+ Error_Vital ("clock port name of 'ticd' VITAL generic must not"
+ & " appear here", El);
+ end if;
+ end Check_Not_Clock;
+ begin
+ Port := Name_Buffer (P_Start .. Gen_Name_Length);
+
+ El := Gen_Chain;
+ while El /= Null_Iir loop
+ Image (Get_Identifier (El));
+ if Name_Length > 5
+ and then Name_Buffer (1) = 't'
+ then
+ if Name_Buffer (2 .. 5) = "bpd_" then
+ Offset := 6;
+ Check_Not_Clock; -- input
+ Check_Not_Clock; -- output
+ elsif Name_Buffer (2 .. 5) = "isd_" then
+ Offset := 6;
+ Check_Not_Clock; -- input
+ elsif Name_Length > 10
+ and then Name_Buffer (2 .. 10) = "recovery_"
+ then
+ Offset := 11;
+ Check_Not_Clock; -- test port
+ elsif Name_Length > 9
+ and then Name_Buffer (2 .. 9) = "removal_"
+ then
+ Offset := 10;
+ Check_Not_Clock;
+ end if;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ end;
+ end Check_Internal_Clock_Delay_Generic_Name;
+
+ procedure Check_Entity_Generic_Declaration
+ (Decl : Iir_Interface_Constant_Declaration)
+ is
+ use Name_Table;
+ Id : Name_Id;
+ begin
+ Id := Get_Identifier (Decl);
+ Image (Id);
+
+ -- Extract prefix.
+ if Name_Buffer (1) = 't' and Name_Length >= 3 then
+ -- Timing generic names.
+ if Name_Buffer (2) = 'p' then
+ if Name_Buffer (3) = 'd' then
+ Check_Propagation_Delay_Name (Decl); -- tpd
+ return;
+ elsif Name_Buffer (3) = 'w' then
+ Check_Pulse_Width_Name (Decl); -- tpw
+ return;
+ elsif Name_Length >= 7
+ and then Name_Buffer (3 .. 7) = "eriod"
+ then
+ Check_Input_Period_Name (Decl); -- tperiod
+ return;
+ end if;
+ elsif Name_Buffer (2) = 'i'
+ and then Name_Length >= 4
+ and then Name_Buffer (4) = 'd'
+ then
+ if Name_Buffer (3) = 'p' then
+ Check_Interconnect_Path_Delay_Name (Decl); -- tipd
+ return;
+ elsif Name_Buffer (3) = 's' then
+ Check_Internal_Signal_Delay_Name (Decl); -- tisd
+ return;
+ elsif Name_Buffer (3) = 'c' then
+ Check_Internal_Clock_Delay_Generic_Name (Decl); -- ticd
+ return;
+ end if;
+ elsif Name_Length >= 6 and then Name_Buffer (2 .. 6) = "setup" then
+ Check_Input_Setup_Time_Name (Decl); -- tsetup
+ return;
+ elsif Name_Length >= 5 and then Name_Buffer (2 .. 5) = "hold" then
+ Check_Input_Hold_Time_Name (Decl); -- thold
+ return;
+ elsif Name_Length >= 9 and then Name_Buffer (2 .. 9) = "recovery" then
+ Check_Input_Recovery_Time_Name (Decl); -- trecovery
+ return;
+ elsif Name_Length >= 8 and then Name_Buffer (2 .. 8) = "removal" then
+ Check_Input_Removal_Time_Name (Decl); -- tremoval
+ return;
+ elsif Name_Length >= 5 and then Name_Buffer (2 .. 5) = "skew" then
+ Check_Input_Skew_Time_Name (Decl); -- tskew
+ return;
+ elsif Name_Length >= 8 and then Name_Buffer (2 .. 8) = "ncsetup" then
+ Check_No_Change_Setup_Time_Name (Decl); -- tncsetup
+ return;
+ elsif Name_Length >= 7 and then Name_Buffer (2 .. 7) = "nchold" then
+ Check_No_Change_Hold_Time_Name (Decl); -- tnchold
+ return;
+ elsif Name_Length >= 7 and then Name_Buffer (2 .. 7) = "device" then
+ Check_Device_Delay_Name (Decl); -- tdevice
+ return;
+ elsif Name_Length >= 4 and then Name_Buffer (2 .. 4) = "bpd" then
+ Check_Biased_Propagation_Delay_Name (Decl); -- tbpd
+ return;
+ end if;
+ end if;
+
+ if Id = InstancePath_Id then
+ if Get_Type (Decl) /= String_Type_Definition then
+ Error_Vital
+ ("InstancePath VITAL generic must be of type String", Decl);
+ end if;
+ return;
+ elsif Id = TimingChecksOn_Id
+ or Id = XOn_Id
+ or Id = MsgOn_Id
+ then
+ if Get_Type (Decl) /= Boolean_Type_Definition then
+ Error_Vital
+ (Image (Id) & " VITAL generic must be of type Boolean", Decl);
+ end if;
+ return;
+ end if;
+
+ if Flags.Warn_Vital_Generic then
+ Warning_Vital (Disp_Node (Decl) & " is not a VITAL generic", Decl);
+ end if;
+ end Check_Entity_Generic_Declaration;
+
+ -- Checks rules for a VITAL level 0 entity.
+ procedure Check_Vital_Level0_Entity (Ent : Iir_Entity_Declaration)
+ is
+ use Sem_Scopes;
+ Decl : Iir;
+ begin
+ -- IEEE 1076.4 4.3.1
+ -- The only form of declaration allowed in the entity declarative part
+ -- is the specification of the VITAL_Level0 attribute.
+ Decl := Get_Declaration_Chain (Ent);
+ if Decl = Null_Iir then
+ -- Cannot happen, since there is at least the attribute spec.
+ raise Internal_Error;
+ end if;
+ Check_Level0_Attribute_Specification (Decl);
+ Decl := Get_Chain (Decl);
+ if Decl /= Null_Iir then
+ Error_Vital ("VITAL entity declarative part must only contain the "
+ & "attribute specification", Decl);
+ end if;
+
+ -- IEEE 1076.4 4.3.1
+ -- No statements are allowed in the entity statement part.
+ Decl := Get_Concurrent_Statement_Chain (Ent);
+ if Decl /= Null_Iir then
+ Error_Vital ("VITAL entity must not have concurrent statement", Decl);
+ end if;
+
+ -- Check ports.
+ Name_Table.Assert_No_Infos;
+ Open_Declarative_Region;
+ Decl := Get_Port_Chain (Ent);
+ while Decl /= Null_Iir loop
+ Check_Entity_Port_Declaration (Decl);
+ Add_Name (Decl);
+ Decl := Get_Chain (Decl);
+ end loop;
+
+ -- Check generics.
+ Gen_Chain := Get_Generic_Chain (Ent);
+ Decl := Gen_Chain;
+ while Decl /= Null_Iir loop
+ Check_Entity_Generic_Declaration (Decl);
+ Decl := Get_Chain (Decl);
+ end loop;
+ Close_Declarative_Region;
+ end Check_Vital_Level0_Entity;
+
+ -- Return TRUE if UNIT was decorated with attribute VITAL_Level0.
+ function Is_Vital_Level0 (Unit : Iir_Entity_Declaration) return Boolean
+ is
+ Value : Iir_Attribute_Value;
+ Spec : Iir_Attribute_Specification;
+ begin
+ Value := Get_Attribute_Value_Chain (Unit);
+ while Value /= Null_Iir loop
+ Spec := Get_Attribute_Specification (Value);
+ if Get_Named_Entity (Get_Attribute_Designator (Spec))
+ = Vital_Level0_Attribute
+ then
+ return True;
+ end if;
+ Value := Get_Chain (Value);
+ end loop;
+
+ return False;
+ end Is_Vital_Level0;
+
+ procedure Check_Vital_Level0_Architecture (Arch : Iir_Architecture_Body)
+ is
+ Decl : Iir;
+ begin
+ -- IEEE 1076.4 4.1
+ -- The entity associated with a Level 0 architecture shall be a VITAL
+ -- Level 0 entity.
+ if not Is_Vital_Level0 (Iirs_Utils.Get_Entity (Arch)) then
+ Error_Vital ("entity associated with a VITAL level 0 architecture "
+ & "shall be a VITAL level 0 entity", Arch);
+ end if;
+
+ -- VITAL_Level_0_architecture_declarative_part ::=
+ -- VITAL_Level0_attribute_specification { block_declarative_item }
+ Decl := Get_Declaration_Chain (Arch);
+ Check_Level0_Attribute_Specification (Decl);
+ end Check_Vital_Level0_Architecture;
+
+ -- Check a VITAL level 0 decorated design unit.
+ procedure Check_Vital_Level0 (Unit : Iir_Design_Unit)
+ is
+ Lib_Unit : Iir;
+ begin
+ Lib_Unit := Get_Library_Unit (Unit);
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Entity_Declaration =>
+ Check_Vital_Level0_Entity (Lib_Unit);
+ when Iir_Kind_Architecture_Body =>
+ Check_Vital_Level0_Architecture (Lib_Unit);
+ when others =>
+ Error_Vital
+ ("only entity or architecture can be VITAL_Level0", Lib_Unit);
+ end case;
+ end Check_Vital_Level0;
+
+ procedure Check_Vital_Level1 (Unit : Iir_Design_Unit)
+ is
+ Arch : Iir;
+ begin
+ Arch := Get_Library_Unit (Unit);
+ if Get_Kind (Arch) /= Iir_Kind_Architecture_Body then
+ Error_Vital ("only architecture can be VITAL_Level1", Arch);
+ return;
+ end if;
+ -- FIXME: todo
+ end Check_Vital_Level1;
+
+end Ieee.Vital_Timing;
diff --git a/src/ieee-vital_timing.ads b/src/ieee-vital_timing.ads
new file mode 100644
index 000000000..7abda2eba
--- /dev/null
+++ b/src/ieee-vital_timing.ads
@@ -0,0 +1,41 @@
+-- Nodes recognizer for ieee.vital_timing.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Iirs; use Iirs;
+
+package Ieee.Vital_Timing is
+ -- Attribute declarations.
+ Vital_Level0_Attribute : Iir_Attribute_Declaration := Null_Iir;
+ Vital_Level1_Attribute : Iir_Attribute_Declaration := Null_Iir;
+
+ -- Vital delay types.
+ VitalDelayType : Iir := Null_Iir;
+ VitalDelayType01 : Iir_Array_Type_Definition := Null_Iir;
+ VitalDelayType01Z : Iir_Array_Type_Definition := Null_Iir;
+ VitalDelayType01ZX : Iir_Array_Type_Definition := Null_Iir;
+
+ VitalDelayArrayType : Iir_Array_Type_Definition := Null_Iir;
+ VitalDelayArrayType01 : Iir_Array_Type_Definition := Null_Iir;
+ VitalDelayArrayType01Z : Iir_Array_Type_Definition := Null_Iir;
+ VitalDelayArrayType01ZX : Iir_Array_Type_Definition := Null_Iir;
+
+ -- Extract declarations from IEEE.VITAL_Timing package.
+ procedure Extract_Declarations (Pkg : Iir_Package_Declaration);
+
+ procedure Check_Vital_Level0 (Unit : Iir_Design_Unit);
+ procedure Check_Vital_Level1 (Unit : Iir_Design_Unit);
+end Ieee.Vital_Timing;
diff --git a/src/ieee.ads b/src/ieee.ads
new file mode 100644
index 000000000..48ab37630
--- /dev/null
+++ b/src/ieee.ads
@@ -0,0 +1,5 @@
+-- Top of ieee hierarchy.
+-- Too small to be copyrighted.
+package Ieee is
+ pragma Pure (Ieee);
+end Ieee;
diff --git a/src/iir_chain_handling.adb b/src/iir_chain_handling.adb
new file mode 100644
index 000000000..1e70a366a
--- /dev/null
+++ b/src/iir_chain_handling.adb
@@ -0,0 +1,68 @@
+-- Generic package to handle chains.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package body Iir_Chain_Handling is
+ procedure Build_Init (Last : out Iir) is
+ begin
+ Last := Null_Iir;
+ end Build_Init;
+
+ procedure Build_Init (Last : out Iir; Parent : Iir)
+ is
+ El : Iir;
+ begin
+ El := Get_Chain_Start (Parent);
+ if El /= Null_Iir then
+ loop
+ Last := El;
+ El := Get_Chain (El);
+ exit when El = Null_Iir;
+ end loop;
+ else
+ Last := Null_Iir;
+ end if;
+ end Build_Init;
+
+ procedure Append (Last : in out Iir; Parent : Iir; El : Iir) is
+ begin
+ if Last = Null_Iir then
+ Set_Chain_Start (Parent, El);
+ else
+ Set_Chain (Last, El);
+ end if;
+ Last := El;
+ end Append;
+
+ procedure Append_Subchain (Last : in out Iir; Parent : Iir; Els : Iir)
+ is
+ El : Iir;
+ begin
+ if Last = Null_Iir then
+ Set_Chain_Start (Parent, Els);
+ else
+ Set_Chain (Last, Els);
+ end if;
+ El := Els;
+ loop
+ Set_Parent (El, Parent);
+ Last := El;
+ El := Get_Chain (El);
+ exit when El = Null_Iir;
+ end loop;
+ end Append_Subchain;
+end Iir_Chain_Handling;
+
diff --git a/src/iir_chain_handling.ads b/src/iir_chain_handling.ads
new file mode 100644
index 000000000..3865e9b65
--- /dev/null
+++ b/src/iir_chain_handling.ads
@@ -0,0 +1,47 @@
+-- Generic package to handle chains.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Iirs; use Iirs;
+
+-- The generic package Chain_Handling can be used to build or modify
+-- chains.
+-- The formals are the subprograms to get and set the first element
+-- from the parent.
+generic
+ with function Get_Chain_Start (Parent : Iir) return Iir;
+ with procedure Set_Chain_Start (Parent : Iir; First : Iir);
+package Iir_Chain_Handling is
+
+ -- Building a chain:
+ -- Initialize (set LAST to NULL_IIR).
+ procedure Build_Init (Last : out Iir);
+ -- Set LAST with the last element of the chain.
+ -- This is an initialization for an already built chain.
+ procedure Build_Init (Last : out Iir; Parent : Iir);
+
+ -- Append element EL to the chain, whose parent is PARENT and last
+ -- element LAST.
+ procedure Append (Last : in out Iir; Parent : Iir; El : Iir);
+
+ -- Append a subchain whose first element is ELS to a chain, whose
+ -- parent is PARENT and last element LAST.
+ -- The Parent field of each elements of Els is set to PARENT.
+ -- Note: the Append procedure declared just above is an optimization
+ -- of this subprogram if ELS has no next element. However, the
+ -- above subprogram does not set the Parent field of EL.
+ procedure Append_Subchain (Last : in out Iir; Parent : Iir; Els : Iir);
+end Iir_Chain_Handling;
diff --git a/src/iir_chains.adb b/src/iir_chains.adb
new file mode 100644
index 000000000..ef47b6485
--- /dev/null
+++ b/src/iir_chains.adb
@@ -0,0 +1,64 @@
+-- Chain handling.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package body Iir_Chains is
+ function Get_Chain_Length (First : Iir) return Natural
+ is
+ Res : Natural := 0;
+ El : Iir := First;
+ begin
+ while El /= Null_Iir loop
+ Res := Res + 1;
+ El := Get_Chain (El);
+ end loop;
+ return Res;
+ end Get_Chain_Length;
+
+ procedure Sub_Chain_Init (First, Last : out Iir) is
+ begin
+ First := Null_Iir;
+ Last := Null_Iir;
+ end Sub_Chain_Init;
+
+ procedure Sub_Chain_Append (First, Last : in out Iir; El : Iir) is
+ begin
+ if First = Null_Iir then
+ First := El;
+ else
+ Set_Chain (Last, El);
+ end if;
+ Last := El;
+ end Sub_Chain_Append;
+
+ function Is_Chain_Length_One (Chain : Iir) return Boolean is
+ begin
+ return Chain /= Null_Iir and then Get_Chain (Chain) = Null_Iir;
+ end Is_Chain_Length_One;
+
+ procedure Insert (Last : Iir; El : Iir) is
+ begin
+ Set_Chain (El, Get_Chain (Last));
+ Set_Chain (Last, El);
+ end Insert;
+
+ procedure Insert_Incr (Last : in out Iir; El : Iir) is
+ begin
+ Set_Chain (El, Get_Chain (Last));
+ Set_Chain (Last, El);
+ Last := El;
+ end Insert_Incr;
+end Iir_Chains;
diff --git a/src/iir_chains.ads b/src/iir_chains.ads
new file mode 100644
index 000000000..dc2f3894c
--- /dev/null
+++ b/src/iir_chains.ads
@@ -0,0 +1,113 @@
+-- Chain handling.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Iirs; use Iirs;
+with Iir_Chain_Handling;
+pragma Elaborate_All (Iir_Chain_Handling);
+
+package Iir_Chains is
+ -- Chains are simply linked list of iirs.
+ -- Elements of the chain are ordered.
+ -- Each element of a chain have a Chain field, which points to the next
+ -- element.
+ -- All elements of a chain have the same parent. This parent contains
+ -- a field which points to the first element of the chain.
+ -- Note: the parent is often the value of the Parent field, but sometimes
+ -- not.
+
+ -- Chains can be covered very simply:
+ -- El : Iir;
+ -- begin
+ -- El := Get_xxx_Chain (Parent);
+ -- while El /= Null_Iir loop
+ -- * Handle element EL of the chain.
+ -- El := Get_Chain (El);
+ -- end loop;
+
+ -- However, building a chain is a little bit more difficult if elements
+ -- have to be appended. Indeed, there is no direct access to the last
+ -- element of a chain.
+ -- An efficient way to build a chain is to keep the last element of it.
+ -- See Iir_Chain_Handling package.
+
+ package Declaration_Chain_Handling is new Iir_Chain_Handling
+ (Get_Chain_Start => Get_Declaration_Chain,
+ Set_Chain_Start => Set_Declaration_Chain);
+
+ package Interface_Declaration_Chain_Handling is new Iir_Chain_Handling
+ (Get_Chain_Start => Get_Interface_Declaration_Chain,
+ Set_Chain_Start => Set_Interface_Declaration_Chain);
+
+ package Context_Items_Chain_Handling is new Iir_Chain_Handling
+ (Get_Chain_Start => Get_Context_Items,
+ Set_Chain_Start => Set_Context_Items);
+
+ package Unit_Chain_Handling is new Iir_Chain_Handling
+ (Get_Chain_Start => Get_Unit_Chain,
+ Set_Chain_Start => Set_Unit_Chain);
+
+ package Configuration_Item_Chain_Handling is new Iir_Chain_Handling
+ (Get_Chain_Start => Get_Configuration_Item_Chain,
+ Set_Chain_Start => Set_Configuration_Item_Chain);
+
+ package Entity_Class_Entry_Chain_Handling is new Iir_Chain_Handling
+ (Get_Chain_Start => Get_Entity_Class_Entry_Chain,
+ Set_Chain_Start => Set_Entity_Class_Entry_Chain);
+
+ package Conditional_Waveform_Chain_Handling is new Iir_Chain_Handling
+ (Get_Chain_Start => Get_Conditional_Waveform_Chain,
+ Set_Chain_Start => Set_Conditional_Waveform_Chain);
+
+ package Selected_Waveform_Chain_Handling is new Iir_Chain_Handling
+ (Get_Chain_Start => Get_Selected_Waveform_Chain,
+ Set_Chain_Start => Set_Selected_Waveform_Chain);
+
+ package Association_Choices_Chain_Handling is new Iir_Chain_Handling
+ (Get_Chain_Start => Get_Association_Choices_Chain,
+ Set_Chain_Start => Set_Association_Choices_Chain);
+
+ package Case_Statement_Alternative_Chain_Handling is new Iir_Chain_Handling
+ (Get_Chain_Start => Get_Case_Statement_Alternative_Chain,
+ Set_Chain_Start => Set_Case_Statement_Alternative_Chain);
+
+ -- Return the number of elements in a chain starting with FIRST.
+ -- Not very efficient since O(N).
+ function Get_Chain_Length (First : Iir) return Natural;
+
+ -- These two subprograms can be used to build a sub-chain.
+ -- FIRST and LAST designates respectively the first and last element of
+ -- the sub-chain.
+
+ -- Set FIRST and LAST to Null_Iir.
+ procedure Sub_Chain_Init (First, Last : out Iir);
+ pragma Inline (Sub_Chain_Init);
+
+ -- Append element EL to the sub-chain.
+ procedure Sub_Chain_Append (First, Last : in out Iir; El : Iir);
+ pragma Inline (Sub_Chain_Append);
+
+ -- Return TRUE iff CHAIN is of length one, ie CHAIN is not NULL_IIR
+ -- and chain (CHAIN) is NULL_IIR.
+ function Is_Chain_Length_One (Chain : Iir) return Boolean;
+ pragma Inline (Is_Chain_Length_One);
+
+ -- Insert EL after LAST.
+ procedure Insert (Last : Iir; El : Iir);
+
+ -- Insert EL after LAST and set LAST to EL.
+ procedure Insert_Incr (Last : in out Iir; El : Iir);
+end Iir_Chains;
diff --git a/src/iirs.adb b/src/iirs.adb
new file mode 100644
index 000000000..876d1464f
--- /dev/null
+++ b/src/iirs.adb
@@ -0,0 +1,4515 @@
+-- Tree node definitions.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Unchecked_Conversion;
+with Ada.Text_IO;
+with Nodes; use Nodes;
+with Lists; use Lists;
+with Nodes_Meta; use Nodes_Meta;
+
+package body Iirs is
+ function Is_Null (Node : Iir) return Boolean is
+ begin
+ return Node = Null_Iir;
+ end Is_Null;
+
+ function Is_Null_List (Node : Iir_List) return Boolean is
+ begin
+ return Node = Null_Iir_List;
+ end Is_Null_List;
+
+ ---------------------------------------------------
+ -- General subprograms that operate on every iir --
+ ---------------------------------------------------
+
+ function Get_Format (Kind : Iir_Kind) return Format_Type;
+
+ function Create_Iir (Kind : Iir_Kind) return Iir
+ is
+ Res : Iir;
+ Format : Format_Type;
+ begin
+ Format := Get_Format (Kind);
+ Res := Create_Node (Format);
+ Set_Nkind (Res, Iir_Kind'Pos (Kind));
+ return Res;
+ end Create_Iir;
+
+ -- Statistics.
+ procedure Disp_Stats
+ is
+ use Ada.Text_IO;
+ type Num_Array is array (Iir_Kind) of Natural;
+ Num : Num_Array := (others => 0);
+ type Format_Array is array (Format_Type) of Natural;
+ Formats : Format_Array := (others => 0);
+ Kind : Iir_Kind;
+ I : Iir;
+ Last_I : Iir;
+ Format : Format_Type;
+ begin
+ I := Error_Node + 1;
+ Last_I := Get_Last_Node;
+ while I < Last_I loop
+ Kind := Get_Kind (I);
+ Num (Kind) := Num (Kind) + 1;
+ Format := Get_Format (Kind);
+ Formats (Format) := Formats (Format) + 1;
+ case Format is
+ when Format_Medium =>
+ I := I + 2;
+ when Format_Short
+ | Format_Fp
+ | Format_Int =>
+ I := I + 1;
+ end case;
+ end loop;
+
+ Put_Line ("Stats per iir_kind:");
+ for J in Iir_Kind loop
+ if Num (J) /= 0 then
+ Put_Line (' ' & Iir_Kind'Image (J) & ':'
+ & Natural'Image (Num (J)));
+ end if;
+ end loop;
+ Put_Line ("Stats per formats:");
+ for J in Format_Type loop
+ Put_Line (' ' & Format_Type'Image (J) & ':'
+ & Natural'Image (Formats (J)));
+ end loop;
+ end Disp_Stats;
+
+ function Iir_Predefined_Shortcut_P (Func : Iir_Predefined_Functions)
+ return Boolean is
+ begin
+ case Func is
+ when Iir_Predefined_Bit_And
+ | Iir_Predefined_Bit_Or
+ | Iir_Predefined_Bit_Nand
+ | Iir_Predefined_Bit_Nor
+ | Iir_Predefined_Boolean_And
+ | Iir_Predefined_Boolean_Or
+ | Iir_Predefined_Boolean_Nand
+ | Iir_Predefined_Boolean_Nor =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Iir_Predefined_Shortcut_P;
+
+ function Create_Iir_Error return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Node (Format_Short);
+ Set_Nkind (Res, Iir_Kind'Pos (Iir_Kind_Error));
+ Set_Base_Type (Res, Res);
+ return Res;
+ end Create_Iir_Error;
+
+ procedure Location_Copy (Target: Iir; Src: Iir) is
+ begin
+ Set_Location (Target, Get_Location (Src));
+ end Location_Copy;
+
+ -- Get kind
+ function Get_Kind (An_Iir: Iir) return Iir_Kind
+ is
+ -- Speed up: avoid to check that nkind is in the bounds of Iir_Kind.
+ pragma Suppress (Range_Check);
+ begin
+ return Iir_Kind'Val (Get_Nkind (An_Iir));
+ end Get_Kind;
+
+ function Time_Stamp_Id_To_Iir is new Ada.Unchecked_Conversion
+ (Source => Time_Stamp_Id, Target => Iir);
+
+ function Iir_To_Time_Stamp_Id is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => Time_Stamp_Id);
+
+ function Iir_To_Iir_List is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => Iir_List);
+ function Iir_List_To_Iir is new Ada.Unchecked_Conversion
+ (Source => Iir_List, Target => Iir);
+
+ function Iir_To_Token_Type (N : Iir) return Token_Type is
+ begin
+ return Token_Type'Val (N);
+ end Iir_To_Token_Type;
+
+ function Token_Type_To_Iir (T : Token_Type) return Iir is
+ begin
+ return Token_Type'Pos (T);
+ end Token_Type_To_Iir;
+
+-- function Iir_To_Iir_Index32 (N : Iir) return Iir_Index32 is
+-- begin
+-- return Iir_Index32 (N);
+-- end Iir_To_Iir_Index32;
+
+-- function Iir_Index32_To_Iir (V : Iir_Index32) return Iir is
+-- begin
+-- return Iir_Index32'Pos (V);
+-- end Iir_Index32_To_Iir;
+
+ function Iir_To_Name_Id (N : Iir) return Name_Id is
+ begin
+ return Iir'Pos (N);
+ end Iir_To_Name_Id;
+ pragma Inline (Iir_To_Name_Id);
+
+ function Name_Id_To_Iir (V : Name_Id) return Iir is
+ begin
+ return Name_Id'Pos (V);
+ end Name_Id_To_Iir;
+
+ function Iir_To_Iir_Int32 is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => Iir_Int32);
+
+ function Iir_Int32_To_Iir is new Ada.Unchecked_Conversion
+ (Source => Iir_Int32, Target => Iir);
+
+ function Iir_To_Source_Ptr (N : Iir) return Source_Ptr is
+ begin
+ return Source_Ptr (N);
+ end Iir_To_Source_Ptr;
+
+ function Source_Ptr_To_Iir (P : Source_Ptr) return Iir is
+ begin
+ return Iir (P);
+ end Source_Ptr_To_Iir;
+
+ function Iir_To_Location_Type (N : Iir) return Location_Type is
+ begin
+ return Location_Type (N);
+ end Iir_To_Location_Type;
+
+ function Location_Type_To_Iir (L : Location_Type) return Iir is
+ begin
+ return Iir (L);
+ end Location_Type_To_Iir;
+
+ function Iir_To_String_Id is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => String_Id);
+ function String_Id_To_Iir is new Ada.Unchecked_Conversion
+ (Source => String_Id, Target => Iir);
+
+ function Iir_To_Int32 is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => Int32);
+ function Int32_To_Iir is new Ada.Unchecked_Conversion
+ (Source => Int32, Target => Iir);
+
+ function Iir_To_PSL_Node is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => PSL_Node);
+
+ function PSL_Node_To_Iir is new Ada.Unchecked_Conversion
+ (Source => PSL_Node, Target => Iir);
+
+ function Iir_To_PSL_NFA is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => PSL_NFA);
+
+ function PSL_NFA_To_Iir is new Ada.Unchecked_Conversion
+ (Source => PSL_NFA, Target => Iir);
+
+ -- Subprograms
+ function Get_Format (Kind : Iir_Kind) return Format_Type is
+ begin
+ case Kind is
+ when Iir_Kind_Unused
+ | Iir_Kind_Error
+ | Iir_Kind_Library_Clause
+ | Iir_Kind_Use_Clause
+ | Iir_Kind_Null_Literal
+ | Iir_Kind_String_Literal
+ | Iir_Kind_Simple_Aggregate
+ | Iir_Kind_Overflow_Literal
+ | Iir_Kind_Waveform_Element
+ | Iir_Kind_Conditional_Waveform
+ | Iir_Kind_Association_Element_By_Expression
+ | Iir_Kind_Association_Element_By_Individual
+ | Iir_Kind_Association_Element_Open
+ | Iir_Kind_Association_Element_Package
+ | Iir_Kind_Choice_By_Others
+ | Iir_Kind_Choice_By_Expression
+ | Iir_Kind_Choice_By_Range
+ | Iir_Kind_Choice_By_None
+ | Iir_Kind_Choice_By_Name
+ | Iir_Kind_Entity_Aspect_Entity
+ | Iir_Kind_Entity_Aspect_Configuration
+ | Iir_Kind_Entity_Aspect_Open
+ | Iir_Kind_Block_Configuration
+ | Iir_Kind_Component_Configuration
+ | Iir_Kind_Entity_Class
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Aggregate_Info
+ | Iir_Kind_Procedure_Call
+ | Iir_Kind_Record_Element_Constraint
+ | Iir_Kind_Array_Element_Resolution
+ | Iir_Kind_Record_Resolution
+ | Iir_Kind_Record_Element_Resolution
+ | Iir_Kind_Disconnection_Specification
+ | Iir_Kind_Configuration_Specification
+ | Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Incomplete_Type_Definition
+ | Iir_Kind_File_Type_Definition
+ | Iir_Kind_Protected_Type_Declaration
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Physical_Type_Definition
+ | Iir_Kind_Range_Expression
+ | Iir_Kind_Protected_Type_Body
+ | Iir_Kind_Overload_List
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Nature_Declaration
+ | Iir_Kind_Subnature_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration
+ | Iir_Kind_Element_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Terminal_Declaration
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Identity_Operator
+ | Iir_Kind_Negation_Operator
+ | Iir_Kind_Absolute_Operator
+ | Iir_Kind_Not_Operator
+ | Iir_Kind_Condition_Operator
+ | Iir_Kind_Reduction_And_Operator
+ | Iir_Kind_Reduction_Or_Operator
+ | Iir_Kind_Reduction_Nand_Operator
+ | Iir_Kind_Reduction_Nor_Operator
+ | Iir_Kind_Reduction_Xor_Operator
+ | Iir_Kind_Reduction_Xnor_Operator
+ | Iir_Kind_And_Operator
+ | Iir_Kind_Or_Operator
+ | Iir_Kind_Nand_Operator
+ | Iir_Kind_Nor_Operator
+ | Iir_Kind_Xor_Operator
+ | Iir_Kind_Xnor_Operator
+ | Iir_Kind_Equality_Operator
+ | Iir_Kind_Inequality_Operator
+ | Iir_Kind_Less_Than_Operator
+ | Iir_Kind_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Greater_Than_Operator
+ | Iir_Kind_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Equality_Operator
+ | Iir_Kind_Match_Inequality_Operator
+ | Iir_Kind_Match_Less_Than_Operator
+ | Iir_Kind_Match_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Greater_Than_Operator
+ | Iir_Kind_Match_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Sll_Operator
+ | Iir_Kind_Sla_Operator
+ | Iir_Kind_Srl_Operator
+ | Iir_Kind_Sra_Operator
+ | Iir_Kind_Rol_Operator
+ | Iir_Kind_Ror_Operator
+ | Iir_Kind_Addition_Operator
+ | Iir_Kind_Substraction_Operator
+ | Iir_Kind_Concatenation_Operator
+ | Iir_Kind_Multiplication_Operator
+ | Iir_Kind_Division_Operator
+ | Iir_Kind_Modulus_Operator
+ | Iir_Kind_Remainder_Operator
+ | Iir_Kind_Exponentiation_Operator
+ | Iir_Kind_Function_Call
+ | Iir_Kind_Aggregate
+ | Iir_Kind_Parenthesis_Expression
+ | Iir_Kind_Qualified_Expression
+ | Iir_Kind_Type_Conversion
+ | Iir_Kind_Allocator_By_Expression
+ | Iir_Kind_Allocator_By_Subtype
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Psl_Expression
+ | Iir_Kind_Psl_Default_Clock
+ | Iir_Kind_Concurrent_Procedure_Call_Statement
+ | Iir_Kind_Null_Statement
+ | Iir_Kind_Variable_Assignment_Statement
+ | Iir_Kind_Return_Statement
+ | Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement
+ | Iir_Kind_Case_Statement
+ | Iir_Kind_Procedure_Call_Statement
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Operator_Symbol
+ | Iir_Kind_Selected_By_All_Name
+ | Iir_Kind_Parenthesis_Name
+ | Iir_Kind_Base_Attribute
+ | Iir_Kind_Left_Type_Attribute
+ | Iir_Kind_Right_Type_Attribute
+ | Iir_Kind_High_Type_Attribute
+ | Iir_Kind_Low_Type_Attribute
+ | Iir_Kind_Ascending_Type_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute
+ | Iir_Kind_Pos_Attribute
+ | Iir_Kind_Val_Attribute
+ | Iir_Kind_Succ_Attribute
+ | Iir_Kind_Pred_Attribute
+ | Iir_Kind_Leftof_Attribute
+ | Iir_Kind_Rightof_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Event_Attribute
+ | Iir_Kind_Active_Attribute
+ | Iir_Kind_Last_Event_Attribute
+ | Iir_Kind_Last_Active_Attribute
+ | Iir_Kind_Last_Value_Attribute
+ | Iir_Kind_Driving_Attribute
+ | Iir_Kind_Driving_Value_Attribute
+ | Iir_Kind_Behavior_Attribute
+ | Iir_Kind_Structure_Attribute
+ | Iir_Kind_Simple_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute
+ | Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Left_Array_Attribute
+ | Iir_Kind_Right_Array_Attribute
+ | Iir_Kind_High_Array_Attribute
+ | Iir_Kind_Low_Array_Attribute
+ | Iir_Kind_Length_Array_Attribute
+ | Iir_Kind_Ascending_Array_Attribute
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute
+ | Iir_Kind_Attribute_Name =>
+ return Format_Short;
+ when Iir_Kind_Design_File
+ | Iir_Kind_Design_Unit
+ | Iir_Kind_Bit_String_Literal
+ | Iir_Kind_Block_Header
+ | Iir_Kind_Binding_Indication
+ | Iir_Kind_Signature
+ | Iir_Kind_Attribute_Specification
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Subtype_Definition
+ | Iir_Kind_Scalar_Nature_Definition
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Package_Header
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Library_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Psl_Declaration
+ | Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Interface_Package_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Component_Instantiation_Statement
+ | Iir_Kind_Simple_Simultaneous_Statement
+ | Iir_Kind_Signal_Assignment_Statement
+ | Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement
+ | Iir_Kind_Wait_Statement
+ | Iir_Kind_If_Statement
+ | Iir_Kind_Elsif =>
+ return Format_Medium;
+ when Iir_Kind_Floating_Point_Literal
+ | Iir_Kind_Physical_Fp_Literal =>
+ return Format_Fp;
+ when Iir_Kind_Integer_Literal
+ | Iir_Kind_Physical_Int_Literal =>
+ return Format_Int;
+ end case;
+ end Get_Format;
+
+ function Get_First_Design_Unit (Design : Iir) return Iir is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_First_Design_Unit (Get_Kind (Design)));
+ return Get_Field5 (Design);
+ end Get_First_Design_Unit;
+
+ procedure Set_First_Design_Unit (Design : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_First_Design_Unit (Get_Kind (Design)));
+ Set_Field5 (Design, Chain);
+ end Set_First_Design_Unit;
+
+ function Get_Last_Design_Unit (Design : Iir) return Iir is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_Last_Design_Unit (Get_Kind (Design)));
+ return Get_Field6 (Design);
+ end Get_Last_Design_Unit;
+
+ procedure Set_Last_Design_Unit (Design : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_Last_Design_Unit (Get_Kind (Design)));
+ Set_Field6 (Design, Chain);
+ end Set_Last_Design_Unit;
+
+ function Get_Library_Declaration (Design : Iir) return Iir is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_Library_Declaration (Get_Kind (Design)));
+ return Get_Field1 (Design);
+ end Get_Library_Declaration;
+
+ procedure Set_Library_Declaration (Design : Iir; Library : Iir) is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_Library_Declaration (Get_Kind (Design)));
+ Set_Field1 (Design, Library);
+ end Set_Library_Declaration;
+
+ function Get_File_Time_Stamp (Design : Iir) return Time_Stamp_Id is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_File_Time_Stamp (Get_Kind (Design)));
+ return Iir_To_Time_Stamp_Id (Get_Field4 (Design));
+ end Get_File_Time_Stamp;
+
+ procedure Set_File_Time_Stamp (Design : Iir; Stamp : Time_Stamp_Id) is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_File_Time_Stamp (Get_Kind (Design)));
+ Set_Field4 (Design, Time_Stamp_Id_To_Iir (Stamp));
+ end Set_File_Time_Stamp;
+
+ function Get_Analysis_Time_Stamp (Design : Iir) return Time_Stamp_Id is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_Analysis_Time_Stamp (Get_Kind (Design)));
+ return Iir_To_Time_Stamp_Id (Get_Field3 (Design));
+ end Get_Analysis_Time_Stamp;
+
+ procedure Set_Analysis_Time_Stamp (Design : Iir; Stamp : Time_Stamp_Id) is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_Analysis_Time_Stamp (Get_Kind (Design)));
+ Set_Field3 (Design, Time_Stamp_Id_To_Iir (Stamp));
+ end Set_Analysis_Time_Stamp;
+
+ function Get_Library (File : Iir_Design_File) return Iir is
+ begin
+ pragma Assert (File /= Null_Iir);
+ pragma Assert (Has_Library (Get_Kind (File)));
+ return Get_Field0 (File);
+ end Get_Library;
+
+ procedure Set_Library (File : Iir_Design_File; Lib : Iir) is
+ begin
+ pragma Assert (File /= Null_Iir);
+ pragma Assert (Has_Library (Get_Kind (File)));
+ Set_Field0 (File, Lib);
+ end Set_Library;
+
+ function Get_File_Dependence_List (File : Iir_Design_File) return Iir_List
+ is
+ begin
+ pragma Assert (File /= Null_Iir);
+ pragma Assert (Has_File_Dependence_List (Get_Kind (File)));
+ return Iir_To_Iir_List (Get_Field1 (File));
+ end Get_File_Dependence_List;
+
+ procedure Set_File_Dependence_List (File : Iir_Design_File; Lst : Iir_List)
+ is
+ begin
+ pragma Assert (File /= Null_Iir);
+ pragma Assert (Has_File_Dependence_List (Get_Kind (File)));
+ Set_Field1 (File, Iir_List_To_Iir (Lst));
+ end Set_File_Dependence_List;
+
+ function Get_Design_File_Filename (File : Iir_Design_File) return Name_Id
+ is
+ begin
+ pragma Assert (File /= Null_Iir);
+ pragma Assert (Has_Design_File_Filename (Get_Kind (File)));
+ return Name_Id'Val (Get_Field12 (File));
+ end Get_Design_File_Filename;
+
+ procedure Set_Design_File_Filename (File : Iir_Design_File; Name : Name_Id)
+ is
+ begin
+ pragma Assert (File /= Null_Iir);
+ pragma Assert (Has_Design_File_Filename (Get_Kind (File)));
+ Set_Field12 (File, Name_Id'Pos (Name));
+ end Set_Design_File_Filename;
+
+ function Get_Design_File_Directory (File : Iir_Design_File) return Name_Id
+ is
+ begin
+ pragma Assert (File /= Null_Iir);
+ pragma Assert (Has_Design_File_Directory (Get_Kind (File)));
+ return Name_Id'Val (Get_Field11 (File));
+ end Get_Design_File_Directory;
+
+ procedure Set_Design_File_Directory (File : Iir_Design_File; Dir : Name_Id)
+ is
+ begin
+ pragma Assert (File /= Null_Iir);
+ pragma Assert (Has_Design_File_Directory (Get_Kind (File)));
+ Set_Field11 (File, Name_Id'Pos (Dir));
+ end Set_Design_File_Directory;
+
+ function Get_Design_File (Unit : Iir_Design_Unit) return Iir is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Design_File (Get_Kind (Unit)));
+ return Get_Field0 (Unit);
+ end Get_Design_File;
+
+ procedure Set_Design_File (Unit : Iir_Design_Unit; File : Iir) is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Design_File (Get_Kind (Unit)));
+ Set_Field0 (Unit, File);
+ end Set_Design_File;
+
+ function Get_Design_File_Chain (Library : Iir) return Iir is
+ begin
+ pragma Assert (Library /= Null_Iir);
+ pragma Assert (Has_Design_File_Chain (Get_Kind (Library)));
+ return Get_Field1 (Library);
+ end Get_Design_File_Chain;
+
+ procedure Set_Design_File_Chain (Library : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Library /= Null_Iir);
+ pragma Assert (Has_Design_File_Chain (Get_Kind (Library)));
+ Set_Field1 (Library, Chain);
+ end Set_Design_File_Chain;
+
+ function Get_Library_Directory (Library : Iir) return Name_Id is
+ begin
+ pragma Assert (Library /= Null_Iir);
+ pragma Assert (Has_Library_Directory (Get_Kind (Library)));
+ return Name_Id'Val (Get_Field11 (Library));
+ end Get_Library_Directory;
+
+ procedure Set_Library_Directory (Library : Iir; Dir : Name_Id) is
+ begin
+ pragma Assert (Library /= Null_Iir);
+ pragma Assert (Has_Library_Directory (Get_Kind (Library)));
+ Set_Field11 (Library, Name_Id'Pos (Dir));
+ end Set_Library_Directory;
+
+ function Get_Date (Target : Iir) return Date_Type is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Date (Get_Kind (Target)));
+ return Date_Type'Val (Get_Field10 (Target));
+ end Get_Date;
+
+ procedure Set_Date (Target : Iir; Date : Date_Type) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Date (Get_Kind (Target)));
+ Set_Field10 (Target, Date_Type'Pos (Date));
+ end Set_Date;
+
+ function Get_Context_Items (Design_Unit : Iir) return Iir is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Context_Items (Get_Kind (Design_Unit)));
+ return Get_Field1 (Design_Unit);
+ end Get_Context_Items;
+
+ procedure Set_Context_Items (Design_Unit : Iir; Items_Chain : Iir) is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Context_Items (Get_Kind (Design_Unit)));
+ Set_Field1 (Design_Unit, Items_Chain);
+ end Set_Context_Items;
+
+ function Get_Dependence_List (Unit : Iir) return Iir_List is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Dependence_List (Get_Kind (Unit)));
+ return Iir_To_Iir_List (Get_Field8 (Unit));
+ end Get_Dependence_List;
+
+ procedure Set_Dependence_List (Unit : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Dependence_List (Get_Kind (Unit)));
+ Set_Field8 (Unit, Iir_List_To_Iir (List));
+ end Set_Dependence_List;
+
+ function Get_Analysis_Checks_List (Unit : Iir) return Iir_List is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Analysis_Checks_List (Get_Kind (Unit)));
+ return Iir_To_Iir_List (Get_Field9 (Unit));
+ end Get_Analysis_Checks_List;
+
+ procedure Set_Analysis_Checks_List (Unit : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Analysis_Checks_List (Get_Kind (Unit)));
+ Set_Field9 (Unit, Iir_List_To_Iir (List));
+ end Set_Analysis_Checks_List;
+
+ function Get_Date_State (Unit : Iir_Design_Unit) return Date_State_Type is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Date_State (Get_Kind (Unit)));
+ return Date_State_Type'Val (Get_State1 (Unit));
+ end Get_Date_State;
+
+ procedure Set_Date_State (Unit : Iir_Design_Unit; State : Date_State_Type)
+ is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Date_State (Get_Kind (Unit)));
+ Set_State1 (Unit, Date_State_Type'Pos (State));
+ end Set_Date_State;
+
+ function Get_Guarded_Target_State (Stmt : Iir) return Tri_State_Type is
+ begin
+ pragma Assert (Stmt /= Null_Iir);
+ pragma Assert (Has_Guarded_Target_State (Get_Kind (Stmt)));
+ return Tri_State_Type'Val (Get_State3 (Stmt));
+ end Get_Guarded_Target_State;
+
+ procedure Set_Guarded_Target_State (Stmt : Iir; State : Tri_State_Type) is
+ begin
+ pragma Assert (Stmt /= Null_Iir);
+ pragma Assert (Has_Guarded_Target_State (Get_Kind (Stmt)));
+ Set_State3 (Stmt, Tri_State_Type'Pos (State));
+ end Set_Guarded_Target_State;
+
+ function Get_Library_Unit (Design_Unit : Iir_Design_Unit) return Iir is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Library_Unit (Get_Kind (Design_Unit)));
+ return Get_Field5 (Design_Unit);
+ end Get_Library_Unit;
+
+ procedure Set_Library_Unit (Design_Unit : Iir_Design_Unit; Lib_Unit : Iir)
+ is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Library_Unit (Get_Kind (Design_Unit)));
+ Set_Field5 (Design_Unit, Lib_Unit);
+ end Set_Library_Unit;
+
+ function Get_Hash_Chain (Design_Unit : Iir_Design_Unit) return Iir is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Hash_Chain (Get_Kind (Design_Unit)));
+ return Get_Field7 (Design_Unit);
+ end Get_Hash_Chain;
+
+ procedure Set_Hash_Chain (Design_Unit : Iir_Design_Unit; Chain : Iir) is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Hash_Chain (Get_Kind (Design_Unit)));
+ Set_Field7 (Design_Unit, Chain);
+ end Set_Hash_Chain;
+
+ function Get_Design_Unit_Source_Pos (Design_Unit : Iir) return Source_Ptr
+ is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Design_Unit_Source_Pos (Get_Kind (Design_Unit)));
+ return Iir_To_Source_Ptr (Get_Field4 (Design_Unit));
+ end Get_Design_Unit_Source_Pos;
+
+ procedure Set_Design_Unit_Source_Pos (Design_Unit : Iir; Pos : Source_Ptr)
+ is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Design_Unit_Source_Pos (Get_Kind (Design_Unit)));
+ Set_Field4 (Design_Unit, Source_Ptr_To_Iir (Pos));
+ end Set_Design_Unit_Source_Pos;
+
+ function Get_Design_Unit_Source_Line (Design_Unit : Iir) return Int32 is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Design_Unit_Source_Line (Get_Kind (Design_Unit)));
+ return Iir_To_Int32 (Get_Field11 (Design_Unit));
+ end Get_Design_Unit_Source_Line;
+
+ procedure Set_Design_Unit_Source_Line (Design_Unit : Iir; Line : Int32) is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Design_Unit_Source_Line (Get_Kind (Design_Unit)));
+ Set_Field11 (Design_Unit, Int32_To_Iir (Line));
+ end Set_Design_Unit_Source_Line;
+
+ function Get_Design_Unit_Source_Col (Design_Unit : Iir) return Int32 is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Design_Unit_Source_Col (Get_Kind (Design_Unit)));
+ return Iir_To_Int32 (Get_Field12 (Design_Unit));
+ end Get_Design_Unit_Source_Col;
+
+ procedure Set_Design_Unit_Source_Col (Design_Unit : Iir; Line : Int32) is
+ begin
+ pragma Assert (Design_Unit /= Null_Iir);
+ pragma Assert (Has_Design_Unit_Source_Col (Get_Kind (Design_Unit)));
+ Set_Field12 (Design_Unit, Int32_To_Iir (Line));
+ end Set_Design_Unit_Source_Col;
+
+ function Get_Value (Lit : Iir) return Iir_Int64 is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Value (Get_Kind (Lit)));
+ return Get_Int64 (Lit);
+ end Get_Value;
+
+ procedure Set_Value (Lit : Iir; Val : Iir_Int64) is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Value (Get_Kind (Lit)));
+ Set_Int64 (Lit, Val);
+ end Set_Value;
+
+ function Get_Enum_Pos (Lit : Iir) return Iir_Int32 is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Enum_Pos (Get_Kind (Lit)));
+ return Iir_Int32'Val (Get_Field10 (Lit));
+ end Get_Enum_Pos;
+
+ procedure Set_Enum_Pos (Lit : Iir; Val : Iir_Int32) is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Enum_Pos (Get_Kind (Lit)));
+ Set_Field10 (Lit, Iir_Int32'Pos (Val));
+ end Set_Enum_Pos;
+
+ function Get_Physical_Literal (Unit : Iir) return Iir is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Physical_Literal (Get_Kind (Unit)));
+ return Get_Field6 (Unit);
+ end Get_Physical_Literal;
+
+ procedure Set_Physical_Literal (Unit : Iir; Lit : Iir) is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Physical_Literal (Get_Kind (Unit)));
+ Set_Field6 (Unit, Lit);
+ end Set_Physical_Literal;
+
+ function Get_Physical_Unit_Value (Unit : Iir) return Iir is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Physical_Unit_Value (Get_Kind (Unit)));
+ return Get_Field7 (Unit);
+ end Get_Physical_Unit_Value;
+
+ procedure Set_Physical_Unit_Value (Unit : Iir; Lit : Iir) is
+ begin
+ pragma Assert (Unit /= Null_Iir);
+ pragma Assert (Has_Physical_Unit_Value (Get_Kind (Unit)));
+ Set_Field7 (Unit, Lit);
+ end Set_Physical_Unit_Value;
+
+ function Get_Fp_Value (Lit : Iir) return Iir_Fp64 is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Fp_Value (Get_Kind (Lit)));
+ return Get_Fp64 (Lit);
+ end Get_Fp_Value;
+
+ procedure Set_Fp_Value (Lit : Iir; Val : Iir_Fp64) is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Fp_Value (Get_Kind (Lit)));
+ Set_Fp64 (Lit, Val);
+ end Set_Fp_Value;
+
+ function Get_Enumeration_Decl (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Enumeration_Decl (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Enumeration_Decl;
+
+ procedure Set_Enumeration_Decl (Target : Iir; Lit : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Enumeration_Decl (Get_Kind (Target)));
+ Set_Field6 (Target, Lit);
+ end Set_Enumeration_Decl;
+
+ function Get_Simple_Aggregate_List (Target : Iir) return Iir_List is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Simple_Aggregate_List (Get_Kind (Target)));
+ return Iir_To_Iir_List (Get_Field3 (Target));
+ end Get_Simple_Aggregate_List;
+
+ procedure Set_Simple_Aggregate_List (Target : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Simple_Aggregate_List (Get_Kind (Target)));
+ Set_Field3 (Target, Iir_List_To_Iir (List));
+ end Set_Simple_Aggregate_List;
+
+ function Get_Bit_String_Base (Lit : Iir) return Base_Type is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Bit_String_Base (Get_Kind (Lit)));
+ return Base_Type'Val (Get_Field8 (Lit));
+ end Get_Bit_String_Base;
+
+ procedure Set_Bit_String_Base (Lit : Iir; Base : Base_Type) is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Bit_String_Base (Get_Kind (Lit)));
+ Set_Field8 (Lit, Base_Type'Pos (Base));
+ end Set_Bit_String_Base;
+
+ function Get_Bit_String_0 (Lit : Iir) return Iir is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Bit_String_0 (Get_Kind (Lit)));
+ return Get_Field6 (Lit);
+ end Get_Bit_String_0;
+
+ procedure Set_Bit_String_0 (Lit : Iir; El : Iir) is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Bit_String_0 (Get_Kind (Lit)));
+ Set_Field6 (Lit, El);
+ end Set_Bit_String_0;
+
+ function Get_Bit_String_1 (Lit : Iir) return Iir is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Bit_String_1 (Get_Kind (Lit)));
+ return Get_Field7 (Lit);
+ end Get_Bit_String_1;
+
+ procedure Set_Bit_String_1 (Lit : Iir; El : Iir) is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Bit_String_1 (Get_Kind (Lit)));
+ Set_Field7 (Lit, El);
+ end Set_Bit_String_1;
+
+ function Get_Literal_Origin (Lit : Iir) return Iir is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Literal_Origin (Get_Kind (Lit)));
+ return Get_Field2 (Lit);
+ end Get_Literal_Origin;
+
+ procedure Set_Literal_Origin (Lit : Iir; Orig : Iir) is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Literal_Origin (Get_Kind (Lit)));
+ Set_Field2 (Lit, Orig);
+ end Set_Literal_Origin;
+
+ function Get_Range_Origin (Lit : Iir) return Iir is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Range_Origin (Get_Kind (Lit)));
+ return Get_Field4 (Lit);
+ end Get_Range_Origin;
+
+ procedure Set_Range_Origin (Lit : Iir; Orig : Iir) is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Range_Origin (Get_Kind (Lit)));
+ Set_Field4 (Lit, Orig);
+ end Set_Range_Origin;
+
+ function Get_Literal_Subtype (Lit : Iir) return Iir is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Literal_Subtype (Get_Kind (Lit)));
+ return Get_Field5 (Lit);
+ end Get_Literal_Subtype;
+
+ procedure Set_Literal_Subtype (Lit : Iir; Atype : Iir) is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_Literal_Subtype (Get_Kind (Lit)));
+ Set_Field5 (Lit, Atype);
+ end Set_Literal_Subtype;
+
+ function Get_Entity_Class (Target : Iir) return Token_Type is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Entity_Class (Get_Kind (Target)));
+ return Iir_To_Token_Type (Get_Field3 (Target));
+ end Get_Entity_Class;
+
+ procedure Set_Entity_Class (Target : Iir; Kind : Token_Type) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Entity_Class (Get_Kind (Target)));
+ Set_Field3 (Target, Token_Type_To_Iir (Kind));
+ end Set_Entity_Class;
+
+ function Get_Entity_Name_List (Target : Iir) return Iir_List is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Entity_Name_List (Get_Kind (Target)));
+ return Iir_To_Iir_List (Get_Field1 (Target));
+ end Get_Entity_Name_List;
+
+ procedure Set_Entity_Name_List (Target : Iir; Names : Iir_List) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Entity_Name_List (Get_Kind (Target)));
+ Set_Field1 (Target, Iir_List_To_Iir (Names));
+ end Set_Entity_Name_List;
+
+ function Get_Attribute_Designator (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Attribute_Designator (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Attribute_Designator;
+
+ procedure Set_Attribute_Designator (Target : Iir; Designator : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Attribute_Designator (Get_Kind (Target)));
+ Set_Field6 (Target, Designator);
+ end Set_Attribute_Designator;
+
+ function Get_Attribute_Specification_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Attribute_Specification_Chain (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_Attribute_Specification_Chain;
+
+ procedure Set_Attribute_Specification_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Attribute_Specification_Chain (Get_Kind (Target)));
+ Set_Field7 (Target, Chain);
+ end Set_Attribute_Specification_Chain;
+
+ function Get_Attribute_Specification (Val : Iir) return Iir is
+ begin
+ pragma Assert (Val /= Null_Iir);
+ pragma Assert (Has_Attribute_Specification (Get_Kind (Val)));
+ return Get_Field4 (Val);
+ end Get_Attribute_Specification;
+
+ procedure Set_Attribute_Specification (Val : Iir; Attr : Iir) is
+ begin
+ pragma Assert (Val /= Null_Iir);
+ pragma Assert (Has_Attribute_Specification (Get_Kind (Val)));
+ Set_Field4 (Val, Attr);
+ end Set_Attribute_Specification;
+
+ function Get_Signal_List (Target : Iir) return Iir_List is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Signal_List (Get_Kind (Target)));
+ return Iir_To_Iir_List (Get_Field3 (Target));
+ end Get_Signal_List;
+
+ procedure Set_Signal_List (Target : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Signal_List (Get_Kind (Target)));
+ Set_Field3 (Target, Iir_List_To_Iir (List));
+ end Set_Signal_List;
+
+ function Get_Designated_Entity (Val : Iir_Attribute_Value) return Iir is
+ begin
+ pragma Assert (Val /= Null_Iir);
+ pragma Assert (Has_Designated_Entity (Get_Kind (Val)));
+ return Get_Field3 (Val);
+ end Get_Designated_Entity;
+
+ procedure Set_Designated_Entity (Val : Iir_Attribute_Value; Entity : Iir)
+ is
+ begin
+ pragma Assert (Val /= Null_Iir);
+ pragma Assert (Has_Designated_Entity (Get_Kind (Val)));
+ Set_Field3 (Val, Entity);
+ end Set_Designated_Entity;
+
+ function Get_Formal (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Formal (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Formal;
+
+ procedure Set_Formal (Target : Iir; Formal : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Formal (Get_Kind (Target)));
+ Set_Field1 (Target, Formal);
+ end Set_Formal;
+
+ function Get_Actual (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Actual (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Actual;
+
+ procedure Set_Actual (Target : Iir; Actual : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Actual (Get_Kind (Target)));
+ Set_Field3 (Target, Actual);
+ end Set_Actual;
+
+ function Get_In_Conversion (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_In_Conversion (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_In_Conversion;
+
+ procedure Set_In_Conversion (Target : Iir; Conv : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_In_Conversion (Get_Kind (Target)));
+ Set_Field4 (Target, Conv);
+ end Set_In_Conversion;
+
+ function Get_Out_Conversion (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Out_Conversion (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Out_Conversion;
+
+ procedure Set_Out_Conversion (Target : Iir; Conv : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Out_Conversion (Get_Kind (Target)));
+ Set_Field5 (Target, Conv);
+ end Set_Out_Conversion;
+
+ function Get_Whole_Association_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Whole_Association_Flag (Get_Kind (Target)));
+ return Get_Flag1 (Target);
+ end Get_Whole_Association_Flag;
+
+ procedure Set_Whole_Association_Flag (Target : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Whole_Association_Flag (Get_Kind (Target)));
+ Set_Flag1 (Target, Flag);
+ end Set_Whole_Association_Flag;
+
+ function Get_Collapse_Signal_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Collapse_Signal_Flag (Get_Kind (Target)));
+ return Get_Flag2 (Target);
+ end Get_Collapse_Signal_Flag;
+
+ procedure Set_Collapse_Signal_Flag (Target : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Collapse_Signal_Flag (Get_Kind (Target)));
+ Set_Flag2 (Target, Flag);
+ end Set_Collapse_Signal_Flag;
+
+ function Get_Artificial_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Artificial_Flag (Get_Kind (Target)));
+ return Get_Flag3 (Target);
+ end Get_Artificial_Flag;
+
+ procedure Set_Artificial_Flag (Target : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Artificial_Flag (Get_Kind (Target)));
+ Set_Flag3 (Target, Flag);
+ end Set_Artificial_Flag;
+
+ function Get_Open_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Open_Flag (Get_Kind (Target)));
+ return Get_Flag3 (Target);
+ end Get_Open_Flag;
+
+ procedure Set_Open_Flag (Target : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Open_Flag (Get_Kind (Target)));
+ Set_Flag3 (Target, Flag);
+ end Set_Open_Flag;
+
+ function Get_After_Drivers_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_After_Drivers_Flag (Get_Kind (Target)));
+ return Get_Flag5 (Target);
+ end Get_After_Drivers_Flag;
+
+ procedure Set_After_Drivers_Flag (Target : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_After_Drivers_Flag (Get_Kind (Target)));
+ Set_Flag5 (Target, Flag);
+ end Set_After_Drivers_Flag;
+
+ function Get_We_Value (We : Iir_Waveform_Element) return Iir is
+ begin
+ pragma Assert (We /= Null_Iir);
+ pragma Assert (Has_We_Value (Get_Kind (We)));
+ return Get_Field1 (We);
+ end Get_We_Value;
+
+ procedure Set_We_Value (We : Iir_Waveform_Element; An_Iir : Iir) is
+ begin
+ pragma Assert (We /= Null_Iir);
+ pragma Assert (Has_We_Value (Get_Kind (We)));
+ Set_Field1 (We, An_Iir);
+ end Set_We_Value;
+
+ function Get_Time (We : Iir_Waveform_Element) return Iir is
+ begin
+ pragma Assert (We /= Null_Iir);
+ pragma Assert (Has_Time (Get_Kind (We)));
+ return Get_Field3 (We);
+ end Get_Time;
+
+ procedure Set_Time (We : Iir_Waveform_Element; An_Iir : Iir) is
+ begin
+ pragma Assert (We /= Null_Iir);
+ pragma Assert (Has_Time (Get_Kind (We)));
+ Set_Field3 (We, An_Iir);
+ end Set_Time;
+
+ function Get_Associated_Expr (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Associated_Expr (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Associated_Expr;
+
+ procedure Set_Associated_Expr (Target : Iir; Associated : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Associated_Expr (Get_Kind (Target)));
+ Set_Field3 (Target, Associated);
+ end Set_Associated_Expr;
+
+ function Get_Associated_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Associated_Chain (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Associated_Chain;
+
+ procedure Set_Associated_Chain (Target : Iir; Associated : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Associated_Chain (Get_Kind (Target)));
+ Set_Field4 (Target, Associated);
+ end Set_Associated_Chain;
+
+ function Get_Choice_Name (Choice : Iir) return Iir is
+ begin
+ pragma Assert (Choice /= Null_Iir);
+ pragma Assert (Has_Choice_Name (Get_Kind (Choice)));
+ return Get_Field5 (Choice);
+ end Get_Choice_Name;
+
+ procedure Set_Choice_Name (Choice : Iir; Name : Iir) is
+ begin
+ pragma Assert (Choice /= Null_Iir);
+ pragma Assert (Has_Choice_Name (Get_Kind (Choice)));
+ Set_Field5 (Choice, Name);
+ end Set_Choice_Name;
+
+ function Get_Choice_Expression (Choice : Iir) return Iir is
+ begin
+ pragma Assert (Choice /= Null_Iir);
+ pragma Assert (Has_Choice_Expression (Get_Kind (Choice)));
+ return Get_Field5 (Choice);
+ end Get_Choice_Expression;
+
+ procedure Set_Choice_Expression (Choice : Iir; Name : Iir) is
+ begin
+ pragma Assert (Choice /= Null_Iir);
+ pragma Assert (Has_Choice_Expression (Get_Kind (Choice)));
+ Set_Field5 (Choice, Name);
+ end Set_Choice_Expression;
+
+ function Get_Choice_Range (Choice : Iir) return Iir is
+ begin
+ pragma Assert (Choice /= Null_Iir);
+ pragma Assert (Has_Choice_Range (Get_Kind (Choice)));
+ return Get_Field5 (Choice);
+ end Get_Choice_Range;
+
+ procedure Set_Choice_Range (Choice : Iir; Name : Iir) is
+ begin
+ pragma Assert (Choice /= Null_Iir);
+ pragma Assert (Has_Choice_Range (Get_Kind (Choice)));
+ Set_Field5 (Choice, Name);
+ end Set_Choice_Range;
+
+ function Get_Same_Alternative_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Same_Alternative_Flag (Get_Kind (Target)));
+ return Get_Flag1 (Target);
+ end Get_Same_Alternative_Flag;
+
+ procedure Set_Same_Alternative_Flag (Target : Iir; Val : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Same_Alternative_Flag (Get_Kind (Target)));
+ Set_Flag1 (Target, Val);
+ end Set_Same_Alternative_Flag;
+
+ function Get_Architecture (Target : Iir_Entity_Aspect_Entity) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Architecture (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Architecture;
+
+ procedure Set_Architecture (Target : Iir_Entity_Aspect_Entity; Arch : Iir)
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Architecture (Get_Kind (Target)));
+ Set_Field3 (Target, Arch);
+ end Set_Architecture;
+
+ function Get_Block_Specification (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Block_Specification (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Block_Specification;
+
+ procedure Set_Block_Specification (Target : Iir; Block : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Block_Specification (Get_Kind (Target)));
+ Set_Field5 (Target, Block);
+ end Set_Block_Specification;
+
+ function Get_Prev_Block_Configuration (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Prev_Block_Configuration (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Prev_Block_Configuration;
+
+ procedure Set_Prev_Block_Configuration (Target : Iir; Block : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Prev_Block_Configuration (Get_Kind (Target)));
+ Set_Field4 (Target, Block);
+ end Set_Prev_Block_Configuration;
+
+ function Get_Configuration_Item_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Configuration_Item_Chain (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Configuration_Item_Chain;
+
+ procedure Set_Configuration_Item_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Configuration_Item_Chain (Get_Kind (Target)));
+ Set_Field3 (Target, Chain);
+ end Set_Configuration_Item_Chain;
+
+ function Get_Attribute_Value_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Attribute_Value_Chain (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Attribute_Value_Chain;
+
+ procedure Set_Attribute_Value_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Attribute_Value_Chain (Get_Kind (Target)));
+ Set_Field4 (Target, Chain);
+ end Set_Attribute_Value_Chain;
+
+ function Get_Spec_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Spec_Chain (Get_Kind (Target)));
+ return Get_Field0 (Target);
+ end Get_Spec_Chain;
+
+ procedure Set_Spec_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Spec_Chain (Get_Kind (Target)));
+ Set_Field0 (Target, Chain);
+ end Set_Spec_Chain;
+
+ function Get_Attribute_Value_Spec_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Attribute_Value_Spec_Chain (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Attribute_Value_Spec_Chain;
+
+ procedure Set_Attribute_Value_Spec_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Attribute_Value_Spec_Chain (Get_Kind (Target)));
+ Set_Field4 (Target, Chain);
+ end Set_Attribute_Value_Spec_Chain;
+
+ function Get_Entity_Name (Arch : Iir) return Iir is
+ begin
+ pragma Assert (Arch /= Null_Iir);
+ pragma Assert (Has_Entity_Name (Get_Kind (Arch)));
+ return Get_Field2 (Arch);
+ end Get_Entity_Name;
+
+ procedure Set_Entity_Name (Arch : Iir; Entity : Iir) is
+ begin
+ pragma Assert (Arch /= Null_Iir);
+ pragma Assert (Has_Entity_Name (Get_Kind (Arch)));
+ Set_Field2 (Arch, Entity);
+ end Set_Entity_Name;
+
+ function Get_Package (Package_Body : Iir) return Iir is
+ begin
+ pragma Assert (Package_Body /= Null_Iir);
+ pragma Assert (Has_Package (Get_Kind (Package_Body)));
+ return Get_Field4 (Package_Body);
+ end Get_Package;
+
+ procedure Set_Package (Package_Body : Iir; Decl : Iir) is
+ begin
+ pragma Assert (Package_Body /= Null_Iir);
+ pragma Assert (Has_Package (Get_Kind (Package_Body)));
+ Set_Field4 (Package_Body, Decl);
+ end Set_Package;
+
+ function Get_Package_Body (Pkg : Iir) return Iir is
+ begin
+ pragma Assert (Pkg /= Null_Iir);
+ pragma Assert (Has_Package_Body (Get_Kind (Pkg)));
+ return Get_Field2 (Pkg);
+ end Get_Package_Body;
+
+ procedure Set_Package_Body (Pkg : Iir; Decl : Iir) is
+ begin
+ pragma Assert (Pkg /= Null_Iir);
+ pragma Assert (Has_Package_Body (Get_Kind (Pkg)));
+ Set_Field2 (Pkg, Decl);
+ end Set_Package_Body;
+
+ function Get_Need_Body (Decl : Iir_Package_Declaration) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Need_Body (Get_Kind (Decl)));
+ return Get_Flag1 (Decl);
+ end Get_Need_Body;
+
+ procedure Set_Need_Body (Decl : Iir_Package_Declaration; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Need_Body (Get_Kind (Decl)));
+ Set_Flag1 (Decl, Flag);
+ end Set_Need_Body;
+
+ function Get_Block_Configuration (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Block_Configuration (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Block_Configuration;
+
+ procedure Set_Block_Configuration (Target : Iir; Block : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Block_Configuration (Get_Kind (Target)));
+ Set_Field5 (Target, Block);
+ end Set_Block_Configuration;
+
+ function Get_Concurrent_Statement_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Concurrent_Statement_Chain (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Concurrent_Statement_Chain;
+
+ procedure Set_Concurrent_Statement_Chain (Target : Iir; First : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Concurrent_Statement_Chain (Get_Kind (Target)));
+ Set_Field5 (Target, First);
+ end Set_Concurrent_Statement_Chain;
+
+ function Get_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Chain (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Chain;
+
+ procedure Set_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Chain (Get_Kind (Target)));
+ Set_Field2 (Target, Chain);
+ end Set_Chain;
+
+ function Get_Port_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Port_Chain (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_Port_Chain;
+
+ procedure Set_Port_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Port_Chain (Get_Kind (Target)));
+ Set_Field7 (Target, Chain);
+ end Set_Port_Chain;
+
+ function Get_Generic_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Generic_Chain (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Generic_Chain;
+
+ procedure Set_Generic_Chain (Target : Iir; Generics : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Generic_Chain (Get_Kind (Target)));
+ Set_Field6 (Target, Generics);
+ end Set_Generic_Chain;
+
+ function Get_Type (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Type (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Type;
+
+ procedure Set_Type (Target : Iir; Atype : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Type (Get_Kind (Target)));
+ Set_Field1 (Target, Atype);
+ end Set_Type;
+
+ function Get_Subtype_Indication (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subtype_Indication (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Subtype_Indication;
+
+ procedure Set_Subtype_Indication (Target : Iir; Atype : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subtype_Indication (Get_Kind (Target)));
+ Set_Field5 (Target, Atype);
+ end Set_Subtype_Indication;
+
+ function Get_Discrete_Range (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Discrete_Range (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Discrete_Range;
+
+ procedure Set_Discrete_Range (Target : Iir; Rng : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Discrete_Range (Get_Kind (Target)));
+ Set_Field6 (Target, Rng);
+ end Set_Discrete_Range;
+
+ function Get_Type_Definition (Decl : Iir) return Iir is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Type_Definition (Get_Kind (Decl)));
+ return Get_Field1 (Decl);
+ end Get_Type_Definition;
+
+ procedure Set_Type_Definition (Decl : Iir; Atype : Iir) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Type_Definition (Get_Kind (Decl)));
+ Set_Field1 (Decl, Atype);
+ end Set_Type_Definition;
+
+ function Get_Subtype_Definition (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subtype_Definition (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Subtype_Definition;
+
+ procedure Set_Subtype_Definition (Target : Iir; Def : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subtype_Definition (Get_Kind (Target)));
+ Set_Field4 (Target, Def);
+ end Set_Subtype_Definition;
+
+ function Get_Nature (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Nature (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Nature;
+
+ procedure Set_Nature (Target : Iir; Nature : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Nature (Get_Kind (Target)));
+ Set_Field1 (Target, Nature);
+ end Set_Nature;
+
+ function Get_Mode (Target : Iir) return Iir_Mode is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Mode (Get_Kind (Target)));
+ return Iir_Mode'Val (Get_Odigit1 (Target));
+ end Get_Mode;
+
+ procedure Set_Mode (Target : Iir; Mode : Iir_Mode) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Mode (Get_Kind (Target)));
+ Set_Odigit1 (Target, Iir_Mode'Pos (Mode));
+ end Set_Mode;
+
+ function Get_Signal_Kind (Target : Iir) return Iir_Signal_Kind is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Signal_Kind (Get_Kind (Target)));
+ return Iir_Signal_Kind'Val (Get_State3 (Target));
+ end Get_Signal_Kind;
+
+ procedure Set_Signal_Kind (Target : Iir; Signal_Kind : Iir_Signal_Kind) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Signal_Kind (Get_Kind (Target)));
+ Set_State3 (Target, Iir_Signal_Kind'Pos (Signal_Kind));
+ end Set_Signal_Kind;
+
+ function Get_Base_Name (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Base_Name (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Base_Name;
+
+ procedure Set_Base_Name (Target : Iir; Name : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Base_Name (Get_Kind (Target)));
+ Set_Field5 (Target, Name);
+ end Set_Base_Name;
+
+ function Get_Interface_Declaration_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Interface_Declaration_Chain (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Interface_Declaration_Chain;
+
+ procedure Set_Interface_Declaration_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Interface_Declaration_Chain (Get_Kind (Target)));
+ Set_Field5 (Target, Chain);
+ end Set_Interface_Declaration_Chain;
+
+ function Get_Subprogram_Specification (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subprogram_Specification (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Subprogram_Specification;
+
+ procedure Set_Subprogram_Specification (Target : Iir; Spec : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subprogram_Specification (Get_Kind (Target)));
+ Set_Field4 (Target, Spec);
+ end Set_Subprogram_Specification;
+
+ function Get_Sequential_Statement_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Sequential_Statement_Chain (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Sequential_Statement_Chain;
+
+ procedure Set_Sequential_Statement_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Sequential_Statement_Chain (Get_Kind (Target)));
+ Set_Field5 (Target, Chain);
+ end Set_Sequential_Statement_Chain;
+
+ function Get_Subprogram_Body (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subprogram_Body (Get_Kind (Target)));
+ return Get_Field9 (Target);
+ end Get_Subprogram_Body;
+
+ procedure Set_Subprogram_Body (Target : Iir; A_Body : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subprogram_Body (Get_Kind (Target)));
+ Set_Field9 (Target, A_Body);
+ end Set_Subprogram_Body;
+
+ function Get_Overload_Number (Target : Iir) return Iir_Int32 is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Overload_Number (Get_Kind (Target)));
+ return Iir_Int32'Val (Get_Field12 (Target));
+ end Get_Overload_Number;
+
+ procedure Set_Overload_Number (Target : Iir; Val : Iir_Int32) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Overload_Number (Get_Kind (Target)));
+ Set_Field12 (Target, Iir_Int32'Pos (Val));
+ end Set_Overload_Number;
+
+ function Get_Subprogram_Depth (Target : Iir) return Iir_Int32 is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subprogram_Depth (Get_Kind (Target)));
+ return Iir_Int32'Val (Get_Field10 (Target));
+ end Get_Subprogram_Depth;
+
+ procedure Set_Subprogram_Depth (Target : Iir; Depth : Iir_Int32) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subprogram_Depth (Get_Kind (Target)));
+ Set_Field10 (Target, Iir_Int32'Pos (Depth));
+ end Set_Subprogram_Depth;
+
+ function Get_Subprogram_Hash (Target : Iir) return Iir_Int32 is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subprogram_Hash (Get_Kind (Target)));
+ return Iir_Int32'Val (Get_Field11 (Target));
+ end Get_Subprogram_Hash;
+
+ procedure Set_Subprogram_Hash (Target : Iir; Val : Iir_Int32) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subprogram_Hash (Get_Kind (Target)));
+ Set_Field11 (Target, Iir_Int32'Pos (Val));
+ end Set_Subprogram_Hash;
+
+ function Get_Impure_Depth (Target : Iir) return Iir_Int32 is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Impure_Depth (Get_Kind (Target)));
+ return Iir_To_Iir_Int32 (Get_Field3 (Target));
+ end Get_Impure_Depth;
+
+ procedure Set_Impure_Depth (Target : Iir; Depth : Iir_Int32) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Impure_Depth (Get_Kind (Target)));
+ Set_Field3 (Target, Iir_Int32_To_Iir (Depth));
+ end Set_Impure_Depth;
+
+ function Get_Return_Type (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Return_Type (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Return_Type;
+
+ procedure Set_Return_Type (Target : Iir; Decl : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Return_Type (Get_Kind (Target)));
+ Set_Field1 (Target, Decl);
+ end Set_Return_Type;
+
+ function Get_Implicit_Definition (D : Iir) return Iir_Predefined_Functions
+ is
+ begin
+ pragma Assert (D /= Null_Iir);
+ pragma Assert (Has_Implicit_Definition (Get_Kind (D)));
+ return Iir_Predefined_Functions'Val (Get_Field9 (D));
+ end Get_Implicit_Definition;
+
+ procedure Set_Implicit_Definition (D : Iir; Def : Iir_Predefined_Functions)
+ is
+ begin
+ pragma Assert (D /= Null_Iir);
+ pragma Assert (Has_Implicit_Definition (Get_Kind (D)));
+ Set_Field9 (D, Iir_Predefined_Functions'Pos (Def));
+ end Set_Implicit_Definition;
+
+ function Get_Type_Reference (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Type_Reference (Get_Kind (Target)));
+ return Get_Field10 (Target);
+ end Get_Type_Reference;
+
+ procedure Set_Type_Reference (Target : Iir; Decl : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Type_Reference (Get_Kind (Target)));
+ Set_Field10 (Target, Decl);
+ end Set_Type_Reference;
+
+ function Get_Default_Value (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Default_Value (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Default_Value;
+
+ procedure Set_Default_Value (Target : Iir; Value : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Default_Value (Get_Kind (Target)));
+ Set_Field6 (Target, Value);
+ end Set_Default_Value;
+
+ function Get_Deferred_Declaration (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Deferred_Declaration (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_Deferred_Declaration;
+
+ procedure Set_Deferred_Declaration (Target : Iir; Decl : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Deferred_Declaration (Get_Kind (Target)));
+ Set_Field7 (Target, Decl);
+ end Set_Deferred_Declaration;
+
+ function Get_Deferred_Declaration_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Deferred_Declaration_Flag (Get_Kind (Target)));
+ return Get_Flag1 (Target);
+ end Get_Deferred_Declaration_Flag;
+
+ procedure Set_Deferred_Declaration_Flag (Target : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Deferred_Declaration_Flag (Get_Kind (Target)));
+ Set_Flag1 (Target, Flag);
+ end Set_Deferred_Declaration_Flag;
+
+ function Get_Shared_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Shared_Flag (Get_Kind (Target)));
+ return Get_Flag2 (Target);
+ end Get_Shared_Flag;
+
+ procedure Set_Shared_Flag (Target : Iir; Shared : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Shared_Flag (Get_Kind (Target)));
+ Set_Flag2 (Target, Shared);
+ end Set_Shared_Flag;
+
+ function Get_Design_Unit (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Design_Unit (Get_Kind (Target)));
+ return Get_Field0 (Target);
+ end Get_Design_Unit;
+
+ procedure Set_Design_Unit (Target : Iir; Unit : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Design_Unit (Get_Kind (Target)));
+ Set_Field0 (Target, Unit);
+ end Set_Design_Unit;
+
+ function Get_Block_Statement (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Block_Statement (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_Block_Statement;
+
+ procedure Set_Block_Statement (Target : Iir; Block : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Block_Statement (Get_Kind (Target)));
+ Set_Field7 (Target, Block);
+ end Set_Block_Statement;
+
+ function Get_Signal_Driver (Target : Iir_Signal_Declaration) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Signal_Driver (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_Signal_Driver;
+
+ procedure Set_Signal_Driver (Target : Iir_Signal_Declaration; Driver : Iir)
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Signal_Driver (Get_Kind (Target)));
+ Set_Field7 (Target, Driver);
+ end Set_Signal_Driver;
+
+ function Get_Declaration_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Declaration_Chain (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Declaration_Chain;
+
+ procedure Set_Declaration_Chain (Target : Iir; Decls : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Declaration_Chain (Get_Kind (Target)));
+ Set_Field1 (Target, Decls);
+ end Set_Declaration_Chain;
+
+ function Get_File_Logical_Name (Target : Iir_File_Declaration) return Iir
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_File_Logical_Name (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_File_Logical_Name;
+
+ procedure Set_File_Logical_Name (Target : Iir_File_Declaration; Name : Iir)
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_File_Logical_Name (Get_Kind (Target)));
+ Set_Field6 (Target, Name);
+ end Set_File_Logical_Name;
+
+ function Get_File_Open_Kind (Target : Iir_File_Declaration) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_File_Open_Kind (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_File_Open_Kind;
+
+ procedure Set_File_Open_Kind (Target : Iir_File_Declaration; Kind : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_File_Open_Kind (Get_Kind (Target)));
+ Set_Field7 (Target, Kind);
+ end Set_File_Open_Kind;
+
+ function Get_Element_Position (Target : Iir) return Iir_Index32 is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Element_Position (Get_Kind (Target)));
+ return Iir_Index32'Val (Get_Field4 (Target));
+ end Get_Element_Position;
+
+ procedure Set_Element_Position (Target : Iir; Pos : Iir_Index32) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Element_Position (Get_Kind (Target)));
+ Set_Field4 (Target, Iir_Index32'Pos (Pos));
+ end Set_Element_Position;
+
+ function Get_Element_Declaration (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Element_Declaration (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Element_Declaration;
+
+ procedure Set_Element_Declaration (Target : Iir; El : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Element_Declaration (Get_Kind (Target)));
+ Set_Field2 (Target, El);
+ end Set_Element_Declaration;
+
+ function Get_Selected_Element (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Selected_Element (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Selected_Element;
+
+ procedure Set_Selected_Element (Target : Iir; El : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Selected_Element (Get_Kind (Target)));
+ Set_Field2 (Target, El);
+ end Set_Selected_Element;
+
+ function Get_Use_Clause_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Use_Clause_Chain (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Use_Clause_Chain;
+
+ procedure Set_Use_Clause_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Use_Clause_Chain (Get_Kind (Target)));
+ Set_Field3 (Target, Chain);
+ end Set_Use_Clause_Chain;
+
+ function Get_Selected_Name (Target : Iir_Use_Clause) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Selected_Name (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Selected_Name;
+
+ procedure Set_Selected_Name (Target : Iir_Use_Clause; Name : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Selected_Name (Get_Kind (Target)));
+ Set_Field1 (Target, Name);
+ end Set_Selected_Name;
+
+ function Get_Type_Declarator (Def : Iir) return Iir is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Type_Declarator (Get_Kind (Def)));
+ return Get_Field3 (Def);
+ end Get_Type_Declarator;
+
+ procedure Set_Type_Declarator (Def : Iir; Decl : Iir) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Type_Declarator (Get_Kind (Def)));
+ Set_Field3 (Def, Decl);
+ end Set_Type_Declarator;
+
+ function Get_Enumeration_Literal_List (Target : Iir) return Iir_List is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Enumeration_Literal_List (Get_Kind (Target)));
+ return Iir_To_Iir_List (Get_Field2 (Target));
+ end Get_Enumeration_Literal_List;
+
+ procedure Set_Enumeration_Literal_List (Target : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Enumeration_Literal_List (Get_Kind (Target)));
+ Set_Field2 (Target, Iir_List_To_Iir (List));
+ end Set_Enumeration_Literal_List;
+
+ function Get_Entity_Class_Entry_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Entity_Class_Entry_Chain (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Entity_Class_Entry_Chain;
+
+ procedure Set_Entity_Class_Entry_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Entity_Class_Entry_Chain (Get_Kind (Target)));
+ Set_Field1 (Target, Chain);
+ end Set_Entity_Class_Entry_Chain;
+
+ function Get_Group_Constituent_List (Group : Iir) return Iir_List is
+ begin
+ pragma Assert (Group /= Null_Iir);
+ pragma Assert (Has_Group_Constituent_List (Get_Kind (Group)));
+ return Iir_To_Iir_List (Get_Field1 (Group));
+ end Get_Group_Constituent_List;
+
+ procedure Set_Group_Constituent_List (Group : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Group /= Null_Iir);
+ pragma Assert (Has_Group_Constituent_List (Get_Kind (Group)));
+ Set_Field1 (Group, Iir_List_To_Iir (List));
+ end Set_Group_Constituent_List;
+
+ function Get_Unit_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Unit_Chain (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Unit_Chain;
+
+ procedure Set_Unit_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Unit_Chain (Get_Kind (Target)));
+ Set_Field1 (Target, Chain);
+ end Set_Unit_Chain;
+
+ function Get_Primary_Unit (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Primary_Unit (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Primary_Unit;
+
+ procedure Set_Primary_Unit (Target : Iir; Unit : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Primary_Unit (Get_Kind (Target)));
+ Set_Field1 (Target, Unit);
+ end Set_Primary_Unit;
+
+ function Get_Identifier (Target : Iir) return Name_Id is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Identifier (Get_Kind (Target)));
+ return Iir_To_Name_Id (Get_Field3 (Target));
+ end Get_Identifier;
+
+ procedure Set_Identifier (Target : Iir; Identifier : Name_Id) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Identifier (Get_Kind (Target)));
+ Set_Field3 (Target, Name_Id_To_Iir (Identifier));
+ end Set_Identifier;
+
+ function Get_Label (Target : Iir) return Name_Id is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Label (Get_Kind (Target)));
+ return Iir_To_Name_Id (Get_Field3 (Target));
+ end Get_Label;
+
+ procedure Set_Label (Target : Iir; Label : Name_Id) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Label (Get_Kind (Target)));
+ Set_Field3 (Target, Name_Id_To_Iir (Label));
+ end Set_Label;
+
+ function Get_Visible_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Visible_Flag (Get_Kind (Target)));
+ return Get_Flag4 (Target);
+ end Get_Visible_Flag;
+
+ procedure Set_Visible_Flag (Target : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Visible_Flag (Get_Kind (Target)));
+ Set_Flag4 (Target, Flag);
+ end Set_Visible_Flag;
+
+ function Get_Range_Constraint (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Range_Constraint (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Range_Constraint;
+
+ procedure Set_Range_Constraint (Target : Iir; Constraint : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Range_Constraint (Get_Kind (Target)));
+ Set_Field1 (Target, Constraint);
+ end Set_Range_Constraint;
+
+ function Get_Direction (Decl : Iir) return Iir_Direction is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Direction (Get_Kind (Decl)));
+ return Iir_Direction'Val (Get_State2 (Decl));
+ end Get_Direction;
+
+ procedure Set_Direction (Decl : Iir; Dir : Iir_Direction) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Direction (Get_Kind (Decl)));
+ Set_State2 (Decl, Iir_Direction'Pos (Dir));
+ end Set_Direction;
+
+ function Get_Left_Limit (Decl : Iir_Range_Expression) return Iir is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Left_Limit (Get_Kind (Decl)));
+ return Get_Field2 (Decl);
+ end Get_Left_Limit;
+
+ procedure Set_Left_Limit (Decl : Iir_Range_Expression; Limit : Iir) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Left_Limit (Get_Kind (Decl)));
+ Set_Field2 (Decl, Limit);
+ end Set_Left_Limit;
+
+ function Get_Right_Limit (Decl : Iir_Range_Expression) return Iir is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Right_Limit (Get_Kind (Decl)));
+ return Get_Field3 (Decl);
+ end Get_Right_Limit;
+
+ procedure Set_Right_Limit (Decl : Iir_Range_Expression; Limit : Iir) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Right_Limit (Get_Kind (Decl)));
+ Set_Field3 (Decl, Limit);
+ end Set_Right_Limit;
+
+ function Get_Base_Type (Decl : Iir) return Iir is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Base_Type (Get_Kind (Decl)));
+ return Get_Field4 (Decl);
+ end Get_Base_Type;
+
+ procedure Set_Base_Type (Decl : Iir; Base_Type : Iir) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Base_Type (Get_Kind (Decl)));
+ Set_Field4 (Decl, Base_Type);
+ end Set_Base_Type;
+
+ function Get_Resolution_Indication (Decl : Iir) return Iir is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Resolution_Indication (Get_Kind (Decl)));
+ return Get_Field5 (Decl);
+ end Get_Resolution_Indication;
+
+ procedure Set_Resolution_Indication (Decl : Iir; Ind : Iir) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Resolution_Indication (Get_Kind (Decl)));
+ Set_Field5 (Decl, Ind);
+ end Set_Resolution_Indication;
+
+ function Get_Record_Element_Resolution_Chain (Res : Iir) return Iir is
+ begin
+ pragma Assert (Res /= Null_Iir);
+ pragma Assert (Has_Record_Element_Resolution_Chain (Get_Kind (Res)));
+ return Get_Field1 (Res);
+ end Get_Record_Element_Resolution_Chain;
+
+ procedure Set_Record_Element_Resolution_Chain (Res : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Res /= Null_Iir);
+ pragma Assert (Has_Record_Element_Resolution_Chain (Get_Kind (Res)));
+ Set_Field1 (Res, Chain);
+ end Set_Record_Element_Resolution_Chain;
+
+ function Get_Tolerance (Def : Iir) return Iir is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Tolerance (Get_Kind (Def)));
+ return Get_Field7 (Def);
+ end Get_Tolerance;
+
+ procedure Set_Tolerance (Def : Iir; Tol : Iir) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Tolerance (Get_Kind (Def)));
+ Set_Field7 (Def, Tol);
+ end Set_Tolerance;
+
+ function Get_Plus_Terminal (Def : Iir) return Iir is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Plus_Terminal (Get_Kind (Def)));
+ return Get_Field8 (Def);
+ end Get_Plus_Terminal;
+
+ procedure Set_Plus_Terminal (Def : Iir; Terminal : Iir) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Plus_Terminal (Get_Kind (Def)));
+ Set_Field8 (Def, Terminal);
+ end Set_Plus_Terminal;
+
+ function Get_Minus_Terminal (Def : Iir) return Iir is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Minus_Terminal (Get_Kind (Def)));
+ return Get_Field9 (Def);
+ end Get_Minus_Terminal;
+
+ procedure Set_Minus_Terminal (Def : Iir; Terminal : Iir) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Minus_Terminal (Get_Kind (Def)));
+ Set_Field9 (Def, Terminal);
+ end Set_Minus_Terminal;
+
+ function Get_Simultaneous_Left (Def : Iir) return Iir is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Simultaneous_Left (Get_Kind (Def)));
+ return Get_Field5 (Def);
+ end Get_Simultaneous_Left;
+
+ procedure Set_Simultaneous_Left (Def : Iir; Expr : Iir) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Simultaneous_Left (Get_Kind (Def)));
+ Set_Field5 (Def, Expr);
+ end Set_Simultaneous_Left;
+
+ function Get_Simultaneous_Right (Def : Iir) return Iir is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Simultaneous_Right (Get_Kind (Def)));
+ return Get_Field6 (Def);
+ end Get_Simultaneous_Right;
+
+ procedure Set_Simultaneous_Right (Def : Iir; Expr : Iir) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Simultaneous_Right (Get_Kind (Def)));
+ Set_Field6 (Def, Expr);
+ end Set_Simultaneous_Right;
+
+ function Get_Text_File_Flag (Atype : Iir) return Boolean is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Text_File_Flag (Get_Kind (Atype)));
+ return Get_Flag4 (Atype);
+ end Get_Text_File_Flag;
+
+ procedure Set_Text_File_Flag (Atype : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Text_File_Flag (Get_Kind (Atype)));
+ Set_Flag4 (Atype, Flag);
+ end Set_Text_File_Flag;
+
+ function Get_Only_Characters_Flag (Atype : Iir) return Boolean is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Only_Characters_Flag (Get_Kind (Atype)));
+ return Get_Flag4 (Atype);
+ end Get_Only_Characters_Flag;
+
+ procedure Set_Only_Characters_Flag (Atype : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Only_Characters_Flag (Get_Kind (Atype)));
+ Set_Flag4 (Atype, Flag);
+ end Set_Only_Characters_Flag;
+
+ function Get_Type_Staticness (Atype : Iir) return Iir_Staticness is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Type_Staticness (Get_Kind (Atype)));
+ return Iir_Staticness'Val (Get_State1 (Atype));
+ end Get_Type_Staticness;
+
+ procedure Set_Type_Staticness (Atype : Iir; Static : Iir_Staticness) is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Type_Staticness (Get_Kind (Atype)));
+ Set_State1 (Atype, Iir_Staticness'Pos (Static));
+ end Set_Type_Staticness;
+
+ function Get_Constraint_State (Atype : Iir) return Iir_Constraint is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Constraint_State (Get_Kind (Atype)));
+ return Iir_Constraint'Val (Get_State2 (Atype));
+ end Get_Constraint_State;
+
+ procedure Set_Constraint_State (Atype : Iir; State : Iir_Constraint) is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Constraint_State (Get_Kind (Atype)));
+ Set_State2 (Atype, Iir_Constraint'Pos (State));
+ end Set_Constraint_State;
+
+ function Get_Index_Subtype_List (Decl : Iir) return Iir_List is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Index_Subtype_List (Get_Kind (Decl)));
+ return Iir_To_Iir_List (Get_Field9 (Decl));
+ end Get_Index_Subtype_List;
+
+ procedure Set_Index_Subtype_List (Decl : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Index_Subtype_List (Get_Kind (Decl)));
+ Set_Field9 (Decl, Iir_List_To_Iir (List));
+ end Set_Index_Subtype_List;
+
+ function Get_Index_Subtype_Definition_List (Def : Iir) return Iir_List is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Index_Subtype_Definition_List (Get_Kind (Def)));
+ return Iir_To_Iir_List (Get_Field6 (Def));
+ end Get_Index_Subtype_Definition_List;
+
+ procedure Set_Index_Subtype_Definition_List (Def : Iir; Idx : Iir_List) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Index_Subtype_Definition_List (Get_Kind (Def)));
+ Set_Field6 (Def, Iir_List_To_Iir (Idx));
+ end Set_Index_Subtype_Definition_List;
+
+ function Get_Element_Subtype_Indication (Decl : Iir) return Iir is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Element_Subtype_Indication (Get_Kind (Decl)));
+ return Get_Field2 (Decl);
+ end Get_Element_Subtype_Indication;
+
+ procedure Set_Element_Subtype_Indication (Decl : Iir; Sub_Type : Iir) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Element_Subtype_Indication (Get_Kind (Decl)));
+ Set_Field2 (Decl, Sub_Type);
+ end Set_Element_Subtype_Indication;
+
+ function Get_Element_Subtype (Decl : Iir) return Iir is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Element_Subtype (Get_Kind (Decl)));
+ return Get_Field1 (Decl);
+ end Get_Element_Subtype;
+
+ procedure Set_Element_Subtype (Decl : Iir; Sub_Type : Iir) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Element_Subtype (Get_Kind (Decl)));
+ Set_Field1 (Decl, Sub_Type);
+ end Set_Element_Subtype;
+
+ function Get_Index_Constraint_List (Def : Iir) return Iir_List is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Index_Constraint_List (Get_Kind (Def)));
+ return Iir_To_Iir_List (Get_Field6 (Def));
+ end Get_Index_Constraint_List;
+
+ procedure Set_Index_Constraint_List (Def : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Index_Constraint_List (Get_Kind (Def)));
+ Set_Field6 (Def, Iir_List_To_Iir (List));
+ end Set_Index_Constraint_List;
+
+ function Get_Array_Element_Constraint (Def : Iir) return Iir is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Array_Element_Constraint (Get_Kind (Def)));
+ return Get_Field8 (Def);
+ end Get_Array_Element_Constraint;
+
+ procedure Set_Array_Element_Constraint (Def : Iir; El : Iir) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Array_Element_Constraint (Get_Kind (Def)));
+ Set_Field8 (Def, El);
+ end Set_Array_Element_Constraint;
+
+ function Get_Elements_Declaration_List (Decl : Iir) return Iir_List is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Elements_Declaration_List (Get_Kind (Decl)));
+ return Iir_To_Iir_List (Get_Field1 (Decl));
+ end Get_Elements_Declaration_List;
+
+ procedure Set_Elements_Declaration_List (Decl : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Elements_Declaration_List (Get_Kind (Decl)));
+ Set_Field1 (Decl, Iir_List_To_Iir (List));
+ end Set_Elements_Declaration_List;
+
+ function Get_Designated_Type (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Designated_Type (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Designated_Type;
+
+ procedure Set_Designated_Type (Target : Iir; Dtype : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Designated_Type (Get_Kind (Target)));
+ Set_Field1 (Target, Dtype);
+ end Set_Designated_Type;
+
+ function Get_Designated_Subtype_Indication (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Designated_Subtype_Indication (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Designated_Subtype_Indication;
+
+ procedure Set_Designated_Subtype_Indication (Target : Iir; Dtype : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Designated_Subtype_Indication (Get_Kind (Target)));
+ Set_Field5 (Target, Dtype);
+ end Set_Designated_Subtype_Indication;
+
+ function Get_Index_List (Decl : Iir) return Iir_List is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Index_List (Get_Kind (Decl)));
+ return Iir_To_Iir_List (Get_Field2 (Decl));
+ end Get_Index_List;
+
+ procedure Set_Index_List (Decl : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Index_List (Get_Kind (Decl)));
+ Set_Field2 (Decl, Iir_List_To_Iir (List));
+ end Set_Index_List;
+
+ function Get_Reference (Def : Iir) return Iir is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Reference (Get_Kind (Def)));
+ return Get_Field2 (Def);
+ end Get_Reference;
+
+ procedure Set_Reference (Def : Iir; Ref : Iir) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Reference (Get_Kind (Def)));
+ Set_Field2 (Def, Ref);
+ end Set_Reference;
+
+ function Get_Nature_Declarator (Def : Iir) return Iir is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Nature_Declarator (Get_Kind (Def)));
+ return Get_Field3 (Def);
+ end Get_Nature_Declarator;
+
+ procedure Set_Nature_Declarator (Def : Iir; Decl : Iir) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Nature_Declarator (Get_Kind (Def)));
+ Set_Field3 (Def, Decl);
+ end Set_Nature_Declarator;
+
+ function Get_Across_Type (Def : Iir) return Iir is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Across_Type (Get_Kind (Def)));
+ return Get_Field7 (Def);
+ end Get_Across_Type;
+
+ procedure Set_Across_Type (Def : Iir; Atype : Iir) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Across_Type (Get_Kind (Def)));
+ Set_Field7 (Def, Atype);
+ end Set_Across_Type;
+
+ function Get_Through_Type (Def : Iir) return Iir is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Through_Type (Get_Kind (Def)));
+ return Get_Field8 (Def);
+ end Get_Through_Type;
+
+ procedure Set_Through_Type (Def : Iir; Atype : Iir) is
+ begin
+ pragma Assert (Def /= Null_Iir);
+ pragma Assert (Has_Through_Type (Get_Kind (Def)));
+ Set_Field8 (Def, Atype);
+ end Set_Through_Type;
+
+ function Get_Target (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Target (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Target;
+
+ procedure Set_Target (Target : Iir; Atarget : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Target (Get_Kind (Target)));
+ Set_Field1 (Target, Atarget);
+ end Set_Target;
+
+ function Get_Waveform_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Waveform_Chain (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Waveform_Chain;
+
+ procedure Set_Waveform_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Waveform_Chain (Get_Kind (Target)));
+ Set_Field5 (Target, Chain);
+ end Set_Waveform_Chain;
+
+ function Get_Guard (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Guard (Get_Kind (Target)));
+ return Get_Field8 (Target);
+ end Get_Guard;
+
+ procedure Set_Guard (Target : Iir; Guard : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Guard (Get_Kind (Target)));
+ Set_Field8 (Target, Guard);
+ end Set_Guard;
+
+ function Get_Delay_Mechanism (Target : Iir) return Iir_Delay_Mechanism is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Delay_Mechanism (Get_Kind (Target)));
+ return Iir_Delay_Mechanism'Val (Get_Field12 (Target));
+ end Get_Delay_Mechanism;
+
+ procedure Set_Delay_Mechanism (Target : Iir; Kind : Iir_Delay_Mechanism) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Delay_Mechanism (Get_Kind (Target)));
+ Set_Field12 (Target, Iir_Delay_Mechanism'Pos (Kind));
+ end Set_Delay_Mechanism;
+
+ function Get_Reject_Time_Expression (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Reject_Time_Expression (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Reject_Time_Expression;
+
+ procedure Set_Reject_Time_Expression (Target : Iir; Expr : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Reject_Time_Expression (Get_Kind (Target)));
+ Set_Field6 (Target, Expr);
+ end Set_Reject_Time_Expression;
+
+ function Get_Sensitivity_List (Wait : Iir) return Iir_List is
+ begin
+ pragma Assert (Wait /= Null_Iir);
+ pragma Assert (Has_Sensitivity_List (Get_Kind (Wait)));
+ return Iir_To_Iir_List (Get_Field6 (Wait));
+ end Get_Sensitivity_List;
+
+ procedure Set_Sensitivity_List (Wait : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Wait /= Null_Iir);
+ pragma Assert (Has_Sensitivity_List (Get_Kind (Wait)));
+ Set_Field6 (Wait, Iir_List_To_Iir (List));
+ end Set_Sensitivity_List;
+
+ function Get_Process_Origin (Proc : Iir) return Iir is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Process_Origin (Get_Kind (Proc)));
+ return Get_Field8 (Proc);
+ end Get_Process_Origin;
+
+ procedure Set_Process_Origin (Proc : Iir; Orig : Iir) is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Process_Origin (Get_Kind (Proc)));
+ Set_Field8 (Proc, Orig);
+ end Set_Process_Origin;
+
+ function Get_Condition_Clause (Wait : Iir_Wait_Statement) return Iir is
+ begin
+ pragma Assert (Wait /= Null_Iir);
+ pragma Assert (Has_Condition_Clause (Get_Kind (Wait)));
+ return Get_Field5 (Wait);
+ end Get_Condition_Clause;
+
+ procedure Set_Condition_Clause (Wait : Iir_Wait_Statement; Cond : Iir) is
+ begin
+ pragma Assert (Wait /= Null_Iir);
+ pragma Assert (Has_Condition_Clause (Get_Kind (Wait)));
+ Set_Field5 (Wait, Cond);
+ end Set_Condition_Clause;
+
+ function Get_Timeout_Clause (Wait : Iir_Wait_Statement) return Iir is
+ begin
+ pragma Assert (Wait /= Null_Iir);
+ pragma Assert (Has_Timeout_Clause (Get_Kind (Wait)));
+ return Get_Field1 (Wait);
+ end Get_Timeout_Clause;
+
+ procedure Set_Timeout_Clause (Wait : Iir_Wait_Statement; Timeout : Iir) is
+ begin
+ pragma Assert (Wait /= Null_Iir);
+ pragma Assert (Has_Timeout_Clause (Get_Kind (Wait)));
+ Set_Field1 (Wait, Timeout);
+ end Set_Timeout_Clause;
+
+ function Get_Postponed_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Postponed_Flag (Get_Kind (Target)));
+ return Get_Flag3 (Target);
+ end Get_Postponed_Flag;
+
+ procedure Set_Postponed_Flag (Target : Iir; Value : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Postponed_Flag (Get_Kind (Target)));
+ Set_Flag3 (Target, Value);
+ end Set_Postponed_Flag;
+
+ function Get_Callees_List (Proc : Iir) return Iir_List is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Callees_List (Get_Kind (Proc)));
+ return Iir_To_Iir_List (Get_Field7 (Proc));
+ end Get_Callees_List;
+
+ procedure Set_Callees_List (Proc : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Callees_List (Get_Kind (Proc)));
+ Set_Field7 (Proc, Iir_List_To_Iir (List));
+ end Set_Callees_List;
+
+ function Get_Passive_Flag (Proc : Iir) return Boolean is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Passive_Flag (Get_Kind (Proc)));
+ return Get_Flag2 (Proc);
+ end Get_Passive_Flag;
+
+ procedure Set_Passive_Flag (Proc : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Passive_Flag (Get_Kind (Proc)));
+ Set_Flag2 (Proc, Flag);
+ end Set_Passive_Flag;
+
+ function Get_Resolution_Function_Flag (Func : Iir) return Boolean is
+ begin
+ pragma Assert (Func /= Null_Iir);
+ pragma Assert (Has_Resolution_Function_Flag (Get_Kind (Func)));
+ return Get_Flag7 (Func);
+ end Get_Resolution_Function_Flag;
+
+ procedure Set_Resolution_Function_Flag (Func : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Func /= Null_Iir);
+ pragma Assert (Has_Resolution_Function_Flag (Get_Kind (Func)));
+ Set_Flag7 (Func, Flag);
+ end Set_Resolution_Function_Flag;
+
+ function Get_Wait_State (Proc : Iir) return Tri_State_Type is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Wait_State (Get_Kind (Proc)));
+ return Tri_State_Type'Val (Get_State1 (Proc));
+ end Get_Wait_State;
+
+ procedure Set_Wait_State (Proc : Iir; State : Tri_State_Type) is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Wait_State (Get_Kind (Proc)));
+ Set_State1 (Proc, Tri_State_Type'Pos (State));
+ end Set_Wait_State;
+
+ function Get_All_Sensitized_State (Proc : Iir) return Iir_All_Sensitized is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_All_Sensitized_State (Get_Kind (Proc)));
+ return Iir_All_Sensitized'Val (Get_State3 (Proc));
+ end Get_All_Sensitized_State;
+
+ procedure Set_All_Sensitized_State (Proc : Iir; State : Iir_All_Sensitized)
+ is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_All_Sensitized_State (Get_Kind (Proc)));
+ Set_State3 (Proc, Iir_All_Sensitized'Pos (State));
+ end Set_All_Sensitized_State;
+
+ function Get_Seen_Flag (Proc : Iir) return Boolean is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Seen_Flag (Get_Kind (Proc)));
+ return Get_Flag1 (Proc);
+ end Get_Seen_Flag;
+
+ procedure Set_Seen_Flag (Proc : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Seen_Flag (Get_Kind (Proc)));
+ Set_Flag1 (Proc, Flag);
+ end Set_Seen_Flag;
+
+ function Get_Pure_Flag (Func : Iir) return Boolean is
+ begin
+ pragma Assert (Func /= Null_Iir);
+ pragma Assert (Has_Pure_Flag (Get_Kind (Func)));
+ return Get_Flag2 (Func);
+ end Get_Pure_Flag;
+
+ procedure Set_Pure_Flag (Func : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Func /= Null_Iir);
+ pragma Assert (Has_Pure_Flag (Get_Kind (Func)));
+ Set_Flag2 (Func, Flag);
+ end Set_Pure_Flag;
+
+ function Get_Foreign_Flag (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Foreign_Flag (Get_Kind (Decl)));
+ return Get_Flag3 (Decl);
+ end Get_Foreign_Flag;
+
+ procedure Set_Foreign_Flag (Decl : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Foreign_Flag (Get_Kind (Decl)));
+ Set_Flag3 (Decl, Flag);
+ end Set_Foreign_Flag;
+
+ function Get_Resolved_Flag (Atype : Iir) return Boolean is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Resolved_Flag (Get_Kind (Atype)));
+ return Get_Flag1 (Atype);
+ end Get_Resolved_Flag;
+
+ procedure Set_Resolved_Flag (Atype : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Resolved_Flag (Get_Kind (Atype)));
+ Set_Flag1 (Atype, Flag);
+ end Set_Resolved_Flag;
+
+ function Get_Signal_Type_Flag (Atype : Iir) return Boolean is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Signal_Type_Flag (Get_Kind (Atype)));
+ return Get_Flag2 (Atype);
+ end Get_Signal_Type_Flag;
+
+ procedure Set_Signal_Type_Flag (Atype : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Signal_Type_Flag (Get_Kind (Atype)));
+ Set_Flag2 (Atype, Flag);
+ end Set_Signal_Type_Flag;
+
+ function Get_Has_Signal_Flag (Atype : Iir) return Boolean is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Has_Signal_Flag (Get_Kind (Atype)));
+ return Get_Flag3 (Atype);
+ end Get_Has_Signal_Flag;
+
+ procedure Set_Has_Signal_Flag (Atype : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Has_Signal_Flag (Get_Kind (Atype)));
+ Set_Flag3 (Atype, Flag);
+ end Set_Has_Signal_Flag;
+
+ function Get_Purity_State (Proc : Iir) return Iir_Pure_State is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Purity_State (Get_Kind (Proc)));
+ return Iir_Pure_State'Val (Get_State2 (Proc));
+ end Get_Purity_State;
+
+ procedure Set_Purity_State (Proc : Iir; State : Iir_Pure_State) is
+ begin
+ pragma Assert (Proc /= Null_Iir);
+ pragma Assert (Has_Purity_State (Get_Kind (Proc)));
+ Set_State2 (Proc, Iir_Pure_State'Pos (State));
+ end Set_Purity_State;
+
+ function Get_Elab_Flag (Design : Iir) return Boolean is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_Elab_Flag (Get_Kind (Design)));
+ return Get_Flag3 (Design);
+ end Get_Elab_Flag;
+
+ procedure Set_Elab_Flag (Design : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Design /= Null_Iir);
+ pragma Assert (Has_Elab_Flag (Get_Kind (Design)));
+ Set_Flag3 (Design, Flag);
+ end Set_Elab_Flag;
+
+ function Get_Index_Constraint_Flag (Atype : Iir) return Boolean is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Index_Constraint_Flag (Get_Kind (Atype)));
+ return Get_Flag4 (Atype);
+ end Get_Index_Constraint_Flag;
+
+ procedure Set_Index_Constraint_Flag (Atype : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Atype /= Null_Iir);
+ pragma Assert (Has_Index_Constraint_Flag (Get_Kind (Atype)));
+ Set_Flag4 (Atype, Flag);
+ end Set_Index_Constraint_Flag;
+
+ function Get_Assertion_Condition (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Assertion_Condition (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Assertion_Condition;
+
+ procedure Set_Assertion_Condition (Target : Iir; Cond : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Assertion_Condition (Get_Kind (Target)));
+ Set_Field1 (Target, Cond);
+ end Set_Assertion_Condition;
+
+ function Get_Report_Expression (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Report_Expression (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Report_Expression;
+
+ procedure Set_Report_Expression (Target : Iir; Expr : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Report_Expression (Get_Kind (Target)));
+ Set_Field6 (Target, Expr);
+ end Set_Report_Expression;
+
+ function Get_Severity_Expression (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Severity_Expression (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Severity_Expression;
+
+ procedure Set_Severity_Expression (Target : Iir; Expr : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Severity_Expression (Get_Kind (Target)));
+ Set_Field5 (Target, Expr);
+ end Set_Severity_Expression;
+
+ function Get_Instantiated_Unit (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Instantiated_Unit (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Instantiated_Unit;
+
+ procedure Set_Instantiated_Unit (Target : Iir; Unit : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Instantiated_Unit (Get_Kind (Target)));
+ Set_Field1 (Target, Unit);
+ end Set_Instantiated_Unit;
+
+ function Get_Generic_Map_Aspect_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Generic_Map_Aspect_Chain (Get_Kind (Target)));
+ return Get_Field8 (Target);
+ end Get_Generic_Map_Aspect_Chain;
+
+ procedure Set_Generic_Map_Aspect_Chain (Target : Iir; Generics : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Generic_Map_Aspect_Chain (Get_Kind (Target)));
+ Set_Field8 (Target, Generics);
+ end Set_Generic_Map_Aspect_Chain;
+
+ function Get_Port_Map_Aspect_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Port_Map_Aspect_Chain (Get_Kind (Target)));
+ return Get_Field9 (Target);
+ end Get_Port_Map_Aspect_Chain;
+
+ procedure Set_Port_Map_Aspect_Chain (Target : Iir; Port : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Port_Map_Aspect_Chain (Get_Kind (Target)));
+ Set_Field9 (Target, Port);
+ end Set_Port_Map_Aspect_Chain;
+
+ function Get_Configuration_Name (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Configuration_Name (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Configuration_Name;
+
+ procedure Set_Configuration_Name (Target : Iir; Conf : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Configuration_Name (Get_Kind (Target)));
+ Set_Field1 (Target, Conf);
+ end Set_Configuration_Name;
+
+ function Get_Component_Configuration (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Component_Configuration (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Component_Configuration;
+
+ procedure Set_Component_Configuration (Target : Iir; Conf : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Component_Configuration (Get_Kind (Target)));
+ Set_Field6 (Target, Conf);
+ end Set_Component_Configuration;
+
+ function Get_Configuration_Specification (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Configuration_Specification (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_Configuration_Specification;
+
+ procedure Set_Configuration_Specification (Target : Iir; Conf : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Configuration_Specification (Get_Kind (Target)));
+ Set_Field7 (Target, Conf);
+ end Set_Configuration_Specification;
+
+ function Get_Default_Binding_Indication (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Default_Binding_Indication (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Default_Binding_Indication;
+
+ procedure Set_Default_Binding_Indication (Target : Iir; Conf : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Default_Binding_Indication (Get_Kind (Target)));
+ Set_Field5 (Target, Conf);
+ end Set_Default_Binding_Indication;
+
+ function Get_Default_Configuration_Declaration (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert
+ (Has_Default_Configuration_Declaration (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Default_Configuration_Declaration;
+
+ procedure Set_Default_Configuration_Declaration (Target : Iir; Conf : Iir)
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert
+ (Has_Default_Configuration_Declaration (Get_Kind (Target)));
+ Set_Field6 (Target, Conf);
+ end Set_Default_Configuration_Declaration;
+
+ function Get_Expression (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Expression (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Expression;
+
+ procedure Set_Expression (Target : Iir; Expr : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Expression (Get_Kind (Target)));
+ Set_Field5 (Target, Expr);
+ end Set_Expression;
+
+ function Get_Allocator_Designated_Type (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Allocator_Designated_Type (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Allocator_Designated_Type;
+
+ procedure Set_Allocator_Designated_Type (Target : Iir; A_Type : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Allocator_Designated_Type (Get_Kind (Target)));
+ Set_Field2 (Target, A_Type);
+ end Set_Allocator_Designated_Type;
+
+ function Get_Selected_Waveform_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Selected_Waveform_Chain (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_Selected_Waveform_Chain;
+
+ procedure Set_Selected_Waveform_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Selected_Waveform_Chain (Get_Kind (Target)));
+ Set_Field7 (Target, Chain);
+ end Set_Selected_Waveform_Chain;
+
+ function Get_Conditional_Waveform_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Conditional_Waveform_Chain (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_Conditional_Waveform_Chain;
+
+ procedure Set_Conditional_Waveform_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Conditional_Waveform_Chain (Get_Kind (Target)));
+ Set_Field7 (Target, Chain);
+ end Set_Conditional_Waveform_Chain;
+
+ function Get_Guard_Expression (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Guard_Expression (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Guard_Expression;
+
+ procedure Set_Guard_Expression (Target : Iir; Expr : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Guard_Expression (Get_Kind (Target)));
+ Set_Field2 (Target, Expr);
+ end Set_Guard_Expression;
+
+ function Get_Guard_Decl (Target : Iir_Block_Statement) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Guard_Decl (Get_Kind (Target)));
+ return Get_Field8 (Target);
+ end Get_Guard_Decl;
+
+ procedure Set_Guard_Decl (Target : Iir_Block_Statement; Decl : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Guard_Decl (Get_Kind (Target)));
+ Set_Field8 (Target, Decl);
+ end Set_Guard_Decl;
+
+ function Get_Guard_Sensitivity_List (Guard : Iir) return Iir_List is
+ begin
+ pragma Assert (Guard /= Null_Iir);
+ pragma Assert (Has_Guard_Sensitivity_List (Get_Kind (Guard)));
+ return Iir_To_Iir_List (Get_Field6 (Guard));
+ end Get_Guard_Sensitivity_List;
+
+ procedure Set_Guard_Sensitivity_List (Guard : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Guard /= Null_Iir);
+ pragma Assert (Has_Guard_Sensitivity_List (Get_Kind (Guard)));
+ Set_Field6 (Guard, Iir_List_To_Iir (List));
+ end Set_Guard_Sensitivity_List;
+
+ function Get_Block_Block_Configuration (Block : Iir) return Iir is
+ begin
+ pragma Assert (Block /= Null_Iir);
+ pragma Assert (Has_Block_Block_Configuration (Get_Kind (Block)));
+ return Get_Field6 (Block);
+ end Get_Block_Block_Configuration;
+
+ procedure Set_Block_Block_Configuration (Block : Iir; Conf : Iir) is
+ begin
+ pragma Assert (Block /= Null_Iir);
+ pragma Assert (Has_Block_Block_Configuration (Get_Kind (Block)));
+ Set_Field6 (Block, Conf);
+ end Set_Block_Block_Configuration;
+
+ function Get_Package_Header (Pkg : Iir) return Iir is
+ begin
+ pragma Assert (Pkg /= Null_Iir);
+ pragma Assert (Has_Package_Header (Get_Kind (Pkg)));
+ return Get_Field5 (Pkg);
+ end Get_Package_Header;
+
+ procedure Set_Package_Header (Pkg : Iir; Header : Iir) is
+ begin
+ pragma Assert (Pkg /= Null_Iir);
+ pragma Assert (Has_Package_Header (Get_Kind (Pkg)));
+ Set_Field5 (Pkg, Header);
+ end Set_Package_Header;
+
+ function Get_Block_Header (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Block_Header (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_Block_Header;
+
+ procedure Set_Block_Header (Target : Iir; Header : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Block_Header (Get_Kind (Target)));
+ Set_Field7 (Target, Header);
+ end Set_Block_Header;
+
+ function Get_Uninstantiated_Package_Name (Inst : Iir) return Iir is
+ begin
+ pragma Assert (Inst /= Null_Iir);
+ pragma Assert (Has_Uninstantiated_Package_Name (Get_Kind (Inst)));
+ return Get_Field5 (Inst);
+ end Get_Uninstantiated_Package_Name;
+
+ procedure Set_Uninstantiated_Package_Name (Inst : Iir; Name : Iir) is
+ begin
+ pragma Assert (Inst /= Null_Iir);
+ pragma Assert (Has_Uninstantiated_Package_Name (Get_Kind (Inst)));
+ Set_Field5 (Inst, Name);
+ end Set_Uninstantiated_Package_Name;
+
+ function Get_Generate_Block_Configuration (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Generate_Block_Configuration (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_Generate_Block_Configuration;
+
+ procedure Set_Generate_Block_Configuration (Target : Iir; Conf : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Generate_Block_Configuration (Get_Kind (Target)));
+ Set_Field7 (Target, Conf);
+ end Set_Generate_Block_Configuration;
+
+ function Get_Generation_Scheme (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Generation_Scheme (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Generation_Scheme;
+
+ procedure Set_Generation_Scheme (Target : Iir; Scheme : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Generation_Scheme (Get_Kind (Target)));
+ Set_Field6 (Target, Scheme);
+ end Set_Generation_Scheme;
+
+ function Get_Condition (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Condition (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Condition;
+
+ procedure Set_Condition (Target : Iir; Condition : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Condition (Get_Kind (Target)));
+ Set_Field1 (Target, Condition);
+ end Set_Condition;
+
+ function Get_Else_Clause (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Else_Clause (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Else_Clause;
+
+ procedure Set_Else_Clause (Target : Iir; Clause : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Else_Clause (Get_Kind (Target)));
+ Set_Field6 (Target, Clause);
+ end Set_Else_Clause;
+
+ function Get_Parameter_Specification (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Parameter_Specification (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Parameter_Specification;
+
+ procedure Set_Parameter_Specification (Target : Iir; Param : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Parameter_Specification (Get_Kind (Target)));
+ Set_Field1 (Target, Param);
+ end Set_Parameter_Specification;
+
+ function Get_Parent (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Parent (Get_Kind (Target)));
+ return Get_Field0 (Target);
+ end Get_Parent;
+
+ procedure Set_Parent (Target : Iir; Parent : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Parent (Get_Kind (Target)));
+ Set_Field0 (Target, Parent);
+ end Set_Parent;
+
+ function Get_Loop_Label (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Loop_Label (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Loop_Label;
+
+ procedure Set_Loop_Label (Target : Iir; Stmt : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Loop_Label (Get_Kind (Target)));
+ Set_Field5 (Target, Stmt);
+ end Set_Loop_Label;
+
+ function Get_Component_Name (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Component_Name (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Component_Name;
+
+ procedure Set_Component_Name (Target : Iir; Name : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Component_Name (Get_Kind (Target)));
+ Set_Field4 (Target, Name);
+ end Set_Component_Name;
+
+ function Get_Instantiation_List (Target : Iir) return Iir_List is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Instantiation_List (Get_Kind (Target)));
+ return Iir_To_Iir_List (Get_Field1 (Target));
+ end Get_Instantiation_List;
+
+ procedure Set_Instantiation_List (Target : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Instantiation_List (Get_Kind (Target)));
+ Set_Field1 (Target, Iir_List_To_Iir (List));
+ end Set_Instantiation_List;
+
+ function Get_Entity_Aspect (Target : Iir_Binding_Indication) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Entity_Aspect (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Entity_Aspect;
+
+ procedure Set_Entity_Aspect (Target : Iir_Binding_Indication; Entity : Iir)
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Entity_Aspect (Get_Kind (Target)));
+ Set_Field3 (Target, Entity);
+ end Set_Entity_Aspect;
+
+ function Get_Default_Entity_Aspect (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Default_Entity_Aspect (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Default_Entity_Aspect;
+
+ procedure Set_Default_Entity_Aspect (Target : Iir; Aspect : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Default_Entity_Aspect (Get_Kind (Target)));
+ Set_Field1 (Target, Aspect);
+ end Set_Default_Entity_Aspect;
+
+ function Get_Default_Generic_Map_Aspect_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Default_Generic_Map_Aspect_Chain (Get_Kind (Target)));
+ return Get_Field6 (Target);
+ end Get_Default_Generic_Map_Aspect_Chain;
+
+ procedure Set_Default_Generic_Map_Aspect_Chain (Target : Iir; Chain : Iir)
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Default_Generic_Map_Aspect_Chain (Get_Kind (Target)));
+ Set_Field6 (Target, Chain);
+ end Set_Default_Generic_Map_Aspect_Chain;
+
+ function Get_Default_Port_Map_Aspect_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Default_Port_Map_Aspect_Chain (Get_Kind (Target)));
+ return Get_Field7 (Target);
+ end Get_Default_Port_Map_Aspect_Chain;
+
+ procedure Set_Default_Port_Map_Aspect_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Default_Port_Map_Aspect_Chain (Get_Kind (Target)));
+ Set_Field7 (Target, Chain);
+ end Set_Default_Port_Map_Aspect_Chain;
+
+ function Get_Binding_Indication (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Binding_Indication (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Binding_Indication;
+
+ procedure Set_Binding_Indication (Target : Iir; Binding : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Binding_Indication (Get_Kind (Target)));
+ Set_Field3 (Target, Binding);
+ end Set_Binding_Indication;
+
+ function Get_Named_Entity (Name : Iir) return Iir is
+ begin
+ pragma Assert (Name /= Null_Iir);
+ pragma Assert (Has_Named_Entity (Get_Kind (Name)));
+ return Get_Field4 (Name);
+ end Get_Named_Entity;
+
+ procedure Set_Named_Entity (Name : Iir; Val : Iir) is
+ begin
+ pragma Assert (Name /= Null_Iir);
+ pragma Assert (Has_Named_Entity (Get_Kind (Name)));
+ Set_Field4 (Name, Val);
+ end Set_Named_Entity;
+
+ function Get_Alias_Declaration (Name : Iir) return Iir is
+ begin
+ pragma Assert (Name /= Null_Iir);
+ pragma Assert (Has_Alias_Declaration (Get_Kind (Name)));
+ return Get_Field2 (Name);
+ end Get_Alias_Declaration;
+
+ procedure Set_Alias_Declaration (Name : Iir; Val : Iir) is
+ begin
+ pragma Assert (Name /= Null_Iir);
+ pragma Assert (Has_Alias_Declaration (Get_Kind (Name)));
+ Set_Field2 (Name, Val);
+ end Set_Alias_Declaration;
+
+ function Get_Expr_Staticness (Target : Iir) return Iir_Staticness is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Expr_Staticness (Get_Kind (Target)));
+ return Iir_Staticness'Val (Get_State1 (Target));
+ end Get_Expr_Staticness;
+
+ procedure Set_Expr_Staticness (Target : Iir; Static : Iir_Staticness) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Expr_Staticness (Get_Kind (Target)));
+ Set_State1 (Target, Iir_Staticness'Pos (Static));
+ end Set_Expr_Staticness;
+
+ function Get_Error_Origin (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Error_Origin (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Error_Origin;
+
+ procedure Set_Error_Origin (Target : Iir; Origin : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Error_Origin (Get_Kind (Target)));
+ Set_Field2 (Target, Origin);
+ end Set_Error_Origin;
+
+ function Get_Operand (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Operand (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Operand;
+
+ procedure Set_Operand (Target : Iir; An_Iir : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Operand (Get_Kind (Target)));
+ Set_Field2 (Target, An_Iir);
+ end Set_Operand;
+
+ function Get_Left (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Left (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Left;
+
+ procedure Set_Left (Target : Iir; An_Iir : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Left (Get_Kind (Target)));
+ Set_Field2 (Target, An_Iir);
+ end Set_Left;
+
+ function Get_Right (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Right (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Right;
+
+ procedure Set_Right (Target : Iir; An_Iir : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Right (Get_Kind (Target)));
+ Set_Field4 (Target, An_Iir);
+ end Set_Right;
+
+ function Get_Unit_Name (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Unit_Name (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Unit_Name;
+
+ procedure Set_Unit_Name (Target : Iir; Name : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Unit_Name (Get_Kind (Target)));
+ Set_Field3 (Target, Name);
+ end Set_Unit_Name;
+
+ function Get_Name (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Name (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Name;
+
+ procedure Set_Name (Target : Iir; Name : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Name (Get_Kind (Target)));
+ Set_Field4 (Target, Name);
+ end Set_Name;
+
+ function Get_Group_Template_Name (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Group_Template_Name (Get_Kind (Target)));
+ return Get_Field5 (Target);
+ end Get_Group_Template_Name;
+
+ procedure Set_Group_Template_Name (Target : Iir; Name : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Group_Template_Name (Get_Kind (Target)));
+ Set_Field5 (Target, Name);
+ end Set_Group_Template_Name;
+
+ function Get_Name_Staticness (Target : Iir) return Iir_Staticness is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Name_Staticness (Get_Kind (Target)));
+ return Iir_Staticness'Val (Get_State2 (Target));
+ end Get_Name_Staticness;
+
+ procedure Set_Name_Staticness (Target : Iir; Static : Iir_Staticness) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Name_Staticness (Get_Kind (Target)));
+ Set_State2 (Target, Iir_Staticness'Pos (Static));
+ end Set_Name_Staticness;
+
+ function Get_Prefix (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Prefix (Get_Kind (Target)));
+ return Get_Field0 (Target);
+ end Get_Prefix;
+
+ procedure Set_Prefix (Target : Iir; Prefix : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Prefix (Get_Kind (Target)));
+ Set_Field0 (Target, Prefix);
+ end Set_Prefix;
+
+ function Get_Signature_Prefix (Sign : Iir) return Iir is
+ begin
+ pragma Assert (Sign /= Null_Iir);
+ pragma Assert (Has_Signature_Prefix (Get_Kind (Sign)));
+ return Get_Field1 (Sign);
+ end Get_Signature_Prefix;
+
+ procedure Set_Signature_Prefix (Sign : Iir; Prefix : Iir) is
+ begin
+ pragma Assert (Sign /= Null_Iir);
+ pragma Assert (Has_Signature_Prefix (Get_Kind (Sign)));
+ Set_Field1 (Sign, Prefix);
+ end Set_Signature_Prefix;
+
+ function Get_Slice_Subtype (Slice : Iir) return Iir is
+ begin
+ pragma Assert (Slice /= Null_Iir);
+ pragma Assert (Has_Slice_Subtype (Get_Kind (Slice)));
+ return Get_Field3 (Slice);
+ end Get_Slice_Subtype;
+
+ procedure Set_Slice_Subtype (Slice : Iir; Atype : Iir) is
+ begin
+ pragma Assert (Slice /= Null_Iir);
+ pragma Assert (Has_Slice_Subtype (Get_Kind (Slice)));
+ Set_Field3 (Slice, Atype);
+ end Set_Slice_Subtype;
+
+ function Get_Suffix (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Suffix (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Suffix;
+
+ procedure Set_Suffix (Target : Iir; Suffix : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Suffix (Get_Kind (Target)));
+ Set_Field2 (Target, Suffix);
+ end Set_Suffix;
+
+ function Get_Index_Subtype (Attr : Iir) return Iir is
+ begin
+ pragma Assert (Attr /= Null_Iir);
+ pragma Assert (Has_Index_Subtype (Get_Kind (Attr)));
+ return Get_Field2 (Attr);
+ end Get_Index_Subtype;
+
+ procedure Set_Index_Subtype (Attr : Iir; St : Iir) is
+ begin
+ pragma Assert (Attr /= Null_Iir);
+ pragma Assert (Has_Index_Subtype (Get_Kind (Attr)));
+ Set_Field2 (Attr, St);
+ end Set_Index_Subtype;
+
+ function Get_Parameter (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Parameter (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Parameter;
+
+ procedure Set_Parameter (Target : Iir; Param : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Parameter (Get_Kind (Target)));
+ Set_Field4 (Target, Param);
+ end Set_Parameter;
+
+ function Get_Actual_Type (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Actual_Type (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Actual_Type;
+
+ procedure Set_Actual_Type (Target : Iir; Atype : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Actual_Type (Get_Kind (Target)));
+ Set_Field3 (Target, Atype);
+ end Set_Actual_Type;
+
+ function Get_Associated_Interface (Assoc : Iir) return Iir is
+ begin
+ pragma Assert (Assoc /= Null_Iir);
+ pragma Assert (Has_Associated_Interface (Get_Kind (Assoc)));
+ return Get_Field4 (Assoc);
+ end Get_Associated_Interface;
+
+ procedure Set_Associated_Interface (Assoc : Iir; Inter : Iir) is
+ begin
+ pragma Assert (Assoc /= Null_Iir);
+ pragma Assert (Has_Associated_Interface (Get_Kind (Assoc)));
+ Set_Field4 (Assoc, Inter);
+ end Set_Associated_Interface;
+
+ function Get_Association_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Association_Chain (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Association_Chain;
+
+ procedure Set_Association_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Association_Chain (Get_Kind (Target)));
+ Set_Field2 (Target, Chain);
+ end Set_Association_Chain;
+
+ function Get_Individual_Association_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Individual_Association_Chain (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Individual_Association_Chain;
+
+ procedure Set_Individual_Association_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Individual_Association_Chain (Get_Kind (Target)));
+ Set_Field4 (Target, Chain);
+ end Set_Individual_Association_Chain;
+
+ function Get_Aggregate_Info (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggregate_Info (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Aggregate_Info;
+
+ procedure Set_Aggregate_Info (Target : Iir; Info : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggregate_Info (Get_Kind (Target)));
+ Set_Field2 (Target, Info);
+ end Set_Aggregate_Info;
+
+ function Get_Sub_Aggregate_Info (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Sub_Aggregate_Info (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Sub_Aggregate_Info;
+
+ procedure Set_Sub_Aggregate_Info (Target : Iir; Info : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Sub_Aggregate_Info (Get_Kind (Target)));
+ Set_Field1 (Target, Info);
+ end Set_Sub_Aggregate_Info;
+
+ function Get_Aggr_Dynamic_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggr_Dynamic_Flag (Get_Kind (Target)));
+ return Get_Flag3 (Target);
+ end Get_Aggr_Dynamic_Flag;
+
+ procedure Set_Aggr_Dynamic_Flag (Target : Iir; Val : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggr_Dynamic_Flag (Get_Kind (Target)));
+ Set_Flag3 (Target, Val);
+ end Set_Aggr_Dynamic_Flag;
+
+ function Get_Aggr_Min_Length (Info : Iir_Aggregate_Info) return Iir_Int32
+ is
+ begin
+ pragma Assert (Info /= Null_Iir);
+ pragma Assert (Has_Aggr_Min_Length (Get_Kind (Info)));
+ return Iir_To_Iir_Int32 (Get_Field4 (Info));
+ end Get_Aggr_Min_Length;
+
+ procedure Set_Aggr_Min_Length (Info : Iir_Aggregate_Info; Nbr : Iir_Int32)
+ is
+ begin
+ pragma Assert (Info /= Null_Iir);
+ pragma Assert (Has_Aggr_Min_Length (Get_Kind (Info)));
+ Set_Field4 (Info, Iir_Int32_To_Iir (Nbr));
+ end Set_Aggr_Min_Length;
+
+ function Get_Aggr_Low_Limit (Target : Iir_Aggregate_Info) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggr_Low_Limit (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Aggr_Low_Limit;
+
+ procedure Set_Aggr_Low_Limit (Target : Iir_Aggregate_Info; Limit : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggr_Low_Limit (Get_Kind (Target)));
+ Set_Field2 (Target, Limit);
+ end Set_Aggr_Low_Limit;
+
+ function Get_Aggr_High_Limit (Target : Iir_Aggregate_Info) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggr_High_Limit (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Aggr_High_Limit;
+
+ procedure Set_Aggr_High_Limit (Target : Iir_Aggregate_Info; Limit : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggr_High_Limit (Get_Kind (Target)));
+ Set_Field3 (Target, Limit);
+ end Set_Aggr_High_Limit;
+
+ function Get_Aggr_Others_Flag (Target : Iir_Aggregate_Info) return Boolean
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggr_Others_Flag (Get_Kind (Target)));
+ return Get_Flag2 (Target);
+ end Get_Aggr_Others_Flag;
+
+ procedure Set_Aggr_Others_Flag (Target : Iir_Aggregate_Info; Val : Boolean)
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggr_Others_Flag (Get_Kind (Target)));
+ Set_Flag2 (Target, Val);
+ end Set_Aggr_Others_Flag;
+
+ function Get_Aggr_Named_Flag (Target : Iir_Aggregate_Info) return Boolean
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggr_Named_Flag (Get_Kind (Target)));
+ return Get_Flag4 (Target);
+ end Get_Aggr_Named_Flag;
+
+ procedure Set_Aggr_Named_Flag (Target : Iir_Aggregate_Info; Val : Boolean)
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Aggr_Named_Flag (Get_Kind (Target)));
+ Set_Flag4 (Target, Val);
+ end Set_Aggr_Named_Flag;
+
+ function Get_Value_Staticness (Target : Iir) return Iir_Staticness is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Value_Staticness (Get_Kind (Target)));
+ return Iir_Staticness'Val (Get_State2 (Target));
+ end Get_Value_Staticness;
+
+ procedure Set_Value_Staticness (Target : Iir; Staticness : Iir_Staticness)
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Value_Staticness (Get_Kind (Target)));
+ Set_State2 (Target, Iir_Staticness'Pos (Staticness));
+ end Set_Value_Staticness;
+
+ function Get_Association_Choices_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Association_Choices_Chain (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Association_Choices_Chain;
+
+ procedure Set_Association_Choices_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Association_Choices_Chain (Get_Kind (Target)));
+ Set_Field4 (Target, Chain);
+ end Set_Association_Choices_Chain;
+
+ function Get_Case_Statement_Alternative_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Case_Statement_Alternative_Chain (Get_Kind (Target)));
+ return Get_Field1 (Target);
+ end Get_Case_Statement_Alternative_Chain;
+
+ procedure Set_Case_Statement_Alternative_Chain (Target : Iir; Chain : Iir)
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Case_Statement_Alternative_Chain (Get_Kind (Target)));
+ Set_Field1 (Target, Chain);
+ end Set_Case_Statement_Alternative_Chain;
+
+ function Get_Choice_Staticness (Target : Iir) return Iir_Staticness is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Choice_Staticness (Get_Kind (Target)));
+ return Iir_Staticness'Val (Get_State2 (Target));
+ end Get_Choice_Staticness;
+
+ procedure Set_Choice_Staticness (Target : Iir; Staticness : Iir_Staticness)
+ is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Choice_Staticness (Get_Kind (Target)));
+ Set_State2 (Target, Iir_Staticness'Pos (Staticness));
+ end Set_Choice_Staticness;
+
+ function Get_Procedure_Call (Stmt : Iir) return Iir is
+ begin
+ pragma Assert (Stmt /= Null_Iir);
+ pragma Assert (Has_Procedure_Call (Get_Kind (Stmt)));
+ return Get_Field1 (Stmt);
+ end Get_Procedure_Call;
+
+ procedure Set_Procedure_Call (Stmt : Iir; Call : Iir) is
+ begin
+ pragma Assert (Stmt /= Null_Iir);
+ pragma Assert (Has_Procedure_Call (Get_Kind (Stmt)));
+ Set_Field1 (Stmt, Call);
+ end Set_Procedure_Call;
+
+ function Get_Implementation (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Implementation (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Implementation;
+
+ procedure Set_Implementation (Target : Iir; Decl : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Implementation (Get_Kind (Target)));
+ Set_Field3 (Target, Decl);
+ end Set_Implementation;
+
+ function Get_Parameter_Association_Chain (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Parameter_Association_Chain (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Parameter_Association_Chain;
+
+ procedure Set_Parameter_Association_Chain (Target : Iir; Chain : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Parameter_Association_Chain (Get_Kind (Target)));
+ Set_Field2 (Target, Chain);
+ end Set_Parameter_Association_Chain;
+
+ function Get_Method_Object (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Method_Object (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Method_Object;
+
+ procedure Set_Method_Object (Target : Iir; Object : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Method_Object (Get_Kind (Target)));
+ Set_Field4 (Target, Object);
+ end Set_Method_Object;
+
+ function Get_Subtype_Type_Mark (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subtype_Type_Mark (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Subtype_Type_Mark;
+
+ procedure Set_Subtype_Type_Mark (Target : Iir; Mark : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Subtype_Type_Mark (Get_Kind (Target)));
+ Set_Field2 (Target, Mark);
+ end Set_Subtype_Type_Mark;
+
+ function Get_Type_Conversion_Subtype (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Type_Conversion_Subtype (Get_Kind (Target)));
+ return Get_Field3 (Target);
+ end Get_Type_Conversion_Subtype;
+
+ procedure Set_Type_Conversion_Subtype (Target : Iir; Atype : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Type_Conversion_Subtype (Get_Kind (Target)));
+ Set_Field3 (Target, Atype);
+ end Set_Type_Conversion_Subtype;
+
+ function Get_Type_Mark (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Type_Mark (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Type_Mark;
+
+ procedure Set_Type_Mark (Target : Iir; Mark : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Type_Mark (Get_Kind (Target)));
+ Set_Field4 (Target, Mark);
+ end Set_Type_Mark;
+
+ function Get_File_Type_Mark (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_File_Type_Mark (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_File_Type_Mark;
+
+ procedure Set_File_Type_Mark (Target : Iir; Mark : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_File_Type_Mark (Get_Kind (Target)));
+ Set_Field2 (Target, Mark);
+ end Set_File_Type_Mark;
+
+ function Get_Return_Type_Mark (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Return_Type_Mark (Get_Kind (Target)));
+ return Get_Field8 (Target);
+ end Get_Return_Type_Mark;
+
+ procedure Set_Return_Type_Mark (Target : Iir; Mark : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Return_Type_Mark (Get_Kind (Target)));
+ Set_Field8 (Target, Mark);
+ end Set_Return_Type_Mark;
+
+ function Get_Lexical_Layout (Decl : Iir) return Iir_Lexical_Layout_Type is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Lexical_Layout (Get_Kind (Decl)));
+ return Iir_Lexical_Layout_Type'Val (Get_Odigit2 (Decl));
+ end Get_Lexical_Layout;
+
+ procedure Set_Lexical_Layout (Decl : Iir; Lay : Iir_Lexical_Layout_Type) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Lexical_Layout (Get_Kind (Decl)));
+ Set_Odigit2 (Decl, Iir_Lexical_Layout_Type'Pos (Lay));
+ end Set_Lexical_Layout;
+
+ function Get_Incomplete_Type_List (Target : Iir) return Iir_List is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Incomplete_Type_List (Get_Kind (Target)));
+ return Iir_To_Iir_List (Get_Field2 (Target));
+ end Get_Incomplete_Type_List;
+
+ procedure Set_Incomplete_Type_List (Target : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Incomplete_Type_List (Get_Kind (Target)));
+ Set_Field2 (Target, Iir_List_To_Iir (List));
+ end Set_Incomplete_Type_List;
+
+ function Get_Has_Disconnect_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Has_Disconnect_Flag (Get_Kind (Target)));
+ return Get_Flag1 (Target);
+ end Get_Has_Disconnect_Flag;
+
+ procedure Set_Has_Disconnect_Flag (Target : Iir; Val : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Has_Disconnect_Flag (Get_Kind (Target)));
+ Set_Flag1 (Target, Val);
+ end Set_Has_Disconnect_Flag;
+
+ function Get_Has_Active_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Has_Active_Flag (Get_Kind (Target)));
+ return Get_Flag2 (Target);
+ end Get_Has_Active_Flag;
+
+ procedure Set_Has_Active_Flag (Target : Iir; Val : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Has_Active_Flag (Get_Kind (Target)));
+ Set_Flag2 (Target, Val);
+ end Set_Has_Active_Flag;
+
+ function Get_Is_Within_Flag (Target : Iir) return Boolean is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Is_Within_Flag (Get_Kind (Target)));
+ return Get_Flag5 (Target);
+ end Get_Is_Within_Flag;
+
+ procedure Set_Is_Within_Flag (Target : Iir; Val : Boolean) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Is_Within_Flag (Get_Kind (Target)));
+ Set_Flag5 (Target, Val);
+ end Set_Is_Within_Flag;
+
+ function Get_Type_Marks_List (Target : Iir) return Iir_List is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Type_Marks_List (Get_Kind (Target)));
+ return Iir_To_Iir_List (Get_Field2 (Target));
+ end Get_Type_Marks_List;
+
+ procedure Set_Type_Marks_List (Target : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Type_Marks_List (Get_Kind (Target)));
+ Set_Field2 (Target, Iir_List_To_Iir (List));
+ end Set_Type_Marks_List;
+
+ function Get_Implicit_Alias_Flag (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Implicit_Alias_Flag (Get_Kind (Decl)));
+ return Get_Flag1 (Decl);
+ end Get_Implicit_Alias_Flag;
+
+ procedure Set_Implicit_Alias_Flag (Decl : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Implicit_Alias_Flag (Get_Kind (Decl)));
+ Set_Flag1 (Decl, Flag);
+ end Set_Implicit_Alias_Flag;
+
+ function Get_Alias_Signature (Alias : Iir) return Iir is
+ begin
+ pragma Assert (Alias /= Null_Iir);
+ pragma Assert (Has_Alias_Signature (Get_Kind (Alias)));
+ return Get_Field5 (Alias);
+ end Get_Alias_Signature;
+
+ procedure Set_Alias_Signature (Alias : Iir; Signature : Iir) is
+ begin
+ pragma Assert (Alias /= Null_Iir);
+ pragma Assert (Has_Alias_Signature (Get_Kind (Alias)));
+ Set_Field5 (Alias, Signature);
+ end Set_Alias_Signature;
+
+ function Get_Attribute_Signature (Attr : Iir) return Iir is
+ begin
+ pragma Assert (Attr /= Null_Iir);
+ pragma Assert (Has_Attribute_Signature (Get_Kind (Attr)));
+ return Get_Field2 (Attr);
+ end Get_Attribute_Signature;
+
+ procedure Set_Attribute_Signature (Attr : Iir; Signature : Iir) is
+ begin
+ pragma Assert (Attr /= Null_Iir);
+ pragma Assert (Has_Attribute_Signature (Get_Kind (Attr)));
+ Set_Field2 (Attr, Signature);
+ end Set_Attribute_Signature;
+
+ function Get_Overload_List (Target : Iir) return Iir_List is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Overload_List (Get_Kind (Target)));
+ return Iir_To_Iir_List (Get_Field1 (Target));
+ end Get_Overload_List;
+
+ procedure Set_Overload_List (Target : Iir; List : Iir_List) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Overload_List (Get_Kind (Target)));
+ Set_Field1 (Target, Iir_List_To_Iir (List));
+ end Set_Overload_List;
+
+ function Get_Simple_Name_Identifier (Target : Iir) return Name_Id is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Simple_Name_Identifier (Get_Kind (Target)));
+ return Iir_To_Name_Id (Get_Field3 (Target));
+ end Get_Simple_Name_Identifier;
+
+ procedure Set_Simple_Name_Identifier (Target : Iir; Ident : Name_Id) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Simple_Name_Identifier (Get_Kind (Target)));
+ Set_Field3 (Target, Name_Id_To_Iir (Ident));
+ end Set_Simple_Name_Identifier;
+
+ function Get_Simple_Name_Subtype (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Simple_Name_Subtype (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Simple_Name_Subtype;
+
+ procedure Set_Simple_Name_Subtype (Target : Iir; Atype : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Simple_Name_Subtype (Get_Kind (Target)));
+ Set_Field4 (Target, Atype);
+ end Set_Simple_Name_Subtype;
+
+ function Get_Protected_Type_Body (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Protected_Type_Body (Get_Kind (Target)));
+ return Get_Field2 (Target);
+ end Get_Protected_Type_Body;
+
+ procedure Set_Protected_Type_Body (Target : Iir; Bod : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Protected_Type_Body (Get_Kind (Target)));
+ Set_Field2 (Target, Bod);
+ end Set_Protected_Type_Body;
+
+ function Get_Protected_Type_Declaration (Target : Iir) return Iir is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Protected_Type_Declaration (Get_Kind (Target)));
+ return Get_Field4 (Target);
+ end Get_Protected_Type_Declaration;
+
+ procedure Set_Protected_Type_Declaration (Target : Iir; Decl : Iir) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_Protected_Type_Declaration (Get_Kind (Target)));
+ Set_Field4 (Target, Decl);
+ end Set_Protected_Type_Declaration;
+
+ function Get_End_Location (Target : Iir) return Location_Type is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_End_Location (Get_Kind (Target)));
+ return Iir_To_Location_Type (Get_Field6 (Target));
+ end Get_End_Location;
+
+ procedure Set_End_Location (Target : Iir; Loc : Location_Type) is
+ begin
+ pragma Assert (Target /= Null_Iir);
+ pragma Assert (Has_End_Location (Get_Kind (Target)));
+ Set_Field6 (Target, Location_Type_To_Iir (Loc));
+ end Set_End_Location;
+
+ function Get_String_Id (Lit : Iir) return String_Id is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_String_Id (Get_Kind (Lit)));
+ return Iir_To_String_Id (Get_Field3 (Lit));
+ end Get_String_Id;
+
+ procedure Set_String_Id (Lit : Iir; Id : String_Id) is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_String_Id (Get_Kind (Lit)));
+ Set_Field3 (Lit, String_Id_To_Iir (Id));
+ end Set_String_Id;
+
+ function Get_String_Length (Lit : Iir) return Int32 is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_String_Length (Get_Kind (Lit)));
+ return Iir_To_Int32 (Get_Field4 (Lit));
+ end Get_String_Length;
+
+ procedure Set_String_Length (Lit : Iir; Len : Int32) is
+ begin
+ pragma Assert (Lit /= Null_Iir);
+ pragma Assert (Has_String_Length (Get_Kind (Lit)));
+ Set_Field4 (Lit, Int32_To_Iir (Len));
+ end Set_String_Length;
+
+ function Get_Use_Flag (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Use_Flag (Get_Kind (Decl)));
+ return Get_Flag6 (Decl);
+ end Get_Use_Flag;
+
+ procedure Set_Use_Flag (Decl : Iir; Val : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Use_Flag (Get_Kind (Decl)));
+ Set_Flag6 (Decl, Val);
+ end Set_Use_Flag;
+
+ function Get_End_Has_Reserved_Id (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_End_Has_Reserved_Id (Get_Kind (Decl)));
+ return Get_Flag8 (Decl);
+ end Get_End_Has_Reserved_Id;
+
+ procedure Set_End_Has_Reserved_Id (Decl : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_End_Has_Reserved_Id (Get_Kind (Decl)));
+ Set_Flag8 (Decl, Flag);
+ end Set_End_Has_Reserved_Id;
+
+ function Get_End_Has_Identifier (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_End_Has_Identifier (Get_Kind (Decl)));
+ return Get_Flag9 (Decl);
+ end Get_End_Has_Identifier;
+
+ procedure Set_End_Has_Identifier (Decl : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_End_Has_Identifier (Get_Kind (Decl)));
+ Set_Flag9 (Decl, Flag);
+ end Set_End_Has_Identifier;
+
+ function Get_End_Has_Postponed (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_End_Has_Postponed (Get_Kind (Decl)));
+ return Get_Flag10 (Decl);
+ end Get_End_Has_Postponed;
+
+ procedure Set_End_Has_Postponed (Decl : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_End_Has_Postponed (Get_Kind (Decl)));
+ Set_Flag10 (Decl, Flag);
+ end Set_End_Has_Postponed;
+
+ function Get_Has_Begin (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Begin (Get_Kind (Decl)));
+ return Get_Flag10 (Decl);
+ end Get_Has_Begin;
+
+ procedure Set_Has_Begin (Decl : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Begin (Get_Kind (Decl)));
+ Set_Flag10 (Decl, Flag);
+ end Set_Has_Begin;
+
+ function Get_Has_Is (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Is (Get_Kind (Decl)));
+ return Get_Flag7 (Decl);
+ end Get_Has_Is;
+
+ procedure Set_Has_Is (Decl : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Is (Get_Kind (Decl)));
+ Set_Flag7 (Decl, Flag);
+ end Set_Has_Is;
+
+ function Get_Has_Pure (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Pure (Get_Kind (Decl)));
+ return Get_Flag8 (Decl);
+ end Get_Has_Pure;
+
+ procedure Set_Has_Pure (Decl : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Pure (Get_Kind (Decl)));
+ Set_Flag8 (Decl, Flag);
+ end Set_Has_Pure;
+
+ function Get_Has_Body (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Body (Get_Kind (Decl)));
+ return Get_Flag9 (Decl);
+ end Get_Has_Body;
+
+ procedure Set_Has_Body (Decl : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Body (Get_Kind (Decl)));
+ Set_Flag9 (Decl, Flag);
+ end Set_Has_Body;
+
+ function Get_Has_Identifier_List (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Identifier_List (Get_Kind (Decl)));
+ return Get_Flag3 (Decl);
+ end Get_Has_Identifier_List;
+
+ procedure Set_Has_Identifier_List (Decl : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Identifier_List (Get_Kind (Decl)));
+ Set_Flag3 (Decl, Flag);
+ end Set_Has_Identifier_List;
+
+ function Get_Has_Mode (Decl : Iir) return Boolean is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Mode (Get_Kind (Decl)));
+ return Get_Flag8 (Decl);
+ end Get_Has_Mode;
+
+ procedure Set_Has_Mode (Decl : Iir; Flag : Boolean) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Has_Mode (Get_Kind (Decl)));
+ Set_Flag8 (Decl, Flag);
+ end Set_Has_Mode;
+
+ function Get_Is_Ref (N : Iir) return Boolean is
+ begin
+ pragma Assert (N /= Null_Iir);
+ pragma Assert (Has_Is_Ref (Get_Kind (N)));
+ return Get_Flag7 (N);
+ end Get_Is_Ref;
+
+ procedure Set_Is_Ref (N : Iir; Ref : Boolean) is
+ begin
+ pragma Assert (N /= Null_Iir);
+ pragma Assert (Has_Is_Ref (Get_Kind (N)));
+ Set_Flag7 (N, Ref);
+ end Set_Is_Ref;
+
+ function Get_Psl_Property (Decl : Iir) return PSL_Node is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Psl_Property (Get_Kind (Decl)));
+ return Iir_To_PSL_Node (Get_Field1 (Decl));
+ end Get_Psl_Property;
+
+ procedure Set_Psl_Property (Decl : Iir; Prop : PSL_Node) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Psl_Property (Get_Kind (Decl)));
+ Set_Field1 (Decl, PSL_Node_To_Iir (Prop));
+ end Set_Psl_Property;
+
+ function Get_Psl_Declaration (Decl : Iir) return PSL_Node is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Psl_Declaration (Get_Kind (Decl)));
+ return Iir_To_PSL_Node (Get_Field1 (Decl));
+ end Get_Psl_Declaration;
+
+ procedure Set_Psl_Declaration (Decl : Iir; Prop : PSL_Node) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Psl_Declaration (Get_Kind (Decl)));
+ Set_Field1 (Decl, PSL_Node_To_Iir (Prop));
+ end Set_Psl_Declaration;
+
+ function Get_Psl_Expression (Decl : Iir) return PSL_Node is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Psl_Expression (Get_Kind (Decl)));
+ return Iir_To_PSL_Node (Get_Field3 (Decl));
+ end Get_Psl_Expression;
+
+ procedure Set_Psl_Expression (Decl : Iir; Prop : PSL_Node) is
+ begin
+ pragma Assert (Decl /= Null_Iir);
+ pragma Assert (Has_Psl_Expression (Get_Kind (Decl)));
+ Set_Field3 (Decl, PSL_Node_To_Iir (Prop));
+ end Set_Psl_Expression;
+
+ function Get_Psl_Boolean (N : Iir) return PSL_Node is
+ begin
+ pragma Assert (N /= Null_Iir);
+ pragma Assert (Has_Psl_Boolean (Get_Kind (N)));
+ return Iir_To_PSL_Node (Get_Field1 (N));
+ end Get_Psl_Boolean;
+
+ procedure Set_Psl_Boolean (N : Iir; Bool : PSL_Node) is
+ begin
+ pragma Assert (N /= Null_Iir);
+ pragma Assert (Has_Psl_Boolean (Get_Kind (N)));
+ Set_Field1 (N, PSL_Node_To_Iir (Bool));
+ end Set_Psl_Boolean;
+
+ function Get_PSL_Clock (N : Iir) return PSL_Node is
+ begin
+ pragma Assert (N /= Null_Iir);
+ pragma Assert (Has_PSL_Clock (Get_Kind (N)));
+ return Iir_To_PSL_Node (Get_Field7 (N));
+ end Get_PSL_Clock;
+
+ procedure Set_PSL_Clock (N : Iir; Clock : PSL_Node) is
+ begin
+ pragma Assert (N /= Null_Iir);
+ pragma Assert (Has_PSL_Clock (Get_Kind (N)));
+ Set_Field7 (N, PSL_Node_To_Iir (Clock));
+ end Set_PSL_Clock;
+
+ function Get_PSL_NFA (N : Iir) return PSL_NFA is
+ begin
+ pragma Assert (N /= Null_Iir);
+ pragma Assert (Has_PSL_NFA (Get_Kind (N)));
+ return Iir_To_PSL_NFA (Get_Field8 (N));
+ end Get_PSL_NFA;
+
+ procedure Set_PSL_NFA (N : Iir; Fa : PSL_NFA) is
+ begin
+ pragma Assert (N /= Null_Iir);
+ pragma Assert (Has_PSL_NFA (Get_Kind (N)));
+ Set_Field8 (N, PSL_NFA_To_Iir (Fa));
+ end Set_PSL_NFA;
+
+end Iirs;
diff --git a/src/iirs.adb.in b/src/iirs.adb.in
new file mode 100644
index 000000000..04511bb67
--- /dev/null
+++ b/src/iirs.adb.in
@@ -0,0 +1,229 @@
+-- Tree node definitions.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Unchecked_Conversion;
+with Ada.Text_IO;
+with Nodes; use Nodes;
+with Lists; use Lists;
+with Nodes_Meta; use Nodes_Meta;
+
+package body Iirs is
+ function Is_Null (Node : Iir) return Boolean is
+ begin
+ return Node = Null_Iir;
+ end Is_Null;
+
+ function Is_Null_List (Node : Iir_List) return Boolean is
+ begin
+ return Node = Null_Iir_List;
+ end Is_Null_List;
+
+ ---------------------------------------------------
+ -- General subprograms that operate on every iir --
+ ---------------------------------------------------
+
+ function Get_Format (Kind : Iir_Kind) return Format_Type;
+
+ function Create_Iir (Kind : Iir_Kind) return Iir
+ is
+ Res : Iir;
+ Format : Format_Type;
+ begin
+ Format := Get_Format (Kind);
+ Res := Create_Node (Format);
+ Set_Nkind (Res, Iir_Kind'Pos (Kind));
+ return Res;
+ end Create_Iir;
+
+ -- Statistics.
+ procedure Disp_Stats
+ is
+ use Ada.Text_IO;
+ type Num_Array is array (Iir_Kind) of Natural;
+ Num : Num_Array := (others => 0);
+ type Format_Array is array (Format_Type) of Natural;
+ Formats : Format_Array := (others => 0);
+ Kind : Iir_Kind;
+ I : Iir;
+ Last_I : Iir;
+ Format : Format_Type;
+ begin
+ I := Error_Node + 1;
+ Last_I := Get_Last_Node;
+ while I < Last_I loop
+ Kind := Get_Kind (I);
+ Num (Kind) := Num (Kind) + 1;
+ Format := Get_Format (Kind);
+ Formats (Format) := Formats (Format) + 1;
+ case Format is
+ when Format_Medium =>
+ I := I + 2;
+ when Format_Short
+ | Format_Fp
+ | Format_Int =>
+ I := I + 1;
+ end case;
+ end loop;
+
+ Put_Line ("Stats per iir_kind:");
+ for J in Iir_Kind loop
+ if Num (J) /= 0 then
+ Put_Line (' ' & Iir_Kind'Image (J) & ':'
+ & Natural'Image (Num (J)));
+ end if;
+ end loop;
+ Put_Line ("Stats per formats:");
+ for J in Format_Type loop
+ Put_Line (' ' & Format_Type'Image (J) & ':'
+ & Natural'Image (Formats (J)));
+ end loop;
+ end Disp_Stats;
+
+ function Iir_Predefined_Shortcut_P (Func : Iir_Predefined_Functions)
+ return Boolean is
+ begin
+ case Func is
+ when Iir_Predefined_Bit_And
+ | Iir_Predefined_Bit_Or
+ | Iir_Predefined_Bit_Nand
+ | Iir_Predefined_Bit_Nor
+ | Iir_Predefined_Boolean_And
+ | Iir_Predefined_Boolean_Or
+ | Iir_Predefined_Boolean_Nand
+ | Iir_Predefined_Boolean_Nor =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Iir_Predefined_Shortcut_P;
+
+ function Create_Iir_Error return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Node (Format_Short);
+ Set_Nkind (Res, Iir_Kind'Pos (Iir_Kind_Error));
+ Set_Base_Type (Res, Res);
+ return Res;
+ end Create_Iir_Error;
+
+ procedure Location_Copy (Target: Iir; Src: Iir) is
+ begin
+ Set_Location (Target, Get_Location (Src));
+ end Location_Copy;
+
+ -- Get kind
+ function Get_Kind (An_Iir: Iir) return Iir_Kind
+ is
+ -- Speed up: avoid to check that nkind is in the bounds of Iir_Kind.
+ pragma Suppress (Range_Check);
+ begin
+ return Iir_Kind'Val (Get_Nkind (An_Iir));
+ end Get_Kind;
+
+ function Time_Stamp_Id_To_Iir is new Ada.Unchecked_Conversion
+ (Source => Time_Stamp_Id, Target => Iir);
+
+ function Iir_To_Time_Stamp_Id is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => Time_Stamp_Id);
+
+ function Iir_To_Iir_List is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => Iir_List);
+ function Iir_List_To_Iir is new Ada.Unchecked_Conversion
+ (Source => Iir_List, Target => Iir);
+
+ function Iir_To_Token_Type (N : Iir) return Token_Type is
+ begin
+ return Token_Type'Val (N);
+ end Iir_To_Token_Type;
+
+ function Token_Type_To_Iir (T : Token_Type) return Iir is
+ begin
+ return Token_Type'Pos (T);
+ end Token_Type_To_Iir;
+
+-- function Iir_To_Iir_Index32 (N : Iir) return Iir_Index32 is
+-- begin
+-- return Iir_Index32 (N);
+-- end Iir_To_Iir_Index32;
+
+-- function Iir_Index32_To_Iir (V : Iir_Index32) return Iir is
+-- begin
+-- return Iir_Index32'Pos (V);
+-- end Iir_Index32_To_Iir;
+
+ function Iir_To_Name_Id (N : Iir) return Name_Id is
+ begin
+ return Iir'Pos (N);
+ end Iir_To_Name_Id;
+ pragma Inline (Iir_To_Name_Id);
+
+ function Name_Id_To_Iir (V : Name_Id) return Iir is
+ begin
+ return Name_Id'Pos (V);
+ end Name_Id_To_Iir;
+
+ function Iir_To_Iir_Int32 is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => Iir_Int32);
+
+ function Iir_Int32_To_Iir is new Ada.Unchecked_Conversion
+ (Source => Iir_Int32, Target => Iir);
+
+ function Iir_To_Source_Ptr (N : Iir) return Source_Ptr is
+ begin
+ return Source_Ptr (N);
+ end Iir_To_Source_Ptr;
+
+ function Source_Ptr_To_Iir (P : Source_Ptr) return Iir is
+ begin
+ return Iir (P);
+ end Source_Ptr_To_Iir;
+
+ function Iir_To_Location_Type (N : Iir) return Location_Type is
+ begin
+ return Location_Type (N);
+ end Iir_To_Location_Type;
+
+ function Location_Type_To_Iir (L : Location_Type) return Iir is
+ begin
+ return Iir (L);
+ end Location_Type_To_Iir;
+
+ function Iir_To_String_Id is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => String_Id);
+ function String_Id_To_Iir is new Ada.Unchecked_Conversion
+ (Source => String_Id, Target => Iir);
+
+ function Iir_To_Int32 is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => Int32);
+ function Int32_To_Iir is new Ada.Unchecked_Conversion
+ (Source => Int32, Target => Iir);
+
+ function Iir_To_PSL_Node is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => PSL_Node);
+
+ function PSL_Node_To_Iir is new Ada.Unchecked_Conversion
+ (Source => PSL_Node, Target => Iir);
+
+ function Iir_To_PSL_NFA is new Ada.Unchecked_Conversion
+ (Source => Iir, Target => PSL_NFA);
+
+ function PSL_NFA_To_Iir is new Ada.Unchecked_Conversion
+ (Source => PSL_NFA, Target => Iir);
+
+ -- Subprograms
+end Iirs;
diff --git a/src/iirs.ads b/src/iirs.ads
new file mode 100644
index 000000000..cd58daa56
--- /dev/null
+++ b/src/iirs.ads
@@ -0,0 +1,6445 @@
+-- Tree node definitions.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Ada.Unchecked_Deallocation;
+with Types; use Types;
+with Tokens; use Tokens;
+with Nodes;
+with Lists;
+
+package Iirs is
+ -- This package defines the semantic tree and functions to handle it.
+ -- The tree is roughly based on IIR (Internal Intermediate Representation),
+ -- [AIRE/CE Advanced Intermediate Representation with Extensibility,
+ -- Common Environment. http://www.vhdl.org/aire/index.html ]
+ -- but oriented object features are not used, and sometimes, functions
+ -- or fields have changed.
+
+ -- Note: this tree is also used during syntaxic analysis, but with
+ -- a little bit different meanings for the fields.
+ -- The parser (parse package) build the tree.
+ -- The semantic pass (sem, sem_expr, sem_name) transforms it into a
+ -- semantic tree.
+
+ -- Documentation:
+ -- Only the semantic aspect is to be fully documented.
+ -- The syntaxic aspect is only used between parse and sem.
+
+ -- Each node of the tree is a record of type iir. The record has only
+ -- one discriminent, which contains the kind of the node. There is
+ -- currenlty no variant (but this can change, this is not public).
+
+ -- The root of a semantic tree is a library_declaration.
+ -- All the library_declarations are kept in a private list, held by
+ -- package libraries.
+ -- Exemple of a tree:
+ -- library_declaration
+ -- +-- design_file
+ -- +-- design_unit
+ -- | +-- entity_declaration
+ -- +-- design_unit
+ -- +-- architecture_body
+ -- ...
+
+ -- Since the tree can represent all the libraries and their contents, it
+ -- is not always loaded into memory.
+ -- When a library is loaded, only library_declaration, design_file,
+ -- design_unit and library_unit nodes are created. When a design_unit is
+ -- really loaded, the design_unit node is not replaced but modified (ie,
+ -- access to this node are still valid).
+
+ -- To add a new kind of node:
+ -- the name should be of the form iir_kind_NAME
+ -- add iir_kind_NAME in the definition of type iir_kind_type
+ -- document the node below: grammar, methods.
+ -- for each methods, add the name if the case statement in the body
+ -- (this enables the methods)
+ -- add an entry in disp_tree (debugging)
+ -- handle this node in Errorout.Disp_Node
+
+ -- Meta-grammar
+ -- This file is processed by a tool to automatically generate the body, so
+ -- it must follow a meta-grammar.
+ --
+ -- The low level representation is described in nodes.ads.
+ --
+ -- The literals for the nodes must be declared in this file like this:
+ -- type Iir_Kind is
+ -- (
+ -- Iir_Kind_AAA,
+ -- ...
+ -- Iir_Kind_ZZZ
+ -- );
+ -- The tool doesn't check for uniqness as this is done by the compiler.
+ --
+ -- It is possible to declare ranges of kinds like this:
+ -- subtype Iir_Kinds_RANGE is Iir_Kind range
+ -- Iir_Kind_FIRST ..
+ -- --Iir_Kind_MID
+ -- Iir_Kind_LAST;
+ -- Literals Iir_Kind_MID are optionnal (FIXME: make them required ?), but
+ -- if present all the values between FIRST and LAST must be present.
+ --
+ -- The methods appear after the comment: ' -- General methods.'
+ -- They have the following format:
+ -- -- Field: FIELD ATTR (CONV)
+ -- function Get_NAME (PNAME : PTYPE) return RTYPE;
+ -- procedure Set_NAME (PNAME : PTYPE; RNAME : RTYPE);
+ -- 'FIELD' indicate which field of the node is used to store the value.
+ -- ATTR is optional and if present must be one of:
+ -- Ref: the field is a reference to an existing node
+ -- Chain: the field contains a chain of nodes
+ -- Chain_Next: the field contains the next element of a chain (present
+ -- only on one field: Set/Get_Chain).
+ -- ' (CONV)' is present if the type of the value (indicated by RTYPE) is
+ -- different from the type of the field. CONV can be either 'uc' or 'pos'.
+ -- 'uc' indicates an unchecked conversion while 'pos' a pos/val conversion.
+ --
+ -- Nodes content is described between ' -- Start of Iir_Kind.' and
+ -- ' -- End of Iir_Kind.' like this:
+ -- -- Iir_Kind_NODE1 (FORMAT1)
+ -- -- Iir_Kind_NODE2 (FORMAT2)
+ -- --
+ -- -- Get/Set_NAME1 (FIELD1)
+ -- --
+ -- -- Get/Set_NAME2 (FIELD2)
+ -- -- Get/Set_NAME3 (Alias FIELD2)
+ -- --
+ -- -- Only for Iir_Kind_NODE1:
+ -- -- Get/Set_NAME4 (FIELD3)
+ -- Severals nodes can be described at once; at least one must be described.
+ -- Fields FIELD1, FIELD2, FIELD3 must be different, unless 'Alias ' is
+ -- present. The number of spaces is significant. The 'Only for ' lines
+ -- are optionnal and there may be severals of them.
+
+ -------------------------------------------------
+ -- General methods (can be used on all nodes): --
+ -------------------------------------------------
+
+ -- Create a node of kind KIND.
+ -- function Create_Iir (Kind: Iir_Kind) return Iir;
+ --
+ -- Deallocate a node. Deallocate fields that where allocated by
+ -- create_iir.
+ -- procedure Free_Iir (Target: in out Iir);
+ --
+ -- Get the kind of the iir.
+ -- See below for the (public) list of kinds.
+ -- function Get_Kind (An_Iir: Iir) return Iir_Kind;
+
+ -- Get the location of the node: ie the current position in the source
+ -- file when the node was created. This is a little bit fuzzy.
+ --
+ -- procedure Set_Location (Target: in out Iir; Location: Location_Type);
+ -- function Get_Location (Target: in out Iir) return Location_Type;
+ --
+ -- Copy a location from a node to another one.
+ -- procedure Location_Copy (Target: in out Iir; Src: in Iir);
+
+ -- The next line marks the start of the node description.
+ -- Start of Iir_Kind.
+
+ --------------------------------------------------
+ -- A set of methods are associed with a kind. --
+ --------------------------------------------------
+
+ -- Iir_Kind_Design_File (Medium)
+ -- LRM93 11
+ -- design_file ::= design_unit { design_unit }
+ --
+ -- The library containing this design file.
+ -- Get/Set_Library (Field0)
+ -- Get/Set_Parent (Alias Field0)
+ --
+ -- Get/Set_File_Dependence_List (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Analysis_Time_Stamp (Field3)
+ --
+ -- Get/Set_File_Time_Stamp (Field4)
+ --
+ -- Get the chain of unit contained in the file. This is a simply linked
+ -- chain, but the tail is kept to speed-up appending operation.
+ -- Get/Set_First_Design_Unit (Field5)
+ --
+ -- Get/Set_Last_Design_Unit (Field6)
+ --
+ -- Identifier for the design file file name and dirname.
+ -- Get/Set_Design_File_Filename (Field12)
+ -- Get/Set_Design_File_Directory (Field11)
+ --
+ -- Flag used during elaboration. Set when the file was already seen.
+ -- Get/Set_Elab_Flag (Flag3)
+
+ -- Iir_Kind_Design_Unit (Medium)
+ -- LRM93 11
+ -- design_unit ::= context_clause library_unit
+ --
+ -- The design_file containing this design unit.
+ -- Get/Set_Design_File (Field0)
+ -- Get/Set_Parent (Alias Field0)
+ --
+ -- Get the chain of context clause.
+ -- Get/Set_Context_Items (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set the library unit, which can be an entity, an architecture,
+ -- a package, a package body or a configuration.
+ -- Get/Set_Library_Unit (Field5)
+ --
+ -- Get/Set_End_Location (Field6)
+ --
+ -- Collision chain for units.
+ -- Get/Set_Hash_Chain (Field7)
+ --
+ -- Get the list of design units that must be analysed before this unit.
+ -- See LRM93 11.4 for the rules defining the order of analysis.
+ -- Get/Set_Dependence_List (Field8)
+ --
+ -- FIXME: this field can be put in the library_unit, since it is only used
+ -- when the units have been analyzed.
+ -- Get/Set_Analysis_Checks_List (Field9)
+ --
+ -- This is a symbolic date, only used as a order of analysis of design
+ -- units.
+ -- Get/Set_Date (Field10)
+ --
+ -- Set the line and the offset in the line, only for the library manager.
+ -- This is valid until the file is really loaded in memory. On loading,
+ -- location will contain all this informations.
+ -- Get/Set_Design_Unit_Source_Pos (Field4)
+ --
+ -- Get/Set_Design_Unit_Source_Line (Field11)
+ --
+ -- Get/Set_Design_Unit_Source_Col (Field12)
+ --
+ -- Get/Set the date state, which indicates whether this design unit is in
+ -- memory or not.
+ -- Get/Set_Date_State (State1)
+ --
+ -- Flag used during elaboration. Set when the file was already seen.
+ -- Get/Set_Elab_Flag (Flag3)
+
+ -- Iir_Kind_Library_Clause (Short)
+ --
+ -- LRM08 13.2 Design libraries
+ --
+ -- library_clause ::= LIBRARY logical_name_list ;
+ --
+ -- logical_name_list ::= logical_name { , logical_name }
+ --
+ -- logical_name ::= identifier
+ --
+ -- Note: a library_clause node is created for every logical_name.
+ -- As a consequence, the scope of the library starts after the logical_name
+ -- and not after the library_clause. However, since an identifier
+ -- can only be used as a logical_name, and since the second occurence has
+ -- no effect, this is correct.
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Library_Declaration (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Has_Identifier_List (Flag3)
+
+ ---------------
+ -- Literals --
+ ---------------
+
+ -- Iir_Kind_String_Literal (Short)
+ -- Iir_Kind_Bit_String_Literal (Medium)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Used for computed literals. Literal_Origin contains the expression
+ -- whose value was computed during analysis and replaces the expression.
+ -- Get/Set_Literal_Origin (Field2)
+ --
+ -- Get/Set_String_Id (Field3)
+ --
+ -- As bit-strings are expanded to '0'/'1' strings, this is the number of
+ -- characters.
+ -- Get/Set_String_Length (Field4)
+ --
+ -- Same as Type, but marked as property of that node.
+ -- Get/Set_Literal_Subtype (Field5)
+ --
+ -- For bit string only:
+ -- Enumeration literal which correspond to '0' and '1'.
+ -- This cannot be defined only in the enumeration type definition, due to
+ -- possible aliases.
+ -- Only for Iir_Kind_Bit_String_Literal:
+ -- Get/Set_Bit_String_0 (Field6)
+ -- Only for Iir_Kind_Bit_String_Literal:
+ -- Get/Set_Bit_String_1 (Field7)
+ --
+ -- Only for Iir_Kind_Bit_String_Literal:
+ -- Get/Set_Bit_String_Base (Field8)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+
+ -- Iir_Kind_Integer_Literal (Int)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set the value of the integer.
+ -- Get/Set_Value (Int64)
+ --
+ -- Get/Set_Literal_Origin (Field2)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+
+ -- Iir_Kind_Floating_Point_Literal (Fp)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- The value of the literal.
+ -- Get/Set_Fp_Value (Fp64)
+ --
+ -- Get/Set_Literal_Origin (Field2)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+
+ -- Iir_Kind_Null_Literal (Short)
+ -- The null literal, which can be a disconnection or a null access.
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+
+ -- Iir_Kind_Physical_Int_Literal (Int)
+ -- Iir_Kind_Physical_Fp_Literal (Fp)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Literal_Origin (Field2)
+ --
+ -- The physical unit of the literal.
+ -- Get/Set_Unit_Name (Field3)
+ --
+ -- Must be set to locally except for time literal, which is globally.
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Only for Iir_Kind_Physical_Int_Literal:
+ -- The multiplicand.
+ -- Get/Set_Value (Int64)
+ --
+ -- Only for Iir_Kind_Physical_Fp_Literal:
+ -- The multiplicand.
+ -- Get/Set_Fp_Value (Fp64)
+
+ -- Iir_Kind_Simple_Aggregate (Short)
+ -- This node can only be generated by evaluation: it is an unidimentional
+ -- positional aggregate.
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Literal_Origin (Field2)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- List of elements
+ -- Get/Set_Simple_Aggregate_List (Field3)
+ --
+ -- Same as Type, but marked as property of that node.
+ -- Get/Set_Literal_Subtype (Field5)
+
+ -- Iir_Kind_Overflow_Literal (Short)
+ -- This node can only be generated by evaluation to represent an error: out
+ -- of range, division by zero...
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Literal_Origin (Field2)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+
+ -------------
+ -- Tuples --
+ -------------
+
+ -- Iir_Kind_Association_Element_By_Expression (Short)
+ -- Iir_Kind_Association_Element_Open (Short)
+ -- Iir_Kind_Association_Element_By_Individual (Short)
+ -- Iir_Kind_Association_Element_Package (Short)
+ -- These are used for association element of an association list with
+ -- an interface (ie subprogram call, port map, generic map).
+ --
+ -- Get/Set_Formal (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Only for Iir_Kind_Association_Element_By_Expression:
+ -- Only for Iir_Kind_Association_Element_Package:
+ -- Get/Set_Actual (Field3)
+ --
+ -- Only for Iir_Kind_Association_Element_By_Individual:
+ -- Get/Set_Actual_Type (Field3)
+ --
+ -- Only for Iir_Kind_Association_Element_By_Individual:
+ -- Get/Set_Individual_Association_Chain (Field4)
+ --
+ -- Only for Iir_Kind_Association_Element_Package:
+ -- Get/Set_Associated_Interface (Field4)
+ --
+ -- A function call or a type conversion for the association.
+ -- FIXME: should be a name ?
+ -- Only for Iir_Kind_Association_Element_By_Expression:
+ -- Get/Set_In_Conversion (Field4)
+ --
+ -- Only for Iir_Kind_Association_Element_By_Expression:
+ -- Get/Set_Out_Conversion (Field5)
+ --
+ -- Get/Set the whole association flag (true if the formal is associated in
+ -- whole and not individually, see LRM93 4.3.2.2)
+ -- Get/Set_Whole_Association_Flag (Flag1)
+ --
+ -- Get/Set_Collapse_Signal_Flag (Flag2)
+ --
+ -- Only for Iir_Kind_Association_Element_Open:
+ -- Get/Set_Artificial_Flag (Flag3)
+
+ -- Iir_Kind_Waveform_Element (Short)
+ --
+ -- Get/Set_We_Value (Field1)
+ --
+ -- Get/Set_Time (Field3)
+ --
+ -- Get/Set_Chain (Field2)
+
+ -- Iir_Kind_Conditional_Waveform (Short)
+ --
+ -- Get/Set_Condition (Field1)
+ --
+ -- Get/Set_Waveform_Chain (Field5)
+ --
+ -- Get/Set_Chain (Field2)
+
+ -- Iir_Kind_Choice_By_Others (Short)
+ -- Iir_Kind_Choice_By_None (Short)
+ -- Iir_Kind_Choice_By_Range (Short)
+ -- Iir_Kind_Choice_By_Name (Short)
+ -- Iir_Kind_Choice_By_Expression (Short)
+ -- (Iir_Kinds_Choice)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- For a list of choices, only the first one is associated, the following
+ -- associations have the same_alternative_flag set.
+ -- Get/Set_Chain (Field2)
+ --
+ -- These are elements of an choice chain, which is used for
+ -- case_statement, concurrent_select_signal_assignment, aggregates.
+ --
+ -- Get/Set what is associated with the choice. There are two different
+ -- nodes, one for simple association and the other for chain association.
+ -- This simplifies walkers. But both nodes are never used at the same
+ -- time.
+ --
+ -- For:
+ -- * an expression for an aggregate
+ -- * an individual association
+ -- Get/Set_Associated_Expr (Field3)
+ --
+ -- For
+ -- * a waveform_chain for a concurrent_select_signal_assignment,
+ -- * a sequential statement chain for a case_statement.
+ -- Get/Set_Associated_Chain (Field4)
+ --
+ -- Only for Iir_Kind_Choice_By_Name:
+ -- Get/Set_Choice_Name (Field5)
+ --
+ -- Only for Iir_Kind_Choice_By_Expression:
+ -- Get/Set_Choice_Expression (Field5)
+ --
+ -- Only for Iir_Kind_Choice_By_Range:
+ -- Get/Set_Choice_Range (Field5)
+ --
+ -- Get/Set_Same_Alternative_Flag (Flag1)
+ --
+ -- Only for Iir_Kind_Choice_By_Range:
+ -- Only for Iir_Kind_Choice_By_Expression:
+ -- Get/Set_Choice_Staticness (State2)
+
+ -- Iir_Kind_Entity_Aspect_Entity (Short)
+ --
+ -- Get/Set_Entity_Name (Field2)
+ --
+ -- parse: a simple name.
+ -- sem: an architecture declaration or NULL_IIR.
+ -- Get/Set_Architecture (Field3)
+
+ -- Iir_Kind_Entity_Aspect_Open (Short)
+
+ -- Iir_Kind_Entity_Aspect_Configuration (Short)
+ --
+ -- Get/Set_Configuration_Name (Field1)
+
+ -- Iir_Kind_Block_Configuration (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Configuration_Item_Chain (Field3)
+ --
+ -- Note: for default block configurations of iterative generate statement,
+ -- the block specification is an indexed_name, whose index_list is others.
+ -- Get/Set_Block_Specification (Field5)
+ --
+ -- Single linked list of block configuration that apply to the same
+ -- for scheme generate block.
+ -- Get/Set_Prev_Block_Configuration (Field4)
+
+ -- Iir_Kind_Binding_Indication (Medium)
+ --
+ -- Get/Set_Default_Entity_Aspect (Field1)
+ --
+ -- The entity aspect.
+ -- It is a iir_kind_entity_aspect_entity, iir_kind_entity_aspect_open or
+ -- iir_kind_entity_aspect_configuration. This may be transformed into a
+ -- declaration by semantic.
+ -- Get/Set_Entity_Aspect (Field3)
+ --
+ -- Get/Set_Default_Generic_Map_Aspect_Chain (Field6)
+ --
+ -- Get/Set_Default_Port_Map_Aspect_Chain (Field7)
+ --
+ -- Get/Set_Generic_Map_Aspect_Chain (Field8)
+ --
+ -- Get/Set_Port_Map_Aspect_Chain (Field9)
+
+ -- Iir_Kind_Component_Configuration (Short)
+ -- Iir_Kind_Configuration_Specification (Short)
+ --
+ -- LRM08 7.3 Configuration specification
+ --
+ -- configuration_specification ::=
+ -- simple_configuration_specification
+ -- | compound_configuration_specification
+ --
+ -- simple_configuration_specification ::=
+ -- FOR component_specification binding_indication ;
+ -- [ END FOR ; ]
+ --
+ -- compound_configuration_specification ::=
+ -- FOR component_specification binding_indication ;
+ -- verification_unit_binding_indication ;
+ -- { verification_unit_binding_indication ; }
+ -- END FOR ;
+ --
+ -- component_specification ::=
+ -- instantiation_list : component_name
+ --
+ -- instantiation_list ::=
+ -- instantiation_label { , instantiation_label }
+ -- | OTHERS
+ -- | ALL
+ --
+ -- The declaration containing this type declaration.
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Component_Name (Field4)
+ --
+ -- Must be one of designator_list, designator_by_others or
+ -- designator_by_all.
+ -- Get/Set_Instantiation_List (Field1)
+ --
+ -- Only for Iir_Kind_Component_Configuration:
+ -- Get/Set_Block_Configuration (Field5)
+ --
+ -- Get/Set_Binding_Indication (Field3)
+ --
+ -- Get/Set_Chain (Field2)
+
+ -- Iir_Kind_Disconnection_Specification (Short)
+ --
+ -- LRM08 7.4 Disconnection specification
+ --
+ -- disconnection_specification ::=
+ -- DISCONNECT guarded_signal_specification AFTER time_expression ;
+ --
+ -- guarded_signal_specification ::=
+ -- guarded_signal_list : type_mark
+ --
+ -- signal_list ::=
+ -- signal_name { , signal_name }
+ -- | OTHERS
+ -- | ALL
+ --
+ -- The declaration containing this type declaration.
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Signal_List (Field3)
+ --
+ -- Get/Set_Type_Mark (Field4)
+ --
+ -- Get/Set_Expression (Field5)
+
+ -- Iir_Kind_Block_Header (Medium)
+ --
+ -- Get/Set_Generic_Chain (Field6)
+ --
+ -- Get/Set_Port_Chain (Field7)
+ --
+ -- Get/Set_Generic_Map_Aspect_Chain (Field8)
+ --
+ -- Get/Set_Port_Map_Aspect_Chain (Field9)
+
+ -- Iir_Kind_Entity_Class (Short)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Entity_Class (Field3)
+
+ -- Iir_Kind_Attribute_Specification (Medium)
+ --
+ -- LRM08 7.2 Attribute specification
+ --
+ -- attribute_specification ::=
+ -- ATTRIBUTE attribute_designator OF entity_specification
+ -- IS expression ;
+ --
+ -- entity_specification ::= entity_name_list : entity_class
+ --
+ -- entity_name_list ::=
+ -- entity_designator { , entity_designator }
+ -- | OTHERS
+ -- | ALL
+ --
+ -- entity_designator ::= entity_tag [ signature ]
+ --
+ -- entity_tag ::= simple_name | character_literal | operator_symbol
+ --
+ -- LRM08 8.6 Attribute names
+ --
+ -- attribute_designator ::= /attribute/_simple_name
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Entity_Name_List (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Entity_Class (Field3)
+ --
+ -- Get/Set_Attribute_Value_Spec_Chain (Field4)
+ --
+ -- Get/Set_Expression (Field5)
+ --
+ -- Always a simple name.
+ -- Get/Set_Attribute_Designator (Field6)
+ --
+ -- Get/Set_Attribute_Specification_Chain (Field7)
+
+ -- Iir_Kind_Attribute_Value (Short)
+ -- An attribute value is the element of the chain of attribute of an
+ -- entity, marking the entity as decorated by the attribute.
+ -- This node is built only by sem.
+ -- In fact, the node is member of the chain of attribute of an entity, and
+ -- of the chain of entity of the attribute specification.
+ -- This makes elaboration (and more precisely, expression evaluation)
+ -- easier.
+ --
+ -- Get/Set_Spec_Chain (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Designated_Entity (Field3)
+ --
+ -- Get/Set_Attribute_Specification (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Psl_Expression (Short)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Psl_Expression (Field3)
+
+ -- Iir_Kind_Signature (Medium)
+ --
+ -- LRM08 4.5.3 Signatures
+ --
+ -- signature ::= '[' [ type_mark { , type_mark } ] [ RETURN type_mark ] ']'
+ --
+ -- Get/Set_Signature_Prefix (Field1)
+ --
+ -- Get/Set_Type_Marks_List (Field2)
+ --
+ -- Get/Set_Return_Type_Mark (Field8)
+
+ -- Iir_Kind_Overload_List (Short)
+ --
+ -- Get/Set_Overload_List (Field1)
+
+ -------------------
+ -- Declarations --
+ -------------------
+
+ -- Iir_Kind_Entity_Declaration (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ -- Get/Set_Design_Unit (Alias Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Concurrent_Statement_Chain (Field5)
+ --
+ -- Get/Set_Generic_Chain (Field6)
+ --
+ -- Get/Set_Port_Chain (Field7)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Is_Within_Flag (Flag5)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+ --
+ -- Get/Set_Has_Begin (Flag10)
+
+ -- Iir_Kind_Architecture_Body (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ -- Get/Set_Design_Unit (Alias Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Name of the entity declaration for the architecture.
+ -- Get/Set_Entity_Name (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Concurrent_Statement_Chain (Field5)
+ --
+ -- The default configuration created by canon. This is a design unit.
+ -- Get/Set_Default_Configuration_Declaration (Field6)
+ --
+ -- Get/Set_Foreign_Flag (Flag3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Is_Within_Flag (Flag5)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Configuration_Declaration (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ -- Get/Set_Design_Unit (Alias Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Name of the entity of a configuration.
+ -- Get/Set_Entity_Name (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Block_Configuration (Field5)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Package_Header (Medium)
+ --
+ -- Get/Set_Generic_Chain (Field6)
+ --
+ -- Get/Set_Generic_Map_Aspect_Chain (Field8)
+
+ -- Iir_Kind_Package_Declaration (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ -- Get/Set_Design_Unit (Alias Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Package_Body (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Package_Header (Field5)
+ --
+ -- Get/Set_Need_Body (Flag1)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Package_Body (Short)
+ -- Note: a body is not a declaration, that's the reason why there is no
+ -- _declaration suffix in the name.
+ --
+ -- Get/Set_Parent (Field0)
+ -- Get/Set_Design_Unit (Alias Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- The corresponding package declaration.
+ -- Get/Set_Package (Field4)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Package_Instantiation_Declaration (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ -- Get/Set_Design_Unit (Alias Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Package_Body (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Uninstantiated_Package_Name (Field5)
+ --
+ -- Get/Set_Generic_Chain (Field6)
+ --
+ -- Get/Set_Generic_Map_Aspect_Chain (Field8)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Library_Declaration (Medium)
+ --
+ -- Design files in the library.
+ -- Get/Set_Design_File_Chain (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- This node is used to contain all a library. Only internaly used.
+ -- Name (identifier) of the library.
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Date (Field10)
+ --
+ -- Get/Set_Library_Directory (Field11)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Component_Declaration (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Generic_Chain (Field6)
+ --
+ -- Get/Set_Port_Chain (Field7)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Get/Set_Has_Is (Flag7)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- LRM08 6.6 Alias declarations
+ --
+ -- alias_declaration ::=
+ -- ALIAS alias_designator [ : subtype_indication ] IS
+ -- name [ signature ] ;
+ --
+ -- alias_designator ::= identifier | character_literal | operator_symbol
+ --
+ -- Object aliases and non-object aliases are represented by two different
+ -- nodes, as their semantic is different. The parser only creates object
+ -- alias declaration nodes, but sem_decl replaces the node for non-object
+ -- alias declarations.
+
+ -- Iir_Kind_Object_Alias_Declaration (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- The type can be deduced from the subtype indication, but this field is
+ -- present for uniformity (and speed).
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Name (Field4)
+ --
+ -- The subtype indication may not be present.
+ -- Get/Set_Subtype_Indication (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_After_Drivers_Flag (Flag5)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Get/Set_Is_Ref (Flag7)
+
+ -- Iir_Kind_Non_Object_Alias_Declaration (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Name (Field4)
+ --
+ -- Get/Set_Alias_Signature (Field5)
+ --
+ -- Set when the alias was implicitely created (by Sem) because of an
+ -- explicit alias of a type.
+ -- Get/Set_Implicit_Alias_Flag (Flag1)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+
+ -- Iir_Kind_Anonymous_Type_Declaration (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type_Definition (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Used for informative purpose only.
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Subtype_Definition (Field4)
+
+ -- Iir_Kind_Type_Declaration (Short)
+ --
+ -- LRM08 6.3 Type declarations
+ --
+ -- type_declaration ::=
+ -- full_type_declaration
+ -- | incomplete_type_declaration
+ --
+ -- full_type_declaration ::=
+ -- TYPE identifier IS type_definition ;
+ --
+ -- type_definition ::=
+ -- scalar_type_definition
+ -- | composite_type_definition
+ -- | access_type_definition
+ -- | file_type_definition
+ -- | protected_type_definition
+ --
+ -- LRM08 5.4.2 Incomplete type declarations
+ --
+ -- incomplete_type_declaration ::=
+ -- TYPE identifier ;
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Definition of the type.
+ -- Note: the type definition can be a real type (unconstrained array,
+ -- enumeration, file, record, access) or a subtype (integer, floating
+ -- point).
+ -- The parser set this field to null_iir for an incomplete type
+ -- declaration. This field is set to an incomplete_type_definition node
+ -- when first semantized.
+ -- Get/Set_Type_Definition (Field1)
+ -- Get/Set_Type (Alias Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+
+ -- Iir_Kind_Subtype_Declaration (Short)
+ --
+ -- LRM08 6.3 Subtype declarations
+ --
+ -- subtype_declaration ::=
+ -- SUBTYPE identifier IS subtype_indication ;
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Subtype_Indication (Field5)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Get/Set_Is_Ref (Flag7)
+
+ -- Iir_Kind_Nature_Declaration (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Nature (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+
+ -- Iir_Kind_Subnature_Declaration (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Nature (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+
+ -- Iir_Kind_Interface_Signal_Declaration (Medium)
+ -- Iir_Kind_Interface_Constant_Declaration (Medium)
+ -- Iir_Kind_Interface_Variable_Declaration (Medium)
+ -- Iir_Kind_Interface_File_Declaration (Medium)
+ --
+ -- Get/Set the parent of an interface declaration.
+ -- The parent is an entity declaration, a subprogram specification, a
+ -- component declaration, a loop statement, a block declaration or ??
+ -- Useful to distinguish a port and an interface.
+ -- Get/Set_Parent (Field0)
+ --
+ -- The type can be deduced from the subtype indication, but this field is
+ -- present for uniformity (and speed).
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Subtype_Indication (Field5)
+ --
+ -- Must always be null_iir for iir_kind_interface_file_declaration.
+ -- Get/Set_Default_Value (Field6)
+ --
+ -- Get/Set_Mode (Odigit1)
+ --
+ -- Get/Set_Lexical_Layout (Odigit2)
+ --
+ -- Only for Iir_Kind_Interface_Signal_Declaration:
+ -- Get/Set_Has_Disconnect_Flag (Flag1)
+ --
+ -- Only for Iir_Kind_Interface_Signal_Declaration:
+ -- Get/Set_Has_Active_Flag (Flag2)
+ --
+ -- Only for Iir_Kind_Interface_Signal_Declaration:
+ -- Get/Set_Open_Flag (Flag3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_After_Drivers_Flag (Flag5)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Get/Set_Is_Ref (Flag7)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+ --
+ -- Only for Iir_Kind_Interface_Signal_Declaration:
+ -- Get/Set_Signal_Kind (State3)
+
+ -- Iir_Kind_Interface_Package_Declaration (Medium)
+ --
+ -- LRM08 6.5.5 Interface package declarations
+ --
+ -- interface_package_declaration ::=
+ -- PACKAGE identifier IS NEW /uninstantiated_package/_name
+ -- interface_package_generic_map_aspect
+ --
+ -- interface_package_generic_map_aspect ::=
+ -- generic_map_aspect
+ -- | GENERIC MAP ( <> ) -- Represented by Null_Iir
+ -- | GENERIC MAP ( DEFAULT ) -- Not yet implemented
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Uninstantiated_Package_Name (Field5)
+ --
+ -- Get/Set_Generic_Chain (Field6)
+ --
+ -- Get/Set_Generic_Map_Aspect_Chain (Field8)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Function_Declaration (Medium)
+ -- Iir_Kind_Procedure_Declaration (Medium)
+ --
+ -- LRM08 4.2 Subprogram declarations
+ --
+ -- subprogram_declaration ::= subprogram_specification ;
+ --
+ -- subprogram_specification ::=
+ -- procedure_specification | function_specification
+ --
+ -- procedure_specification ::=
+ -- PROCEDURE designator
+ -- subprogram_header
+ -- [ [ PARAMETER ] ( formal_parameter_list ) ]
+ --
+ -- function_specification ::=
+ -- [ PURE | IMPURE ] FUNCTION designator
+ -- subprogram_header
+ -- [ [ PARAMETER ] ( formal_parameter_list ) ] return type_mark
+ --
+ -- designator ::= identifier | operator_symbol
+ --
+ -- operator_symbol ::= string_literal
+ --
+ -- Note: the subprogram specification of a body is kept, but should be
+ -- ignored if there is a subprogram declaration. The function
+ -- Is_Second_Subprogram_Specification returns True on such specification.
+ --
+ -- The declaration containing this subrogram declaration.
+ -- Get/Set_Parent (Field0)
+ --
+ -- Only for Iir_Kind_Function_Declaration:
+ -- Get/Set_Return_Type (Field1)
+ --
+ -- Only for Iir_Kind_Function_Declaration:
+ -- Get/Set_Type (Alias Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Interface_Declaration_Chain (Field5)
+ --
+ -- Get/Set_Generic_Chain (Field6)
+ --
+ -- --Get/Set_Generic_Map_Aspect_Chain (Field8)
+ --
+ -- Get/Set_Return_Type_Mark (Field8)
+ --
+ -- Get/Set_Subprogram_Body (Field9)
+ --
+ -- Get/Set_Subprogram_Depth (Field10)
+ --
+ -- Get/Set_Subprogram_Hash (Field11)
+ --
+ -- Get/Set_Overload_Number (Field12)
+ --
+ -- Get/Set_Seen_Flag (Flag1)
+ --
+ -- Only for Iir_Kind_Function_Declaration:
+ -- Get/Set_Pure_Flag (Flag2)
+ --
+ -- Only for Iir_Kind_Procedure_Declaration:
+ -- Get/Set_Passive_Flag (Flag2)
+ --
+ -- Get/Set_Foreign_Flag (Flag3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Is_Within_Flag (Flag5)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Only for Iir_Kind_Function_Declaration:
+ -- Get/Set_Resolution_Function_Flag (Flag7)
+ --
+ -- Only for Iir_Kind_Function_Declaration:
+ -- Get/Set_Has_Pure (Flag8)
+ --
+ -- True is the specification is immediately followed by a body.
+ -- Get/Set_Has_Body (Flag9)
+ --
+ -- Get/Set_Wait_State (State1)
+ --
+ -- Only for Iir_Kind_Procedure_Declaration:
+ -- Get/Set_Purity_State (State2)
+ --
+ -- Get/Set_All_Sensitized_State (State3)
+
+ -- Iir_Kind_Function_Body (Medium)
+ -- Iir_Kind_Procedure_Body (Medium)
+ --
+ -- LRM08 4.3 Subprogram bodies
+ --
+ -- subprogram_body ::=
+ -- subprogram_specification IS
+ -- subprogram_declarative_part
+ -- BEGIN
+ -- subprogram_statement_part
+ -- END [ subprogram_kind ] [ designator ] ;
+ --
+ -- subprogram_kind ::= PROCEDURE | FUNCTION
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- The parse stage always puts a declaration before a body.
+ -- Sem will remove the declaration if there is a forward declaration.
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Impure_Depth (Field3)
+ --
+ -- Get/Set_Subprogram_Specification (Field4)
+ --
+ -- Get/Set_Sequential_Statement_Chain (Field5)
+ --
+ -- Get/Set_Callees_List (Field7)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Implicit_Procedure_Declaration (Medium)
+ -- Iir_Kind_Implicit_Function_Declaration (Medium)
+ --
+ -- This node contains a subprogram_declaration that was implicitly defined
+ -- just after a type declaration.
+ -- This declaration is inserted by sem.
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Only for Iir_Kind_Implicit_Function_Declaration:
+ -- Get/Set_Return_Type (Field1)
+ --
+ -- Only for Iir_Kind_Implicit_Function_Declaration:
+ -- Get/Set_Type (Alias Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Interface_Declaration_Chain (Field5)
+ --
+ -- Get/Set_Generic_Chain (Field6)
+ --
+ -- Get/Set_Generic_Map_Aspect_Chain (Field8)
+ --
+ -- Get/Set_Implicit_Definition (Field9)
+ --
+ -- Get/Set_Type_Reference (Field10)
+ --
+ -- Get/Set_Subprogram_Hash (Field11)
+ --
+ -- Get/Set_Overload_Number (Field12)
+ --
+ -- Get/Set_Wait_State (State1)
+ --
+ -- Get/Set_Seen_Flag (Flag1)
+ --
+ -- Only for Iir_Kind_Implicit_Function_Declaration:
+ -- Get/Set_Pure_Flag (Flag2)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Is_Within_Flag (Flag5)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+
+ -- Iir_Kind_Signal_Declaration (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Subtype_Indication (Field5)
+ --
+ -- Get/Set_Default_Value (Field6)
+ --
+ -- For a non-resolved signal: null_iir if the signal has no driver, or
+ -- a process/concurrent_statement for which the signal should have a
+ -- driver. This is used to catch at analyse time unresolved signals with
+ -- several drivers.
+ -- Get/Set_Signal_Driver (Field7)
+ --
+ -- Get/Set_Has_Disconnect_Flag (Flag1)
+ --
+ -- Get/Set_Has_Identifier_List (Flag3)
+ --
+ -- Get/Set_Has_Active_Flag (Flag2)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_After_Drivers_Flag (Flag5)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Get/Set_Is_Ref (Flag7)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+ --
+ -- Get/Set_Signal_Kind (State3)
+
+ -- Iir_Kind_Guard_Signal_Declaration (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Guard_Expression (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Guard_Sensitivity_List (Field6)
+ --
+ -- Get/Set_Block_Statement (Field7)
+ --
+ -- Get/Set_Has_Active_Flag (Flag2)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+ --
+ -- Get/Set_Signal_Kind (State3)
+
+ -- Iir_Kind_Constant_Declaration (Medium)
+ -- Iir_Kind_Iterator_Declaration (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- For iterator, this is the reconstructed subtype indication.
+ -- Get/Set_Subtype_Indication (Field5)
+ --
+ -- Only for Iir_Kind_Iterator_Declaration:
+ -- Get/Set_Discrete_Range (Field6)
+ --
+ -- Only for Iir_Kind_Constant_Declaration:
+ -- Default value of a deferred constant points to the full constant
+ -- declaration.
+ -- Get/Set_Default_Value (Field6)
+ --
+ -- Only for Iir_Kind_Constant_Declaration:
+ -- Summary:
+ -- | constant C1 : integer; -- Deferred declaration (in a package)
+ -- | constant C2 : integer := 4; -- Declaration
+ -- | constant C1 : integer := 3; -- Full declaration (in a body)
+ -- | NAME Deferred_declaration Deferred_declaration_flag
+ -- | C1 Null_iir or C1' (*) True
+ -- | C2 Null_Iir False
+ -- | C1' C1 False
+ -- |(*): Deferred_declaration is Null_Iir as long as the full declaration
+ -- | has not been analyzed.
+ -- Get/Set_Deferred_Declaration (Field7)
+ --
+ -- Only for Iir_Kind_Constant_Declaration:
+ -- Get/Set_Deferred_Declaration_Flag (Flag1)
+ --
+ -- Get/Set_Has_Identifier_List (Flag3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Get/Set_Is_Ref (Flag7)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Variable_Declaration (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Subtype_Indication (Field5)
+ --
+ -- Get/Set_Default_Value (Field6)
+ --
+ -- True if the variable is a shared variable.
+ -- Get/Set_Shared_Flag (Flag2)
+ --
+ -- Get/Set_Has_Identifier_List (Flag3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Get/Set_Is_Ref (Flag7)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_File_Declaration (Medium)
+ --
+ -- LRM08 6.4.2.5 File declarations
+ --
+ -- file_declaration ::=
+ -- FILE identifier_list : subtype_indication [ file_open_information ] ;
+ --
+ -- file_open_information ::=
+ -- [ OPEN file_open_kind_expression ] IS file_logical_name
+ --
+ -- file_logical_name ::= string_expression
+ --
+ -- LRM87
+ --
+ -- file_declaration ::=
+ -- FILE identifier : subtype_indication IS [ mode ] file_logical_name ;
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Subtype_Indication (Field5)
+ --
+ -- Get/Set_File_Logical_Name (Field6)
+ --
+ -- This is not used in vhdl 87.
+ -- Get/Set_File_Open_Kind (Field7)
+ --
+ -- This is used only in vhdl 87.
+ -- Get/Set_Mode (Odigit1)
+ --
+ -- Get/Set_Has_Identifier_List (Flag3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Get/Set_Is_Ref (Flag7)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+ --
+ -- Get/Set_Has_Mode (Flag8)
+
+ -- Iir_Kind_Element_Declaration (Short)
+ --
+ -- LRM08 5.3.3 Record types
+ --
+ -- element_declaration ::=
+ -- identifier_list : element_subtype_definition ;
+ --
+ -- identifier_list ::= identifier { , identifier }
+ --
+ -- element_subtype_definition ::= subtype_indication
+ --
+ -- The type can be deduced from the subtype indication, but this field is
+ -- present for uniformity (and speed).
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Return the position of the element in the record, starting from 0 for
+ -- the first record element, increasing by one for each successive element.
+ -- Get/Set_Element_Position (Field4)
+ --
+ -- Get/Set_Subtype_Indication (Field5)
+ --
+ -- Get/Set_Has_Identifier_List (Flag3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Is_Ref (Flag7)
+
+ -- Iir_Kind_Record_Element_Constraint (Short)
+ --
+ -- Record subtype definition which defines this constraint.
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Element_Declaration (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Return the position of the element in the record, starting from 0 for
+ -- the first record element, increasing by one for each successive element.
+ -- Get/Set_Element_Position (Field4)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Attribute_Declaration (Short)
+ --
+ -- LRM08 6.7 Attribute declarations
+ --
+ -- attribute_declaration ::=
+ -- ATTRIBUTE identifier : type_mark ;
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Type_Mark (Field4)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+
+ -- Iir_Kind_Group_Template_Declaration (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- List of entity class entry.
+ -- To handle `<>', the last element of the list can be an entity_class of
+ -- kind tok_box.
+ -- Get/Set_Entity_Class_Entry_Chain (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+
+ -- Iir_Kind_Group_Declaration (Short)
+ --
+ -- The declaration containing this type declaration.
+ -- Get/Set_Parent (Field0)
+ --
+ -- List of constituents.
+ -- Get/Set_Group_Constituent_List (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Group_Template_Name (Field5)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+
+ -- Iir_Kind_Psl_Declaration (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Psl_Declaration (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Valid only for property declaration.
+ -- Get/Set_PSL_Clock (Field7)
+ --
+ -- Valid only for property declaration without parameters.
+ -- Get/Set_PSL_NFA (Field8)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+
+ -- Iir_Kind_Terminal_Declaration (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Nature (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+
+ -- Iir_Kind_Free_Quantity_Declaration (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Default_Value (Field6)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Across_Quantity_Declaration (Medium)
+ -- Iir_Kind_Through_Quantity_Declaration (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Default_Value (Field6)
+ --
+ -- Get/Set_Tolerance (Field7)
+ --
+ -- Get/Set_Plus_Terminal (Field8)
+ --
+ -- Get/Set_Minus_Terminal (Field9)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Use_Flag (Flag6)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Use_Clause (Short)
+ --
+ -- LRM08 12.4 Use clauses
+ --
+ -- use_clause ::=
+ -- USE selected_name { , selected_name } ;
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Selected_Name (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Use_Clause_Chain (Field3)
+
+
+ -----------------------
+ -- type definitions --
+ -----------------------
+
+ -- For Iir_Kinds_Type_And_Subtype_Definition:
+ --
+ -- Type_Declarator:
+ -- Points to the type declaration or subtype declaration that has created
+ -- this definition. For some types, such as integer and floating point
+ -- types, both type and subtype points to the declaration.
+ -- However, there are cases where a type definition doesn't point to
+ -- a declarator: anonymous subtype created by index contraints, or
+ -- anonymous subtype created by an object declaration.
+ -- Note: a type definition cannot be anoynymous.
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- The base type.
+ -- For a subtype, it returns the type.
+ -- For a type, it must return the type itself.
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- The staticness of a type, according to LRM93 7.4.1.
+ -- Note: These types definition are always locally static:
+ -- enumeration, integer, floating.
+ -- However, their subtype are not necessary locally static.
+ -- Get/Set_Type_Staticness (State1)
+ --
+ -- The resolved flag of a subtype, according to LRM93 2.4
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- The signal_type flag of a type definition.
+ -- It is true when the type can be used for a signal.
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+
+ -- Iir_Kind_Enumeration_Type_Definition (Short)
+ --
+ -- Get the range of the type (This is just an ascending range from the
+ -- first literal to the last declared literal).
+ -- Get/Set_Range_Constraint (Field1)
+ --
+ -- Return the list of literals. This list is created when the node is
+ -- created.
+ -- Get/Set_Enumeration_Literal_List (Field2)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+ --
+ -- Get/Set_Only_Characters_Flag (Flag4)
+ --
+ -- Get/Set_Type_Staticness (State1)
+
+ -- Iir_Kind_Enumeration_Literal (Medium)
+ --
+ -- Nota: two literals of the same type are equal iff their value is the
+ -- same; in other words, there may be severals literals with the same
+ -- value.
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ -- Get/Set_Return_Type (Alias Field1)
+ --
+ -- Get/Set_Literal_Origin (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- The declaration of the literal. If LITERAL_ORIGIN is not set, then this
+ -- is the node itself, else this is the literal defined.
+ -- Get/Set_Enumeration_Decl (Field6)
+ --
+ -- The value of an enumeration literal is the position.
+ -- Get/Set_Enum_Pos (Field10)
+ --
+ -- Get/Set_Subprogram_Hash (Field11)
+ --
+ -- Get/Set_Seen_Flag (Flag1)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Never set to true, but possible when used as a prefix of an expanded
+ -- name in a overloaded subprogram.
+ -- Get/Set_Is_Within_Flag (Flag5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Physical_Type_Definition (Short)
+ --
+ -- Get/Set_Unit_Chain (Field1)
+ -- Get/Set_Primary_Unit (Alias Field1)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+ --
+ -- Get/Set_Type_Staticness (State1)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Unit_Declaration (Medium)
+ --
+ -- LRM08 5.2.4 Physical types
+ --
+ -- primary_unit_declaration ::= identifier ;
+ --
+ -- secondary_unit_declaration ::= identifier = physical_literal ;
+ --
+ -- physical_literal ::= [ abstract_literal ] /unit/_name
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- The Physical_Literal is the expression that appear in the sources, so
+ -- this is Null_Iir for a primary unit.
+ -- Get/Set_Physical_Literal (Field6)
+ --
+ -- The value of the unit, computed from the primary unit. This is always
+ -- a physical integer literal.
+ -- Get/Set_Physical_Unit_Value (Field7)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- LRM08 5.2 Scalar types
+ --
+ -- range_constraint ::= RANGE range
+ --
+ -- range ::=
+ -- range_attribute_name
+ -- | simple_expression direction simple_expression
+ --
+ -- direction ::= to | downto
+
+ -- Iir_Kind_Integer_Type_Definition (Short)
+ -- Iir_Kind_Floating_Type_Definition (Short)
+ --
+ -- The type declarator that has created this type.
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Type staticness is always locally.
+ -- Get/Set_Type_Staticness (State1)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+
+ -- Iir_Kind_Array_Type_Definition (Medium)
+ --
+ -- LRM08 5.3.2 Array types / LRM93 3.2.1
+ --
+ -- unbounded_array_definition ::=
+ -- ARRAY ( index_subtype_definition { , index_subtype_definition } )
+ -- OF element_subtype_indication
+ --
+ -- index_subtype_definition ::= type_mark RANGE <>
+ --
+ -- Get/Set_Element_Subtype (Field1)
+ --
+ -- Get/Set_Element_Subtype_Indication (Field2)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- This is a list of type marks.
+ -- Get/Set_Index_Subtype_Definition_List (Field6)
+ --
+ -- Same as the index_subtype_definition_list.
+ -- Get/Set_Index_Subtype_List (Field9)
+ --
+ -- Get/Set_Type_Staticness (State1)
+ --
+ -- Get/Set_Constraint_State (State2)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+ --
+ -- Get/Set_Index_Constraint_Flag (Flag4)
+
+ -- Iir_Kind_Record_Type_Definition (Short)
+ --
+ -- LRM08 5.3.3 Record types / LRM93 3.2.2 Record types
+ --
+ -- record_type_definition ::=
+ -- RECORD
+ -- element_declaration
+ -- { element_declaration }
+ -- END RECORD [ /record_type/_simple_name ]
+ --
+ -- Get/Set_Elements_Declaration_List (Field1)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Type_Staticness (State1)
+ --
+ -- Get/Set_Constraint_State (State2)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Access_Type_Definition (Short)
+ --
+ -- LRM08 5.4 Access types
+ --
+ -- access_type_definition ::= ACCESS subtype_indication
+ --
+ -- Get/Set_Designated_Type (Field1)
+ --
+ -- Get/Set_Designated_Subtype_Indication (Field5)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Type_Staticness (State1)
+
+ -- Iir_Kind_File_Type_Definition (Short)
+ --
+ -- Get/Set_File_Type_Mark (Field2)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- True if this is the std.textio.text file type, which may require special
+ -- handling.
+ -- Get/Set_Text_File_Flag (Flag4)
+ --
+ -- Get/Set_Type_Staticness (State1)
+
+ -- Iir_Kind_Incomplete_Type_Definition (Short)
+ -- Type definition for an incomplete type. This is created during the
+ -- semantisation of the incomplete type declaration.
+ --
+ -- Get/Set_Incomplete_Type_List (Field2)
+ --
+ -- Set to the incomplete type declaration when semantized, and set to the
+ -- complete type declaration when the latter one is semantized.
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Type_Staticness (State1)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+
+ -- Iir_Kind_Protected_Type_Declaration (Short)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Protected_Type_Body (Field2)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Type_Staticness (State1)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Protected_Type_Body (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Protected_Type_Declaration (Field4)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ --------------------------
+ -- subtype definitions --
+ --------------------------
+
+ -- LRM08 6.3 Subtype declarations
+ --
+ -- subtype_indication ::=
+ -- [ resolution_indication ] type_mark [ constraint ]
+ --
+ -- There is no uniq representation for a subtype indication. If there is
+ -- only a type_mark, then a subtype indication is represented by a name
+ -- (a simple name or an expanded name); otherwise it is represented by one
+ -- of the subtype definition node.
+ --
+ -- resolution_indication ::=
+ -- resolution_function_name | ( element_resolution )
+ --
+ -- element_resolution ::= array_element_resolution | record_resolution
+ --
+ -- If there is no constraint but a resolution function name, the subtype
+ -- indication is represented by a subtype_definition (which will be
+ -- replaced by the correct subtype definition). If there is an array
+ -- element resolution the subtype indication is represented by an array
+ -- subtype definition, and if there is a record resolution, it is
+ -- represented by a record subtype definition.
+ --
+ -- constraint ::=
+ -- range_constraint
+ -- | index_constraint
+ -- | array_constraint
+ -- | record_constraint
+ --
+ -- There is no node for constraint, it is directly represented by one of
+ -- the rhs.
+ --
+ -- element_constraint ::=
+ -- array_constraint
+ -- | record_constraint
+ --
+ -- Likewise, there is no node for element_constraint.
+ --
+ -- index_constraint ::= ( discrete_range { , discrete_range } )
+ --
+ -- An index_constraint is represented by an array_subtype_definition.
+ --
+ -- discrete_range ::= /discrete/_subtype_indication | range
+ --
+ -- array_constraint ::=
+ -- index_constraint [ array_element_constraint ]
+ -- | ( OPEN ) [ array_element_constraint ]
+ --
+ -- An array_constraint is also represented by an array_subtype_definition.
+ --
+ -- array_element_constraint ::= element_constraint
+ --
+ -- There is no node for array_element_constraint.
+ --
+ -- record_constraint ::=
+ -- ( record_element_constraint { , record_element_constraint } )
+ --
+ -- A record_constraint is represented by a record_subtype_definition.
+ --
+ -- record_element_constraint ::=
+ -- record_element_simple_name element_constraint
+ --
+ -- Represented by Record_Element_Constraint.
+
+ -- Iir_Kind_Enumeration_Subtype_Definition (Short)
+ -- Iir_Kind_Integer_Subtype_Definition (Short)
+ -- Iir_Kind_Physical_Subtype_Definition (Short)
+ --
+ -- Get/Set_Range_Constraint (Field1)
+ --
+ -- Get/Set_Subtype_Type_Mark (Field2)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Resolution_Indication (Field5)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+ --
+ -- Get/Set_Type_Staticness (State1)
+
+ -- Iir_Kind_Floating_Subtype_Definition (Medium)
+ --
+ -- Get/Set_Range_Constraint (Field1)
+ --
+ -- Get/Set_Subtype_Type_Mark (Field2)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Resolution_Indication (Field5)
+ --
+ -- Get/Set_Tolerance (Field7)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+ --
+ -- Get/Set_Type_Staticness (State1)
+
+ -- Iir_Kind_Access_Subtype_Definition (Short)
+ --
+ -- Get/Set_Designated_Type (Field1)
+ --
+ -- Get/Set_Subtype_Type_Mark (Field2)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Designated_Subtype_Indication (Field5)
+ --
+ -- Note: no resolution function for access subtype.
+ --
+ -- Get/Set_Type_Staticness (State1)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+
+ -- Iir_Kind_Array_Element_Resolution (Short)
+ --
+ -- LRM08 6.3 Subtype declarations
+ --
+ -- array_element_resolution ::= resolution_indication
+ --
+ -- Get/Set_Resolution_Indication (Field5)
+
+ -- Iir_Kind_Record_Resolution (Short)
+ --
+ -- LRM08 6.3 Subtype declarations
+ --
+ -- record_resolution ::=
+ -- record_element_resolution { , record_element_resolution }
+ --
+ -- Get/Set_Record_Element_Resolution_Chain (Field1)
+
+ -- Iir_Kind_Record_Element_Resolution (Short)
+ --
+ -- LRM08 6.3 Subtype declarations
+ --
+ -- record_element_resolution ::=
+ -- /record_element/_simple_name resolution_indication
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Resolution_Indication (Field5)
+
+ -- Iir_Kind_Record_Subtype_Definition (Medium)
+ --
+ -- Get/Set_Elements_Declaration_List (Field1)
+ --
+ -- Get/Set_Subtype_Type_Mark (Field2)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Resolution_Indication (Field5)
+ --
+ -- Get/Set_Tolerance (Field7)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+ --
+ -- Get/Set_Type_Staticness (State1)
+ --
+ -- Get/Set_Constraint_State (State2)
+
+ -- Iir_Kind_Array_Subtype_Definition (Medium)
+ --
+ -- Get/Set_Element_Subtype (Field1)
+ --
+ -- Get/Set_Subtype_Type_Mark (Field2)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Resolution_Indication (Field5)
+ --
+ -- The index_constraint list as it appears in the subtype indication (if
+ -- present). This is a list of subtype indication.
+ -- Get/Set_Index_Constraint_List (Field6)
+ --
+ -- Get/Set_Tolerance (Field7)
+ --
+ -- Get/Set_Array_Element_Constraint (Field8)
+ --
+ -- The type of the index. This is either the index_constraint list or the
+ -- index subtypes of the type_mark.
+ -- Get/Set_Index_Subtype_List (Field9)
+ --
+ -- Get/Set_Type_Staticness (State1)
+ --
+ -- Get/Set_Constraint_State (State2)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+ --
+ -- Get/Set_Index_Constraint_Flag (Flag4)
+
+ -- Iir_Kind_Range_Expression (Short)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Left_Limit (Field2)
+ --
+ -- Get/Set_Right_Limit (Field3)
+ --
+ -- Get/Set_Range_Origin (Field4)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Direction (State2)
+
+ -- Iir_Kind_Subtype_Definition (Medium)
+ -- Such a node is only created by parse and transformed into the correct
+ -- kind (enumeration_subtype, integer_subtype...) by sem.
+ --
+ -- Get/Set_Range_Constraint (Field1)
+ --
+ -- Get/Set_Subtype_Type_Mark (Field2)
+ --
+ -- Get/Set_Resolution_Indication (Field5)
+ --
+ -- Get/Set_Tolerance (Field7)
+
+ -------------------------
+ -- Nature definitions --
+ -------------------------
+
+ -- Iir_Kind_Scalar_Nature_Definition (Medium)
+ --
+ -- Get/Set_Reference (Field2)
+ --
+ -- The declarator that has created this nature type.
+ -- Get/Set_Nature_Declarator (Field3)
+ --
+ -- C-- Get/Set_Base_Type (Field4)
+ --
+ -- Type staticness is always locally.
+ -- C-- Get/Set_Type_Staticness (State1)
+ --
+ -- Get/Set_Across_Type (Field7)
+ --
+ -- Get/Set_Through_Type (Field8)
+
+ ----------------------------
+ -- concurrent statements --
+ ----------------------------
+
+ -- Iir_Kind_Concurrent_Conditional_Signal_Assignment (Medium)
+ -- Iir_Kind_Concurrent_Selected_Signal_Assignment (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Target (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Only for Iir_Kind_Concurrent_Selected_Signal_Assignment:
+ -- Get/Set_Expression (Field5)
+ --
+ -- Get/Set_Reject_Time_Expression (Field6)
+ --
+ -- Only for Iir_Kind_Concurrent_Conditional_Signal_Assignment:
+ -- Get/Set_Conditional_Waveform_Chain (Field7)
+ --
+ -- Only for Iir_Kind_Concurrent_Selected_Signal_Assignment:
+ -- Get/Set_Selected_Waveform_Chain (Field7)
+ --
+ -- If the assignment is guarded, then get_guard must return the
+ -- declaration of the signal guard, otherwise, null_iir.
+ -- If the guard signal decl is not known, as a kludge and only to mark this
+ -- assignment guarded, the guard can be this assignment.
+ -- Get/Set_Guard (Field8)
+ --
+ -- Get/Set_Delay_Mechanism (Field12)
+ --
+ -- Get/Set_Postponed_Flag (Flag3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- True if the target of the assignment is guarded
+ -- Get/Set_Guarded_Target_State (State3)
+
+ -- Iir_Kind_Sensitized_Process_Statement (Medium)
+ -- Iir_Kind_Process_Statement (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Sequential_Statement_Chain (Field5)
+ --
+ -- Only for Iir_Kind_Sensitized_Process_Statement:
+ -- Get/Set_Sensitivity_List (Field6)
+ --
+ -- Get/Set_Callees_List (Field7)
+ --
+ -- The concurrent statement at the origin of that process. This is
+ -- Null_Iir for a user process.
+ -- Get/Set_Process_Origin (Field8)
+ --
+ -- Get/Set_Wait_State (State1)
+ --
+ -- Get/Set_Seen_Flag (Flag1)
+ --
+ -- Get/Set_Passive_Flag (Flag2)
+ --
+ -- Get/Set_Postponed_Flag (Flag3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Is_Within_Flag (Flag5)
+ --
+ -- Get/Set_Has_Is (Flag7)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+ --
+ -- Get/Set_End_Has_Postponed (Flag10)
+
+ -- Iir_Kind_Concurrent_Assertion_Statement (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Assertion_Condition (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Severity_Expression (Field5)
+ --
+ -- Get/Set_Report_Expression (Field6)
+ --
+ -- Get/Set_Postponed_Flag (Flag3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Psl_Default_Clock (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Psl_Boolean (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+
+ -- Iir_Kind_Psl_Assert_Statement (Medium)
+ -- Iir_Kind_Psl_Cover_Statement (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Psl_Property (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Severity_Expression (Field5)
+ --
+ -- Get/Set_Report_Expression (Field6)
+ --
+ -- Get/Set_PSL_Clock (Field7)
+ --
+ -- Get/Set_PSL_NFA (Field8)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Component_Instantiation_Statement (Medium)
+ --
+ -- LRM08 11.7 Component instantiation statements
+ --
+ -- component_instantiation_statement ::=
+ -- instantiation_label :
+ -- instantiated_unit
+ -- [ generic_map_aspect ]
+ -- [ port_map_aspect ] ;
+ --
+ -- instantiated_unit ::=
+ -- [ COMPONENT ] component_name
+ -- | ENTITY entity_name [ ( architecture_identifier ) ]
+ -- | CONFIGURATION configuration_name
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Unit instantiated. This is a name, an entity_aspect_entity or an
+ -- entity_aspect_configuration.
+ -- Get/Set_Instantiated_Unit (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Default_Binding_Indication (Field5)
+ --
+ -- Get/Set_Generic_Map_Aspect_Chain (Field8)
+ --
+ -- Get/Set_Port_Map_Aspect_Chain (Field9)
+ --
+ -- Configuration:
+ -- In case of a configuration specification, the node is put into
+ -- default configuration. In the absence of a specification, the
+ -- default entity aspect, if any; if none, this field is null_iir.
+ -- Get/Set_Configuration_Specification (Field7)
+ --
+ -- During Sem and elaboration, the configuration field can be filled by
+ -- a component configuration declaration.
+ --
+ -- Configuration for this component.
+ -- FIXME: must be get/set_binding_indication.
+ -- Get/Set_Component_Configuration (Field6)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Block_Statement (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Concurrent_Statement_Chain (Field5)
+ --
+ -- Get/Set_Block_Block_Configuration (Field6)
+ --
+ -- Get/Set_Block_Header (Field7)
+ --
+ -- get/set_guard_decl is used for semantic analysis, in order to add
+ -- a signal declaration.
+ -- Get/Set_Guard_Decl (Field8)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Is_Within_Flag (Flag5)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Generate_Statement (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Declaration_Chain (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Concurrent_Statement_Chain (Field5)
+ --
+ -- The generation scheme.
+ -- A (boolean) expression for a conditionnal elaboration (if).
+ -- A (iterator) declaration for an iterative elaboration (for).
+ -- Get/Set_Generation_Scheme (Field6)
+ --
+ -- The block configuration for this statement.
+ -- Get/Set_Generate_Block_Configuration (Field7)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_End_Has_Reserved_Id (Flag8)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+ --
+ -- Get/Set_Has_Begin (Flag10)
+
+ -- Iir_Kind_Simple_Simultaneous_Statement (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Simultaneous_Left (Field5)
+ --
+ -- Get/Set_Simultaneous_Right (Field6)
+ --
+ -- Get/Set_Tolerance (Field7)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ ----------------------------
+ -- sequential statements --
+ ----------------------------
+
+ -- Iir_Kind_If_Statement (Medium)
+ -- Iir_Kind_Elsif (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- May be NULL only for an iir_kind_elsif node, and then means the else
+ -- clause.
+ -- Get/Set_Condition (Field1)
+ --
+ -- Only for Iir_Kind_If_Statement:
+ -- Get/Set_Chain (Field2)
+ --
+ -- Only for Iir_Kind_If_Statement:
+ -- Get/Set_Label (Field3)
+ --
+ -- Only for Iir_Kind_If_Statement:
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Only for Iir_Kind_If_Statement:
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Sequential_Statement_Chain (Field5)
+ --
+ -- Must be an Iir_kind_elsif node, or NULL for no more elsif clauses.
+ -- Get/Set_Else_Clause (Field6)
+ --
+ -- Only for Iir_Kind_If_Statement:
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- LRM08 10.10 Loop statement / LRM93 8.9
+ --
+ -- loop_statement ::=
+ -- [ loop_label : ]
+ -- [ iteration_scheme ] LOOP
+ -- sequence_of_statements
+ -- END LOOP [ loop_label ] ;
+ --
+ -- iteration_scheme ::=
+ -- WHILE condition
+ -- | FOR loop_parameter_specification
+ --
+ -- parameter_specification ::=
+ -- identifier IN discrete_range
+
+ -- Iir_Kind_For_Loop_Statement (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- The parameters specification is represented by an Iterator_Declaration.
+ -- Get/Set_Parameter_Specification (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Sequential_Statement_Chain (Field5)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_Is_Within_Flag (Flag5)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_While_Loop_Statement (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Condition (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Sequential_Statement_Chain (Field5)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Exit_Statement (Short)
+ -- Iir_Kind_Next_Statement (Short)
+ --
+ -- LRM08 10.11 Next statement
+ --
+ -- next_statement ::=
+ -- [ label : ] NEXT [ loop_label ] [ WHEN condition ] ;
+ --
+ -- LRM08 10.12 Exit statement
+ --
+ -- exit_statement ::=
+ -- [ label : ] exit [ loop_label ] [ when condition ] ;
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Condition (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Loop_Label (Field5)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Signal_Assignment_Statement (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Target (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- The waveform.
+ -- If the waveform_chain is null_iir, then the signal assignment is a
+ -- disconnection statement, ie TARGET <= null_iir after disconection_time,
+ -- where disconnection_time is specified by a disconnection specification.
+ -- Get/Set_Waveform_Chain (Field5)
+ --
+ -- Get/Set_Reject_Time_Expression (Field6)
+ --
+ -- Get/Set_Delay_Mechanism (Field12)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- True if the target of the assignment is guarded
+ -- Get/Set_Guarded_Target_State (State3)
+
+ -- Iir_Kind_Variable_Assignment_Statement (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Target (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Expression (Field5)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Assertion_Statement (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Assertion_Condition (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Severity_Expression (Field5)
+ --
+ -- Get/Set_Report_Expression (Field6)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Report_Statement (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Severity_Expression (Field5)
+ --
+ -- Get/Set_Report_Expression (Field6)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Wait_Statement (Medium)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Timeout_Clause (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Condition_Clause (Field5)
+ --
+ -- Get/Set_Sensitivity_List (Field6)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Return_Statement (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Type of the return value of the function. This is a copy of
+ -- return_type.
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Expression (Field5)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Case_Statement (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Chain is compose of Iir_Kind_Choice_By_XXX.
+ -- Get/Set_Case_Statement_Alternative_Chain (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Expression (Field5)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+ --
+ -- Get/Set_End_Has_Identifier (Flag9)
+
+ -- Iir_Kind_Procedure_Call_Statement (Short)
+ -- Iir_Kind_Concurrent_Procedure_Call_Statement (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Procedure_Call (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Only for Iir_Kind_Concurrent_Procedure_Call_Statement:
+ -- Get/Set_Postponed_Flag (Flag3)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ -- Iir_Kind_Procedure_Call (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Parameter_Association_Chain (Field2)
+ --
+ -- Procedure declaration corresponding to the procedure to call.
+ -- Get/Set_Implementation (Field3)
+ --
+ -- Get/Set_Method_Object (Field4)
+
+ -- Iir_Kind_Null_Statement (Short)
+ --
+ -- Get/Set_Parent (Field0)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Get/Set_Label (Field3)
+ -- Get/Set_Identifier (Alias Field3)
+ --
+ -- Get/Set_Attribute_Value_Chain (Field4)
+ --
+ -- Get/Set_Visible_Flag (Flag4)
+
+ ----------------
+ -- operators --
+ ----------------
+
+ -- Iir_Kinds_Monadic_Operator (Short)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Operand (Field2)
+ --
+ -- Function declaration corresponding to the function to call.
+ -- Get/Set_Implementation (Field3)
+ --
+ -- Expr_staticness is defined by §7.4
+ -- Get/Set_Expr_Staticness (State1)
+
+ -- Iir_Kinds_Dyadic_Operator (Short)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Left and Right operands.
+ -- Get/Set_Left (Field2)
+ --
+ -- Function declaration corresponding to the function to call.
+ -- Get/Set_Implementation (Field3)
+ --
+ -- Get/Set_Right (Field4)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+
+ -- Iir_Kind_Function_Call (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Parameter_Association_Chain (Field2)
+ --
+ -- Function declaration corresponding to the function to call.
+ -- Get/Set_Implementation (Field3)
+ --
+ -- Get/Set_Method_Object (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Aggregate (Short)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Aggregate_Info (Field2)
+ --
+ -- Get/Set_Association_Choices_Chain (Field4)
+ --
+ -- Same as Type, but marked as property of that node.
+ -- Get/Set_Literal_Subtype (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Value_Staticness (State2)
+
+ -- Iir_Kind_Aggregate_Info (Short)
+ --
+ -- Get info for the next dimension. NULL_IIR terminated.
+ -- Get/Set_Sub_Aggregate_Info (Field1)
+ --
+ -- For array aggregate only:
+ -- If TRUE, the choices are not locally static.
+ -- This flag is only valid when the array aggregate is constrained, ie
+ -- has no 'others' choice.
+ -- Get/Set_Aggr_Dynamic_Flag (Flag3)
+ --
+ -- If TRUE, the aggregate is named, else it is positionnal.
+ -- Get/Set_Aggr_Named_Flag (Flag4)
+ --
+ -- The following three fields are used to check bounds of an array
+ -- aggregate.
+ -- For named aggregate, low and high bounds are computed, for positionnal
+ -- aggregate, the (minimum) number of elements is computed.
+ -- Note there may be elements beyond the bounds, due to other choice.
+ -- These fields may apply for the aggregate or for the aggregate and its
+ -- brothers if the node is for a sub-aggregate.
+ --
+ -- The low and high index choice, if any.
+ -- Get/Set_Aggr_Low_Limit (Field2)
+ --
+ -- Get/Set_Aggr_High_Limit (Field3)
+ --
+ -- The minimum number of elements, if any. This is a minimax.
+ -- Get/Set_Aggr_Min_Length (Field4)
+ --
+ -- True if the choice list has an 'others' choice.
+ -- Get/Set_Aggr_Others_Flag (Flag2)
+
+ -- Iir_Kind_Parenthesis_Expression (Short)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Expression (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+
+ -- Iir_Kind_Qualified_Expression (Short)
+ --
+ -- LRM08 9.3.5 Qualified expressions
+ --
+ -- qualified_expression ::=
+ -- type_mark ' ( expression )
+ -- | type_mark ' aggregate
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Type_Mark (Field4)
+ --
+ -- Get/Set_Expression (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+
+ -- Iir_Kind_Type_Conversion (Short)
+ --
+ -- LRM08 9.3.6 Type conversions
+ --
+ -- type_conversion ::= type_mark ( expression )
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- If the type mark denotes an unconstrained array and the expression is
+ -- locally static, the result should be locally static according to vhdl93
+ -- (which is not clear on that point). As a subtype is created, it is
+ -- referenced by this field.
+ -- Get/Set_Type_Conversion_Subtype (Field3)
+ --
+ -- Get/Set_Type_Mark (Field4)
+ --
+ -- Get/Set_Expression (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+
+ -- Iir_Kind_Allocator_By_Expression (Short)
+ -- Iir_Kind_Allocator_By_Subtype (Short)
+ --
+ -- LRM08 9.3.7 Allocators
+ --
+ -- allocator ::=
+ -- NEW subtype_indication
+ -- | NEW qualified_expression
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- To ease analysis: set to the designated type (either the type of the
+ -- expression or the subtype)
+ -- Get/Set_Allocator_Designated_Type (Field2)
+ --
+ -- Only for Iir_Kind_Allocator_By_Expression:
+ -- Contains the expression for a by expression allocator.
+ -- Get/Set_Expression (Field5)
+ --
+ -- Only for Iir_Kind_Allocator_By_Subtype:
+ -- Contains the subtype indication for a by subtype allocator.
+ -- Get/Set_Subtype_Indication (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+
+ ------------
+ -- Names --
+ ------------
+
+ -- Iir_Kind_Simple_Name (Short)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Alias_Declaration (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Named_Entity (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Character_Literal (Short)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Alias_Declaration (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Named_Entity (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Operator_Symbol (Short)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Alias_Declaration (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Named_Entity (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+
+ -- Iir_Kind_Selected_Name (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Alias_Declaration (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Named_Entity (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Selected_By_All_Name (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Named_Entity (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+
+ -- Iir_Kind_Indexed_Name (Short)
+ -- Select the element designed with the INDEX_LIST from array PREFIX.
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Index_List (Field2)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Slice_Name (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Suffix (Field2)
+ --
+ -- Get/Set_Slice_Subtype (Field3)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Parenthesis_Name (Short)
+ -- Created by the parser, and mutated into the correct iir node: it can be
+ -- either a function call, an indexed array, a type conversion or a slice
+ -- name.
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Always returns null_iir.
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Association_Chain (Field2)
+ --
+ -- Get/Set_Named_Entity (Field4)
+
+ -- Iir_Kind_Selected_Element (Short)
+ -- A record element selection. This corresponds to a reffined selected
+ -- names. The production doesn't exist in the VHDL grammar.
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Selected_Element (Field2)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Implicit_Dereference (Short)
+ -- Iir_Kind_Dereference (Short)
+ -- An implicit access dereference.
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -----------------
+ -- Attributes --
+ -----------------
+
+ -- Iir_Kind_Attribute_Name (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Attribute_Signature (Field2)
+ --
+ -- Get/Set_Identifier (Field3)
+ --
+ -- Get/Set_Named_Entity (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Base_Attribute (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+
+ -- Iir_Kind_Left_Type_Attribute (Short)
+ -- Iir_Kind_Right_Type_Attribute (Short)
+ -- Iir_Kind_High_Type_Attribute (Short)
+ -- Iir_Kind_Low_Type_Attribute (Short)
+ -- Iir_Kind_Ascending_Type_Attribute (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Range_Array_Attribute (Short)
+ -- Iir_Kind_Reverse_Range_Array_Attribute (Short)
+ -- Iir_Kind_Left_Array_Attribute (Short)
+ -- Iir_Kind_Right_Array_Attribute (Short)
+ -- Iir_Kind_High_Array_Attribute (Short)
+ -- Iir_Kind_Low_Array_Attribute (Short)
+ -- Iir_Kind_Ascending_Array_Attribute (Short)
+ -- Iir_Kind_Length_Array_Attribute (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Index_Subtype (Field2)
+ --
+ -- Get/Set_Parameter (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Stable_Attribute (Short)
+ -- Iir_Kind_Delayed_Attribute (Short)
+ -- Iir_Kind_Quiet_Attribute (Short)
+ -- Iir_Kind_Transaction_Attribute (Short)
+ -- (Iir_Kinds_Signal_Attribute)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Chain (Field2)
+ --
+ -- Not used by Iir_Kind_Transaction_Attribute
+ -- Get/Set_Parameter (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Has_Active_Flag (Flag2)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Event_Attribute (Short)
+ -- Iir_Kind_Last_Event_Attribute (Short)
+ -- Iir_Kind_Last_Value_Attribute (Short)
+ -- Iir_Kind_Active_Attribute (Short)
+ -- Iir_Kind_Last_Active_Attribute (Short)
+ -- Iir_Kind_Driving_Attribute (Short)
+ -- Iir_Kind_Driving_Value_Attribute (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Pos_Attribute (Short)
+ -- Iir_Kind_Val_Attribute (Short)
+ -- Iir_Kind_Succ_Attribute (Short)
+ -- Iir_Kind_Pred_Attribute (Short)
+ -- Iir_Kind_Leftof_Attribute (Short)
+ -- Iir_Kind_Rightof_Attribute (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Parameter (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Image_Attribute (Short)
+ -- Iir_Kind_Value_Attribute (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Parameter (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Simple_Name_Attribute (Short)
+ -- Iir_Kind_Instance_Name_Attribute (Short)
+ -- Iir_Kind_Path_Name_Attribute (Short)
+ --
+ -- Get/Set_Prefix (Field0)
+ --
+ -- Get/Set_Type (Field1)
+ --
+ -- Only for Iir_Kind_Simple_Name_Attribute:
+ -- Get/Set_Simple_Name_Identifier (Field3)
+ --
+ -- Only for Iir_Kind_Simple_Name_Attribute:
+ -- Get/Set_Simple_Name_Subtype (Field4)
+ --
+ -- Get/Set_Base_Name (Field5)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Name_Staticness (State2)
+
+ -- Iir_Kind_Behavior_Attribute (Short)
+ -- Iir_Kind_Structure_Attribute (Short)
+ -- FIXME: to describe (Short)
+
+ -- Iir_Kind_Error (Short)
+ -- Can be used instead of an expression or a type.
+ -- Get/Set_Type (Field1)
+ --
+ -- Get/Set_Error_Origin (Field2)
+ --
+ -- Get/Set_Type_Declarator (Field3)
+ --
+ -- Get/Set_Base_Type (Field4)
+ --
+ -- Get/Set_Expr_Staticness (State1)
+ --
+ -- Get/Set_Type_Staticness (Alias State1)
+ --
+ -- Get/Set_Resolved_Flag (Flag1)
+ --
+ -- Get/Set_Signal_Type_Flag (Flag2)
+ --
+ -- Get/Set_Has_Signal_Flag (Flag3)
+
+ -- Iir_Kind_Unused (Short)
+
+ -- End of Iir_Kind.
+
+
+ type Iir_Kind is
+ (
+ Iir_Kind_Unused,
+ Iir_Kind_Error,
+
+ Iir_Kind_Design_File,
+ Iir_Kind_Design_Unit,
+ Iir_Kind_Library_Clause,
+ Iir_Kind_Use_Clause,
+
+ -- Literals.
+ Iir_Kind_Integer_Literal,
+ Iir_Kind_Floating_Point_Literal,
+ Iir_Kind_Null_Literal,
+ Iir_Kind_String_Literal,
+ Iir_Kind_Physical_Int_Literal,
+ Iir_Kind_Physical_Fp_Literal,
+ Iir_Kind_Bit_String_Literal,
+ Iir_Kind_Simple_Aggregate,
+ Iir_Kind_Overflow_Literal,
+
+ -- Tuple,
+ Iir_Kind_Waveform_Element,
+ Iir_Kind_Conditional_Waveform,
+ Iir_Kind_Association_Element_By_Expression,
+ Iir_Kind_Association_Element_By_Individual,
+ Iir_Kind_Association_Element_Open,
+ Iir_Kind_Association_Element_Package,
+ Iir_Kind_Choice_By_Others,
+ Iir_Kind_Choice_By_Expression,
+ Iir_Kind_Choice_By_Range,
+ Iir_Kind_Choice_By_None,
+ Iir_Kind_Choice_By_Name,
+ Iir_Kind_Entity_Aspect_Entity,
+ Iir_Kind_Entity_Aspect_Configuration,
+ Iir_Kind_Entity_Aspect_Open,
+ Iir_Kind_Block_Configuration,
+ Iir_Kind_Block_Header,
+ Iir_Kind_Component_Configuration,
+ Iir_Kind_Binding_Indication,
+ Iir_Kind_Entity_Class,
+ Iir_Kind_Attribute_Value,
+ Iir_Kind_Signature,
+ Iir_Kind_Aggregate_Info,
+ Iir_Kind_Procedure_Call,
+ Iir_Kind_Record_Element_Constraint,
+ Iir_Kind_Array_Element_Resolution,
+ Iir_Kind_Record_Resolution,
+ Iir_Kind_Record_Element_Resolution,
+
+ Iir_Kind_Attribute_Specification,
+ Iir_Kind_Disconnection_Specification,
+ Iir_Kind_Configuration_Specification,
+
+ -- Type definitions.
+ -- iir_kinds_type_and_subtype_definition
+ -- kinds: disc: discrete, st: subtype.
+ Iir_Kind_Access_Type_Definition,
+ Iir_Kind_Incomplete_Type_Definition,
+ Iir_Kind_File_Type_Definition,
+ Iir_Kind_Protected_Type_Declaration,
+ Iir_Kind_Record_Type_Definition, -- composite
+ Iir_Kind_Array_Type_Definition, -- composite, array
+ Iir_Kind_Array_Subtype_Definition, -- composite, array, st
+ Iir_Kind_Record_Subtype_Definition, -- composite, st
+ Iir_Kind_Access_Subtype_Definition, -- st
+ Iir_Kind_Physical_Subtype_Definition, -- scalar, st, rng
+ Iir_Kind_Floating_Subtype_Definition, -- scalar, st, rng
+ Iir_Kind_Integer_Subtype_Definition, -- scalar, disc, st, rng
+ Iir_Kind_Enumeration_Subtype_Definition, -- scalar, disc, st, rng
+ Iir_Kind_Enumeration_Type_Definition, -- scalar, disc, rng
+ Iir_Kind_Integer_Type_Definition, -- scalar, disc
+ Iir_Kind_Floating_Type_Definition, -- scalar
+ Iir_Kind_Physical_Type_Definition, -- scalar
+ Iir_Kind_Range_Expression,
+ Iir_Kind_Protected_Type_Body,
+ Iir_Kind_Subtype_Definition, -- temporary (must not appear after sem).
+
+ -- Nature definition
+ Iir_Kind_Scalar_Nature_Definition,
+
+ -- Lists.
+ Iir_Kind_Overload_List, -- used internally by sem_expr.
+
+ -- Declarations.
+ Iir_Kind_Type_Declaration,
+ Iir_Kind_Anonymous_Type_Declaration,
+ Iir_Kind_Subtype_Declaration,
+ Iir_Kind_Nature_Declaration,
+ Iir_Kind_Subnature_Declaration,
+ Iir_Kind_Package_Declaration,
+ Iir_Kind_Package_Instantiation_Declaration,
+ Iir_Kind_Package_Body,
+ Iir_Kind_Configuration_Declaration,
+ Iir_Kind_Entity_Declaration,
+ Iir_Kind_Architecture_Body,
+ Iir_Kind_Package_Header,
+ Iir_Kind_Unit_Declaration,
+ Iir_Kind_Library_Declaration,
+ Iir_Kind_Component_Declaration,
+ Iir_Kind_Attribute_Declaration,
+ Iir_Kind_Group_Template_Declaration,
+ Iir_Kind_Group_Declaration,
+ Iir_Kind_Element_Declaration,
+ Iir_Kind_Non_Object_Alias_Declaration,
+
+ Iir_Kind_Psl_Declaration,
+ Iir_Kind_Terminal_Declaration,
+ Iir_Kind_Free_Quantity_Declaration,
+ Iir_Kind_Across_Quantity_Declaration,
+ Iir_Kind_Through_Quantity_Declaration,
+
+ Iir_Kind_Enumeration_Literal,
+ Iir_Kind_Function_Declaration, -- Subprg, Func
+ Iir_Kind_Implicit_Function_Declaration, -- Subprg, Func, Imp_Subprg
+ Iir_Kind_Implicit_Procedure_Declaration, -- Subprg, Proc, Imp_Subprg
+ Iir_Kind_Procedure_Declaration, -- Subprg, Proc
+ Iir_Kind_Function_Body,
+ Iir_Kind_Procedure_Body,
+
+ Iir_Kind_Object_Alias_Declaration, -- object
+ Iir_Kind_File_Declaration, -- object
+ Iir_Kind_Guard_Signal_Declaration, -- object
+ Iir_Kind_Signal_Declaration, -- object
+ Iir_Kind_Variable_Declaration, -- object
+ Iir_Kind_Constant_Declaration, -- object
+ Iir_Kind_Iterator_Declaration, -- object
+ Iir_Kind_Interface_Constant_Declaration, -- object, interface
+ Iir_Kind_Interface_Variable_Declaration, -- object, interface
+ Iir_Kind_Interface_Signal_Declaration, -- object, interface
+ Iir_Kind_Interface_File_Declaration, -- object, interface
+ Iir_Kind_Interface_Package_Declaration,
+
+ -- Expressions.
+ Iir_Kind_Identity_Operator,
+ Iir_Kind_Negation_Operator,
+ Iir_Kind_Absolute_Operator,
+ Iir_Kind_Not_Operator,
+ Iir_Kind_Condition_Operator,
+ Iir_Kind_Reduction_And_Operator,
+ Iir_Kind_Reduction_Or_Operator,
+ Iir_Kind_Reduction_Nand_Operator,
+ Iir_Kind_Reduction_Nor_Operator,
+ Iir_Kind_Reduction_Xor_Operator,
+ Iir_Kind_Reduction_Xnor_Operator,
+ Iir_Kind_And_Operator,
+ Iir_Kind_Or_Operator,
+ Iir_Kind_Nand_Operator,
+ Iir_Kind_Nor_Operator,
+ Iir_Kind_Xor_Operator,
+ Iir_Kind_Xnor_Operator,
+ Iir_Kind_Equality_Operator,
+ Iir_Kind_Inequality_Operator,
+ Iir_Kind_Less_Than_Operator,
+ Iir_Kind_Less_Than_Or_Equal_Operator,
+ Iir_Kind_Greater_Than_Operator,
+ Iir_Kind_Greater_Than_Or_Equal_Operator,
+ Iir_Kind_Match_Equality_Operator,
+ Iir_Kind_Match_Inequality_Operator,
+ Iir_Kind_Match_Less_Than_Operator,
+ Iir_Kind_Match_Less_Than_Or_Equal_Operator,
+ Iir_Kind_Match_Greater_Than_Operator,
+ Iir_Kind_Match_Greater_Than_Or_Equal_Operator,
+ Iir_Kind_Sll_Operator,
+ Iir_Kind_Sla_Operator,
+ Iir_Kind_Srl_Operator,
+ Iir_Kind_Sra_Operator,
+ Iir_Kind_Rol_Operator,
+ Iir_Kind_Ror_Operator,
+ Iir_Kind_Addition_Operator,
+ Iir_Kind_Substraction_Operator,
+ Iir_Kind_Concatenation_Operator,
+ Iir_Kind_Multiplication_Operator,
+ Iir_Kind_Division_Operator,
+ Iir_Kind_Modulus_Operator,
+ Iir_Kind_Remainder_Operator,
+ Iir_Kind_Exponentiation_Operator,
+ Iir_Kind_Function_Call,
+ Iir_Kind_Aggregate,
+ Iir_Kind_Parenthesis_Expression,
+ Iir_Kind_Qualified_Expression,
+ Iir_Kind_Type_Conversion,
+ Iir_Kind_Allocator_By_Expression,
+ Iir_Kind_Allocator_By_Subtype,
+ Iir_Kind_Selected_Element,
+ Iir_Kind_Dereference,
+ Iir_Kind_Implicit_Dereference,
+ Iir_Kind_Slice_Name,
+ Iir_Kind_Indexed_Name,
+ Iir_Kind_Psl_Expression,
+
+ -- Concurrent statements.
+ Iir_Kind_Sensitized_Process_Statement,
+ Iir_Kind_Process_Statement,
+ Iir_Kind_Concurrent_Conditional_Signal_Assignment,
+ Iir_Kind_Concurrent_Selected_Signal_Assignment,
+ Iir_Kind_Concurrent_Assertion_Statement,
+ Iir_Kind_Psl_Default_Clock,
+ Iir_Kind_Psl_Assert_Statement,
+ Iir_Kind_Psl_Cover_Statement,
+ Iir_Kind_Concurrent_Procedure_Call_Statement,
+ Iir_Kind_Block_Statement,
+ Iir_Kind_Generate_Statement,
+ Iir_Kind_Component_Instantiation_Statement,
+
+ Iir_Kind_Simple_Simultaneous_Statement,
+
+ -- Iir_Kind_Sequential_Statement
+ Iir_Kind_Signal_Assignment_Statement,
+ Iir_Kind_Null_Statement,
+ Iir_Kind_Assertion_Statement,
+ Iir_Kind_Report_Statement,
+ Iir_Kind_Wait_Statement,
+ Iir_Kind_Variable_Assignment_Statement,
+ Iir_Kind_Return_Statement,
+ Iir_Kind_For_Loop_Statement,
+ Iir_Kind_While_Loop_Statement,
+ Iir_Kind_Next_Statement,
+ Iir_Kind_Exit_Statement,
+ Iir_Kind_Case_Statement,
+ Iir_Kind_Procedure_Call_Statement,
+ Iir_Kind_If_Statement,
+ Iir_Kind_Elsif,
+
+ -- Names
+ Iir_Kind_Character_Literal, -- denoting_name
+ Iir_Kind_Simple_Name, -- denoting_name
+ Iir_Kind_Selected_Name, -- denoting_name
+ Iir_Kind_Operator_Symbol, -- denoting_name
+
+ Iir_Kind_Selected_By_All_Name,
+ Iir_Kind_Parenthesis_Name,
+
+ -- Attributes
+ Iir_Kind_Base_Attribute,
+ Iir_Kind_Left_Type_Attribute, -- type_attribute
+ Iir_Kind_Right_Type_Attribute, -- type_attribute
+ Iir_Kind_High_Type_Attribute, -- type_attribute
+ Iir_Kind_Low_Type_Attribute, -- type_attribute
+ Iir_Kind_Ascending_Type_Attribute, -- type_attribute
+ Iir_Kind_Image_Attribute,
+ Iir_Kind_Value_Attribute,
+ Iir_Kind_Pos_Attribute, -- scalar_type_attribute
+ Iir_Kind_Val_Attribute, -- scalar_type_attribute
+ Iir_Kind_Succ_Attribute, -- scalar_type_attribute
+ Iir_Kind_Pred_Attribute, -- scalar_type_attribute
+ Iir_Kind_Leftof_Attribute, -- scalar_type_attribute
+ Iir_Kind_Rightof_Attribute, -- scalar_type_attribute
+ Iir_Kind_Delayed_Attribute, -- signal_attribute
+ Iir_Kind_Stable_Attribute, -- signal_attribute
+ Iir_Kind_Quiet_Attribute, -- signal_attribute
+ Iir_Kind_Transaction_Attribute, -- signal_attribute
+ Iir_Kind_Event_Attribute, -- signal_value_attribute
+ Iir_Kind_Active_Attribute, -- signal_value_attribute
+ Iir_Kind_Last_Event_Attribute, -- signal_value_attribute
+ Iir_Kind_Last_Active_Attribute, -- signal_value_attribute
+ Iir_Kind_Last_Value_Attribute, -- signal_value_attribute
+ Iir_Kind_Driving_Attribute, -- signal_value_attribute
+ Iir_Kind_Driving_Value_Attribute, -- signal_value_attribute
+ Iir_Kind_Behavior_Attribute,
+ Iir_Kind_Structure_Attribute,
+ Iir_Kind_Simple_Name_Attribute,
+ Iir_Kind_Instance_Name_Attribute,
+ Iir_Kind_Path_Name_Attribute,
+ Iir_Kind_Left_Array_Attribute, -- array_attribute
+ Iir_Kind_Right_Array_Attribute, -- array_attribute
+ Iir_Kind_High_Array_Attribute, -- array_attribute
+ Iir_Kind_Low_Array_Attribute, -- array_attribute
+ Iir_Kind_Length_Array_Attribute, -- array_attribute
+ Iir_Kind_Ascending_Array_Attribute, -- array_attribute
+ Iir_Kind_Range_Array_Attribute, -- array_attribute
+ Iir_Kind_Reverse_Range_Array_Attribute, -- array_attribute
+
+ Iir_Kind_Attribute_Name
+ );
+
+ type Iir_Signal_Kind is
+ (
+ Iir_No_Signal_Kind,
+ Iir_Register_Kind,
+ Iir_Bus_Kind
+ );
+
+ -- If the order of elements in IIR_MODE is modified, also modify the
+ -- order in GRT (types and rtis).
+ type Iir_Mode is
+ (
+ Iir_Unknown_Mode,
+ Iir_Linkage_Mode,
+ Iir_Buffer_Mode,
+ Iir_Out_Mode,
+ Iir_Inout_Mode,
+ Iir_In_Mode
+ );
+
+ subtype Iir_In_Modes is Iir_Mode range Iir_Inout_Mode .. Iir_In_Mode;
+ subtype Iir_Out_Modes is Iir_Mode range Iir_Out_Mode .. Iir_Inout_Mode;
+
+ type Iir_Delay_Mechanism is (Iir_Inertial_Delay, Iir_Transport_Delay);
+
+ type Iir_Direction is (Iir_To, Iir_Downto);
+
+ -- Iir_Lexical_Layout_type describe the lexical token used to describe
+ -- an interface declaration. This has no semantics meaning, but it is
+ -- necessary to keep how lexically an interface was declared due to
+ -- LRM93 2.7 (conformance rules).
+ -- To keep this simple, the layout is stored as a bit-string.
+ -- Fields are:
+ -- Has_type: set if the interface is the last of a list.
+ -- has_mode: set if mode is explicit
+ -- has_class: set if class (constant, signal, variable or file) is explicit
+ --
+ -- Exemple:
+ -- procedure P ( A, B: integer;
+ -- constant C: in bit;
+ -- D: inout bit;
+ -- variable E: bit;
+ -- F, G: in bit;
+ -- constant H, I: bit;
+ -- constant J, K: in bit);
+ -- A:
+ -- B: has_type
+ -- C, has_class, has_mode, has_type
+ -- D: has_mode, has_type
+ -- E, has_class, has_type
+ -- F: has_mode
+ -- G: has_mode, has_type
+ -- H: has_class
+ -- I: has_class, has_type
+ -- J: has_class, has_mode
+ -- K: has_class, has_mode, has_type
+ type Iir_Lexical_Layout_Type is mod 2 ** 3;
+ Iir_Lexical_Has_Mode : constant Iir_Lexical_Layout_Type := 2 ** 0;
+ Iir_Lexical_Has_Class : constant Iir_Lexical_Layout_Type := 2 ** 1;
+ Iir_Lexical_Has_Type : constant Iir_Lexical_Layout_Type := 2 ** 2;
+
+ -- List of predefined operators and functions.
+ type Iir_Predefined_Functions is
+ (
+ Iir_Predefined_Error,
+
+ -- Predefined operators for BOOLEAN type.
+ Iir_Predefined_Boolean_And,
+ Iir_Predefined_Boolean_Or,
+ Iir_Predefined_Boolean_Nand,
+ Iir_Predefined_Boolean_Nor,
+ Iir_Predefined_Boolean_Xor,
+ Iir_Predefined_Boolean_Xnor,
+ Iir_Predefined_Boolean_Not,
+
+ Iir_Predefined_Boolean_Rising_Edge,
+ Iir_Predefined_Boolean_Falling_Edge,
+
+ -- Predefined operators for any enumeration type.
+ Iir_Predefined_Enum_Equality,
+ Iir_Predefined_Enum_Inequality,
+ Iir_Predefined_Enum_Less,
+ Iir_Predefined_Enum_Less_Equal,
+ Iir_Predefined_Enum_Greater,
+ Iir_Predefined_Enum_Greater_Equal,
+
+ Iir_Predefined_Enum_Minimum,
+ Iir_Predefined_Enum_Maximum,
+ Iir_Predefined_Enum_To_String,
+
+ -- Predefined operators for BIT type.
+ Iir_Predefined_Bit_And,
+ Iir_Predefined_Bit_Or,
+ Iir_Predefined_Bit_Nand,
+ Iir_Predefined_Bit_Nor,
+ Iir_Predefined_Bit_Xor,
+ Iir_Predefined_Bit_Xnor,
+ Iir_Predefined_Bit_Not,
+
+ Iir_Predefined_Bit_Match_Equality,
+ Iir_Predefined_Bit_Match_Inequality,
+ Iir_Predefined_Bit_Match_Less,
+ Iir_Predefined_Bit_Match_Less_Equal,
+ Iir_Predefined_Bit_Match_Greater,
+ Iir_Predefined_Bit_Match_Greater_Equal,
+
+ Iir_Predefined_Bit_Condition,
+
+ Iir_Predefined_Bit_Rising_Edge,
+ Iir_Predefined_Bit_Falling_Edge,
+
+ -- Predefined operators for any integer type.
+ Iir_Predefined_Integer_Equality,
+ Iir_Predefined_Integer_Inequality,
+ Iir_Predefined_Integer_Less,
+ Iir_Predefined_Integer_Less_Equal,
+ Iir_Predefined_Integer_Greater,
+ Iir_Predefined_Integer_Greater_Equal,
+
+ Iir_Predefined_Integer_Identity,
+ Iir_Predefined_Integer_Negation,
+ Iir_Predefined_Integer_Absolute,
+
+ Iir_Predefined_Integer_Plus,
+ Iir_Predefined_Integer_Minus,
+ Iir_Predefined_Integer_Mul,
+ Iir_Predefined_Integer_Div,
+ Iir_Predefined_Integer_Mod,
+ Iir_Predefined_Integer_Rem,
+
+ Iir_Predefined_Integer_Exp,
+
+ Iir_Predefined_Integer_Minimum,
+ Iir_Predefined_Integer_Maximum,
+ Iir_Predefined_Integer_To_String,
+
+ -- Predefined operators for any floating type.
+ Iir_Predefined_Floating_Equality,
+ Iir_Predefined_Floating_Inequality,
+ Iir_Predefined_Floating_Less,
+ Iir_Predefined_Floating_Less_Equal,
+ Iir_Predefined_Floating_Greater,
+ Iir_Predefined_Floating_Greater_Equal,
+
+ Iir_Predefined_Floating_Identity,
+ Iir_Predefined_Floating_Negation,
+ Iir_Predefined_Floating_Absolute,
+
+ Iir_Predefined_Floating_Plus,
+ Iir_Predefined_Floating_Minus,
+ Iir_Predefined_Floating_Mul,
+ Iir_Predefined_Floating_Div,
+
+ Iir_Predefined_Floating_Exp,
+
+ Iir_Predefined_Floating_Minimum,
+ Iir_Predefined_Floating_Maximum,
+ Iir_Predefined_Floating_To_String,
+
+ Iir_Predefined_Real_To_String_Digits,
+ Iir_Predefined_Real_To_String_Format,
+
+ -- Predefined operator for universal types.
+ Iir_Predefined_Universal_R_I_Mul,
+ Iir_Predefined_Universal_I_R_Mul,
+ Iir_Predefined_Universal_R_I_Div,
+
+ -- Predefined operators for physical types.
+ Iir_Predefined_Physical_Equality,
+ Iir_Predefined_Physical_Inequality,
+ Iir_Predefined_Physical_Less,
+ Iir_Predefined_Physical_Less_Equal,
+ Iir_Predefined_Physical_Greater,
+ Iir_Predefined_Physical_Greater_Equal,
+
+ Iir_Predefined_Physical_Identity,
+ Iir_Predefined_Physical_Negation,
+ Iir_Predefined_Physical_Absolute,
+
+ Iir_Predefined_Physical_Plus,
+ Iir_Predefined_Physical_Minus,
+
+ Iir_Predefined_Physical_Integer_Mul,
+ Iir_Predefined_Physical_Real_Mul,
+ Iir_Predefined_Integer_Physical_Mul,
+ Iir_Predefined_Real_Physical_Mul,
+ Iir_Predefined_Physical_Integer_Div,
+ Iir_Predefined_Physical_Real_Div,
+ Iir_Predefined_Physical_Physical_Div,
+
+ Iir_Predefined_Physical_Minimum,
+ Iir_Predefined_Physical_Maximum,
+ Iir_Predefined_Physical_To_String,
+
+ Iir_Predefined_Time_To_String_Unit,
+
+ -- Predefined operators for access.
+ Iir_Predefined_Access_Equality,
+ Iir_Predefined_Access_Inequality,
+
+ -- Predefined operators for record.
+ Iir_Predefined_Record_Equality,
+ Iir_Predefined_Record_Inequality,
+
+ -- Predefined operators for array.
+ Iir_Predefined_Array_Equality,
+ Iir_Predefined_Array_Inequality,
+ Iir_Predefined_Array_Less,
+ Iir_Predefined_Array_Less_Equal,
+ Iir_Predefined_Array_Greater,
+ Iir_Predefined_Array_Greater_Equal,
+
+ Iir_Predefined_Array_Array_Concat,
+ Iir_Predefined_Array_Element_Concat,
+ Iir_Predefined_Element_Array_Concat,
+ Iir_Predefined_Element_Element_Concat,
+
+ Iir_Predefined_Array_Minimum,
+ Iir_Predefined_Array_Maximum,
+ Iir_Predefined_Vector_Minimum,
+ Iir_Predefined_Vector_Maximum,
+
+ -- Predefined shift operators.
+ Iir_Predefined_Array_Sll,
+ Iir_Predefined_Array_Srl,
+ Iir_Predefined_Array_Sla,
+ Iir_Predefined_Array_Sra,
+ Iir_Predefined_Array_Rol,
+ Iir_Predefined_Array_Ror,
+
+ -- Predefined operators for one dimensional array.
+ -- For bit and boolean type, the operations are the same. For a neutral
+ -- noun, we use TF (for True/False) instead of Bit, Boolean or Logic.
+ Iir_Predefined_TF_Array_And,
+ Iir_Predefined_TF_Array_Or,
+ Iir_Predefined_TF_Array_Nand,
+ Iir_Predefined_TF_Array_Nor,
+ Iir_Predefined_TF_Array_Xor,
+ Iir_Predefined_TF_Array_Xnor,
+ Iir_Predefined_TF_Array_Not,
+
+ Iir_Predefined_TF_Reduction_And,
+ Iir_Predefined_TF_Reduction_Or,
+ Iir_Predefined_TF_Reduction_Nand,
+ Iir_Predefined_TF_Reduction_Nor,
+ Iir_Predefined_TF_Reduction_Xor,
+ Iir_Predefined_TF_Reduction_Xnor,
+ Iir_Predefined_TF_Reduction_Not,
+
+ Iir_Predefined_TF_Array_Element_And,
+ Iir_Predefined_TF_Element_Array_And,
+ Iir_Predefined_TF_Array_Element_Or,
+ Iir_Predefined_TF_Element_Array_Or,
+ Iir_Predefined_TF_Array_Element_Nand,
+ Iir_Predefined_TF_Element_Array_Nand,
+ Iir_Predefined_TF_Array_Element_Nor,
+ Iir_Predefined_TF_Element_Array_Nor,
+ Iir_Predefined_TF_Array_Element_Xor,
+ Iir_Predefined_TF_Element_Array_Xor,
+ Iir_Predefined_TF_Array_Element_Xnor,
+ Iir_Predefined_TF_Element_Array_Xnor,
+
+ Iir_Predefined_Bit_Array_Match_Equality,
+ Iir_Predefined_Bit_Array_Match_Inequality,
+
+ -- Predefined attribute functions.
+ Iir_Predefined_Attribute_Image,
+ Iir_Predefined_Attribute_Value,
+ Iir_Predefined_Attribute_Pos,
+ Iir_Predefined_Attribute_Val,
+ Iir_Predefined_Attribute_Succ,
+ Iir_Predefined_Attribute_Pred,
+ Iir_Predefined_Attribute_Leftof,
+ Iir_Predefined_Attribute_Rightof,
+ Iir_Predefined_Attribute_Left,
+ Iir_Predefined_Attribute_Right,
+ Iir_Predefined_Attribute_Event,
+ Iir_Predefined_Attribute_Active,
+ Iir_Predefined_Attribute_Last_Event,
+ Iir_Predefined_Attribute_Last_Active,
+ Iir_Predefined_Attribute_Last_Value,
+ Iir_Predefined_Attribute_Driving,
+ Iir_Predefined_Attribute_Driving_Value,
+
+ -- Access procedure
+ Iir_Predefined_Deallocate,
+
+ -- file function / procedures.
+ Iir_Predefined_File_Open,
+ Iir_Predefined_File_Open_Status,
+ Iir_Predefined_File_Close,
+ Iir_Predefined_Read,
+ Iir_Predefined_Read_Length,
+ Iir_Predefined_Flush,
+ Iir_Predefined_Write,
+ Iir_Predefined_Endfile,
+
+ -- To_String
+ Iir_Predefined_Array_Char_To_String,
+ Iir_Predefined_Bit_Vector_To_Ostring,
+ Iir_Predefined_Bit_Vector_To_Hstring,
+
+ -- IEEE.Std_Logic_1164.Std_Ulogic
+ Iir_Predefined_Std_Ulogic_Match_Equality,
+ Iir_Predefined_Std_Ulogic_Match_Inequality,
+ Iir_Predefined_Std_Ulogic_Match_Less,
+ Iir_Predefined_Std_Ulogic_Match_Less_Equal,
+ Iir_Predefined_Std_Ulogic_Match_Greater,
+ Iir_Predefined_Std_Ulogic_Match_Greater_Equal,
+
+ Iir_Predefined_Std_Ulogic_Array_Match_Equality,
+ Iir_Predefined_Std_Ulogic_Array_Match_Inequality,
+
+ -- Predefined function.
+ Iir_Predefined_Now_Function
+ );
+
+ -- Return TRUE iff FUNC is a short-cut predefined function.
+ function Iir_Predefined_Shortcut_P (Func : Iir_Predefined_Functions)
+ return Boolean;
+
+ subtype Iir_Predefined_Pure_Functions is Iir_Predefined_Functions range
+ Iir_Predefined_Boolean_And .. Iir_Predefined_Attribute_Driving_Value;
+
+ subtype Iir_Predefined_Dyadic_TF_Array_Functions
+ is Iir_Predefined_Functions range
+ Iir_Predefined_TF_Array_And ..
+ --Iir_Predefined_TF_Array_Or
+ --Iir_Predefined_TF_Array_Nand
+ --Iir_Predefined_TF_Array_Nor
+ --Iir_Predefined_TF_Array_Xor
+ Iir_Predefined_TF_Array_Xnor;
+
+ subtype Iir_Predefined_Shift_Functions is Iir_Predefined_Functions range
+ Iir_Predefined_Array_Sll ..
+ --Iir_Predefined_Array_Srl
+ --Iir_Predefined_Array_Sla
+ --Iir_Predefined_Array_Sra
+ --Iir_Predefined_Array_Rol
+ Iir_Predefined_Array_Ror;
+
+ subtype Iir_Predefined_Concat_Functions is Iir_Predefined_Functions range
+ Iir_Predefined_Array_Array_Concat ..
+ --Iir_Predefined_Array_Element_Concat
+ --Iir_Predefined_Element_Array_Concat
+ Iir_Predefined_Element_Element_Concat;
+
+ subtype Iir_Predefined_Std_Ulogic_Match_Ordering_Functions is
+ Iir_Predefined_Functions range
+ Iir_Predefined_Std_Ulogic_Match_Less ..
+ --Iir_Predefined_Std_Ulogic_Match_Less_Equal
+ --Iir_Predefined_Std_Ulogic_Match_Greater
+ Iir_Predefined_Std_Ulogic_Match_Greater_Equal;
+
+ -- Staticness as defined by LRM93 §6.1 and §7.4
+ type Iir_Staticness is (Unknown, None, Globally, Locally);
+
+ -- Staticness as defined by LRM93 §6.1 and §7.4
+ function Min (L,R: Iir_Staticness) return Iir_Staticness renames
+ Iir_Staticness'Min;
+
+ -- Purity state of a procedure.
+ -- PURE means the procedure is pure.
+ -- IMPURE means the procedure is impure: it references a file object or
+ -- a signal or a variable declared outside a subprogram, or it calls an
+ -- impure subprogram.
+ -- MAYBE_IMPURE means the procedure references a signal or a variable
+ -- declared in a subprogram. The relative position of a parent has to
+ -- be considered. The list of callees must not be checked.
+ -- UNKNOWN is like MAYBE_IMPURE, but the subprogram has a list of callees
+ -- whose purity is not yet known. As a consequence, a direct or
+ -- indirect call to such a procedure cannot be proved to be allowed
+ -- in a pure function.
+ -- Note: UNKNOWN is the default state. At any impure call, the state is
+ -- set to IMPURE. Only at the end of body analysis and only if the
+ -- callee list is empty, the state can be set either to MAYBE_IMPURE or
+ -- PURE.
+ type Iir_Pure_State is (Unknown, Pure, Maybe_Impure, Impure);
+
+ -- State of subprograms for validity of use in all-sensitized process.
+ -- INVALID_SIGNAL means that the subprogram is in a package and
+ -- reads a signal or that the subprogram calls (indirectly) such
+ -- a subprogram. In this case, the subprogram cannot be called from
+ -- an all-sensitized process.
+ -- READ_SIGNAL means that the subprogram reads a signal and is defined
+ -- in an entity or an architecture or that the subprogram calls
+ -- (indirectly) such a subprogram. In this case, the subprogram can
+ -- be called from an all-sensitized process and the reference will be
+ -- part of the sensitivity list.
+ -- NO_SIGNAL means that the subprogram doesn't read any signal and don't
+ -- call such a subprogram. The subprogram can be called from an
+ -- all-sensitized process but there is no need to track this call.
+ -- UNKNOWN means that the state is not yet defined.
+ type Iir_All_Sensitized is
+ (Unknown, No_Signal, Read_Signal, Invalid_Signal);
+
+ -- Constraint state of a type.
+ -- See LRM08 5.1 for definition.
+ type Iir_Constraint is
+ (Unconstrained, Partially_Constrained, Fully_Constrained);
+
+ -- The kind of an inteface list.
+ type Interface_Kind_Type is (Generic_Interface_List,
+ Port_Interface_List,
+ Procedure_Parameter_Interface_List,
+ Function_Parameter_Interface_List);
+ subtype Parameter_Interface_List is Interface_Kind_Type range
+ Procedure_Parameter_Interface_List ..
+ Function_Parameter_Interface_List;
+
+ ---------------
+ -- subranges --
+ ---------------
+ -- These subtypes are used for ranges, for `case' statments or for the `in'
+ -- operator.
+
+ -- In order to be correctly parsed by check_iir, the declaration must
+ -- follow these rules:
+ -- * the first line must be "subtype Iir_Kinds_NAME is Iir_Kind_range"
+ -- * the second line must be the lowest bound of the range, followed by "..
+ -- * comments line
+ -- * the last line must be the highest bound of the range, followed by ";"
+
+-- subtype Iir_Kinds_List is Iir_Kind range
+-- Iir_Kind_List ..
+-- Iir_Kind_Callees_List;
+
+ subtype Iir_Kinds_Library_Unit_Declaration is Iir_Kind range
+ Iir_Kind_Package_Declaration ..
+ --Iir_Kind_Package_Instantiation_Declaration
+ --Iir_Kind_Package_Body
+ --Iir_Kind_Configuration_Declaration
+ --Iir_Kind_Entity_Declaration
+ Iir_Kind_Architecture_Body;
+
+ subtype Iir_Kinds_Package_Declaration is Iir_Kind range
+ Iir_Kind_Package_Declaration ..
+ Iir_Kind_Package_Instantiation_Declaration;
+
+ -- Note: does not include iir_kind_enumeration_literal since it is
+ -- considered as a declaration.
+ subtype Iir_Kinds_Literal is Iir_Kind range
+ Iir_Kind_Integer_Literal ..
+ --Iir_Kind_Floating_Point_Literal
+ --Iir_Kind_Null_Literal
+ --Iir_Kind_String_Literal
+ --Iir_Kind_Physical_Int_Literal
+ --Iir_Kind_Physical_Fp_Literal
+ Iir_Kind_Bit_String_Literal;
+
+ subtype Iir_Kinds_Array_Type_Definition is Iir_Kind range
+ Iir_Kind_Array_Type_Definition ..
+ Iir_Kind_Array_Subtype_Definition;
+
+ subtype Iir_Kinds_Type_And_Subtype_Definition is Iir_Kind range
+ Iir_Kind_Access_Type_Definition ..
+ --Iir_Kind_Incomplete_Type_Definition
+ --Iir_Kind_File_Type_Definition
+ --Iir_Kind_Protected_Type_Declaration
+ --Iir_Kind_Record_Type_Definition
+ --Iir_Kind_Array_Type_Definition
+ --Iir_Kind_Array_Subtype_Definition
+ --Iir_Kind_Record_Subtype_Definition
+ --Iir_Kind_Access_Subtype_Definition
+ --Iir_Kind_Physical_Subtype_Definition
+ --Iir_Kind_Floating_Subtype_Definition
+ --Iir_Kind_Integer_Subtype_Definition
+ --Iir_Kind_Enumeration_Subtype_Definition
+ --Iir_Kind_Enumeration_Type_Definition
+ --Iir_Kind_Integer_Type_Definition
+ --Iir_Kind_Floating_Type_Definition
+ Iir_Kind_Physical_Type_Definition;
+
+ subtype Iir_Kinds_Subtype_Definition is Iir_Kind range
+ Iir_Kind_Array_Subtype_Definition ..
+ --Iir_Kind_Record_Subtype_Definition
+ --Iir_Kind_Access_Subtype_Definition
+ --Iir_Kind_Physical_Subtype_Definition
+ --Iir_Kind_Floating_Subtype_Definition
+ --Iir_Kind_Integer_Subtype_Definition
+ Iir_Kind_Enumeration_Subtype_Definition;
+
+ subtype Iir_Kinds_Scalar_Subtype_Definition is Iir_Kind range
+ Iir_Kind_Physical_Subtype_Definition ..
+ --Iir_Kind_Floating_Subtype_Definition
+ --Iir_Kind_Integer_Subtype_Definition
+ Iir_Kind_Enumeration_Subtype_Definition;
+
+ subtype Iir_Kinds_Scalar_Type_Definition is Iir_Kind range
+ Iir_Kind_Physical_Subtype_Definition ..
+ --Iir_Kind_Floating_Subtype_Definition
+ --Iir_Kind_Integer_Subtype_Definition
+ --Iir_Kind_Enumeration_Subtype_Definition
+ --Iir_Kind_Enumeration_Type_Definition
+ --Iir_Kind_Integer_Type_Definition
+ --Iir_Kind_Floating_Type_Definition
+ Iir_Kind_Physical_Type_Definition;
+
+ subtype Iir_Kinds_Range_Type_Definition is Iir_Kind range
+ Iir_Kind_Physical_Subtype_Definition ..
+ --Iir_Kind_Floating_Subtype_Definition
+ --Iir_Kind_Integer_Subtype_Definition
+ --Iir_Kind_Enumeration_Subtype_Definition
+ Iir_Kind_Enumeration_Type_Definition;
+
+ subtype Iir_Kinds_Discrete_Type_Definition is Iir_Kind range
+ Iir_Kind_Integer_Subtype_Definition ..
+ --Iir_Kind_Enumeration_Subtype_Definition
+ --Iir_Kind_Enumeration_Type_Definition
+ Iir_Kind_Integer_Type_Definition;
+
+-- subtype Iir_Kinds_Discrete_Subtype_Definition is Iir_Kind range
+-- Iir_Kind_Integer_Subtype_Definition ..
+-- Iir_Kind_Enumeration_Subtype_Definition;
+
+ subtype Iir_Kinds_Composite_Type_Definition is Iir_Kind range
+ Iir_Kind_Record_Type_Definition ..
+ --Iir_Kind_Array_Type_Definition
+ --Iir_Kind_Array_Subtype_Definition
+ Iir_Kind_Record_Subtype_Definition;
+
+ subtype Iir_Kinds_Type_Declaration is Iir_Kind range
+ Iir_Kind_Type_Declaration ..
+ --Iir_Kind_Anonymous_Type_Declaration
+ Iir_Kind_Subtype_Declaration;
+
+ subtype Iir_Kinds_Nonoverloadable_Declaration is Iir_Kind range
+ Iir_Kind_Type_Declaration ..
+ Iir_Kind_Element_Declaration;
+
+ subtype Iir_Kinds_Monadic_Operator is Iir_Kind range
+ Iir_Kind_Identity_Operator ..
+ --Iir_Kind_Negation_Operator
+ --Iir_Kind_Absolute_Operator
+ --Iir_Kind_Not_Operator
+ --Iir_Kind_Condition_Operator
+ --Iir_Kind_Reduction_And_Operator
+ --Iir_Kind_Reduction_Or_Operator
+ --Iir_Kind_Reduction_Nand_Operator
+ --Iir_Kind_Reduction_Nor_Operator
+ --Iir_Kind_Reduction_Xor_Operator
+ Iir_Kind_Reduction_Xnor_Operator;
+
+ subtype Iir_Kinds_Dyadic_Operator is Iir_Kind range
+ Iir_Kind_And_Operator ..
+ --Iir_Kind_Or_Operator
+ --Iir_Kind_Nand_Operator
+ --Iir_Kind_Nor_Operator
+ --Iir_Kind_Xor_Operator
+ --Iir_Kind_Xnor_Operator
+ --Iir_Kind_Equality_Operator
+ --Iir_Kind_Inequality_Operator
+ --Iir_Kind_Less_Than_Operator
+ --Iir_Kind_Less_Than_Or_Equal_Operator
+ --Iir_Kind_Greater_Than_Operator
+ --Iir_Kind_Greater_Than_Or_Equal_Operator
+ --Iir_Kind_Match_Equality_Operator
+ --Iir_Kind_Match_Inequality_Operator
+ --Iir_Kind_Match_Less_Than_Operator
+ --Iir_Kind_Match_Less_Than_Or_Equal_Operator
+ --Iir_Kind_Match_Greater_Than_Operator
+ --Iir_Kind_Match_Greater_Than_Or_Equal_Operator
+ --Iir_Kind_Sll_Operator
+ --Iir_Kind_Sla_Operator
+ --Iir_Kind_Srl_Operator
+ --Iir_Kind_Sra_Operator
+ --Iir_Kind_Rol_Operator
+ --Iir_Kind_Ror_Operator
+ --Iir_Kind_Addition_Operator
+ --Iir_Kind_Substraction_Operator
+ --Iir_Kind_Concatenation_Operator
+ --Iir_Kind_Multiplication_Operator
+ --Iir_Kind_Division_Operator
+ --Iir_Kind_Modulus_Operator
+ --Iir_Kind_Remainder_Operator
+ Iir_Kind_Exponentiation_Operator;
+
+ subtype Iir_Kinds_Function_Declaration is Iir_Kind range
+ Iir_Kind_Function_Declaration ..
+ Iir_Kind_Implicit_Function_Declaration;
+
+ subtype Iir_Kinds_Functions_And_Literals is Iir_Kind range
+ Iir_Kind_Enumeration_Literal ..
+ --Iir_Kind_Function_Declaration
+ Iir_Kind_Implicit_Function_Declaration;
+
+ subtype Iir_Kinds_Procedure_Declaration is Iir_Kind range
+ Iir_Kind_Implicit_Procedure_Declaration ..
+ Iir_Kind_Procedure_Declaration;
+
+ subtype Iir_Kinds_Subprogram_Declaration is Iir_Kind range
+ Iir_Kind_Function_Declaration ..
+ --Iir_Kind_Implicit_Function_Declaration
+ --Iir_Kind_Implicit_Procedure_Declaration
+ Iir_Kind_Procedure_Declaration;
+
+ subtype Iir_Kinds_Implicit_Subprogram_Declaration is Iir_Kind range
+ Iir_Kind_Implicit_Function_Declaration ..
+ Iir_Kind_Implicit_Procedure_Declaration;
+
+ subtype Iir_Kinds_Process_Statement is Iir_Kind range
+ Iir_Kind_Sensitized_Process_Statement ..
+ Iir_Kind_Process_Statement;
+
+ subtype Iir_Kinds_Interface_Object_Declaration is Iir_Kind range
+ Iir_Kind_Interface_Constant_Declaration ..
+ --Iir_Kind_Interface_Variable_Declaration
+ --Iir_Kind_Interface_Signal_Declaration
+ Iir_Kind_Interface_File_Declaration;
+
+ subtype Iir_Kinds_Object_Declaration is Iir_Kind range
+ Iir_Kind_Object_Alias_Declaration ..
+ --Iir_Kind_File_Declaration
+ --Iir_Kind_Guard_Signal_Declaration
+ --Iir_Kind_Signal_Declaration
+ --Iir_Kind_Variable_Declaration
+ --Iir_Kind_Constant_Declaration
+ --Iir_Kind_Iterator_Declaration
+ --Iir_Kind_Interface_Constant_Declaration
+ --Iir_Kind_Interface_Variable_Declaration
+ --Iir_Kind_Interface_Signal_Declaration
+ Iir_Kind_Interface_File_Declaration;
+
+ subtype Iir_Kinds_Branch_Quantity_Declaration is Iir_Kind range
+ Iir_Kind_Across_Quantity_Declaration ..
+ Iir_Kind_Through_Quantity_Declaration;
+
+ subtype Iir_Kinds_Quantity_Declaration is Iir_Kind range
+ Iir_Kind_Free_Quantity_Declaration ..
+ --Iir_Kind_Across_Quantity_Declaration
+ Iir_Kind_Through_Quantity_Declaration;
+
+ subtype Iir_Kinds_Non_Alias_Object_Declaration is Iir_Kind range
+ Iir_Kind_File_Declaration ..
+ --Iir_Kind_Guard_Signal_Declaration
+ --Iir_Kind_Signal_Declaration
+ --Iir_Kind_Variable_Declaration
+ --Iir_Kind_Constant_Declaration
+ --Iir_Kind_Iterator_Declaration
+ --Iir_Kind_Interface_Constant_Declaration
+ --Iir_Kind_Interface_Variable_Declaration
+ --Iir_Kind_Interface_Signal_Declaration
+ Iir_Kind_Interface_File_Declaration;
+
+ subtype Iir_Kinds_Association_Element is Iir_Kind range
+ Iir_Kind_Association_Element_By_Expression ..
+ --Iir_Kind_Association_Element_By_Individual
+ Iir_Kind_Association_Element_Open;
+
+ subtype Iir_Kinds_Choice is Iir_Kind range
+ Iir_Kind_Choice_By_Others ..
+ --Iir_Kind_Choice_By_Expression
+ --Iir_Kind_Choice_By_Range
+ --Iir_Kind_Choice_By_None
+ Iir_Kind_Choice_By_Name;
+
+ subtype Iir_Kinds_Denoting_Name is Iir_Kind range
+ Iir_Kind_Character_Literal ..
+ --Iir_Kind_Simple_Name
+ --Iir_Kind_Selected_Name
+ Iir_Kind_Operator_Symbol;
+
+ subtype Iir_Kinds_Name is Iir_Kind range
+ Iir_Kind_Character_Literal ..
+ --Iir_Kind_Simple_Name
+ --Iir_Kind_Selected_Name
+ --Iir_Kind_Operator_Symbol
+ --Iir_Kind_Selected_By_All_Name
+ Iir_Kind_Parenthesis_Name;
+
+ subtype Iir_Kinds_Dereference is Iir_Kind range
+ Iir_Kind_Dereference ..
+ Iir_Kind_Implicit_Dereference;
+
+ -- Any attribute that is an expression.
+ subtype Iir_Kinds_Expression_Attribute is Iir_Kind range
+ Iir_Kind_Left_Type_Attribute ..
+ --Iir_Kind_Right_Type_Attribute
+ --Iir_Kind_High_Type_Attribute
+ --Iir_Kind_Low_Type_Attribute
+ --Iir_Kind_Ascending_Type_Attribute
+ --Iir_Kind_Image_Attribute
+ --Iir_Kind_Value_Attribute
+ --Iir_Kind_Pos_Attribute
+ --Iir_Kind_Val_Attribute
+ --Iir_Kind_Succ_Attribute
+ --Iir_Kind_Pred_Attribute
+ --Iir_Kind_Leftof_Attribute
+ --Iir_Kind_Rightof_Attribute
+ --Iir_Kind_Delayed_Attribute
+ --Iir_Kind_Stable_Attribute
+ --Iir_Kind_Quiet_Attribute
+ --Iir_Kind_Transaction_Attribute
+ --Iir_Kind_Event_Attribute
+ --Iir_Kind_Active_Attribute
+ --Iir_Kind_Last_Event_Attribute
+ --Iir_Kind_Last_Active_Attribute
+ --Iir_Kind_Last_Value_Attribute
+ --Iir_Kind_Driving_Attribute
+ --Iir_Kind_Driving_Value_Attribute
+ --Iir_Kind_Behavior_Attribute
+ --Iir_Kind_Structure_Attribute
+ --Iir_Kind_Simple_Name_Attribute
+ --Iir_Kind_Instance_Name_Attribute
+ --Iir_Kind_Path_Name_Attribute
+ --Iir_Kind_Left_Array_Attribute
+ --Iir_Kind_Right_Array_Attribute
+ --Iir_Kind_High_Array_Attribute
+ --Iir_Kind_Low_Array_Attribute
+ --Iir_Kind_Length_Array_Attribute
+ Iir_Kind_Ascending_Array_Attribute;
+
+ -- All the attributes.
+ subtype Iir_Kinds_Attribute is Iir_Kind range
+ Iir_Kind_Base_Attribute ..
+ Iir_Kind_Reverse_Range_Array_Attribute;
+
+ subtype Iir_Kinds_Type_Attribute is Iir_Kind range
+ Iir_Kind_Left_Type_Attribute ..
+ --Iir_Kind_Right_Type_Attribute
+ --Iir_Kind_High_Type_Attribute
+ --Iir_Kind_Low_Type_Attribute
+ Iir_Kind_Ascending_Type_Attribute;
+
+ subtype Iir_Kinds_Scalar_Type_Attribute is Iir_Kind range
+ Iir_Kind_Pos_Attribute ..
+ --Iir_Kind_Val_Attribute
+ --Iir_Kind_Succ_Attribute
+ --Iir_Kind_Pred_Attribute
+ --Iir_Kind_Leftof_Attribute
+ Iir_Kind_Rightof_Attribute;
+
+ subtype Iir_Kinds_Array_Attribute is Iir_Kind range
+ Iir_Kind_Left_Array_Attribute ..
+ --Iir_Kind_Right_Array_Attribute
+ --Iir_Kind_High_Array_Attribute
+ --Iir_Kind_Low_Array_Attribute
+ --Iir_Kind_Length_Array_Attribute
+ --Iir_Kind_Ascending_Array_Attribute
+ --Iir_Kind_Range_Array_Attribute
+ Iir_Kind_Reverse_Range_Array_Attribute;
+
+ subtype Iir_Kinds_Signal_Attribute is Iir_Kind range
+ Iir_Kind_Delayed_Attribute ..
+ --Iir_Kind_Stable_Attribute
+ --Iir_Kind_Quiet_Attribute
+ Iir_Kind_Transaction_Attribute;
+
+ subtype Iir_Kinds_Signal_Value_Attribute is Iir_Kind range
+ Iir_Kind_Event_Attribute ..
+ --Iir_Kind_Active_Attribute
+ --Iir_Kind_Last_Event_Attribute
+ --Iir_Kind_Last_Active_Attribute
+ --Iir_Kind_Last_Value_Attribute
+ --Iir_Kind_Driving_Attribute
+ Iir_Kind_Driving_Value_Attribute;
+
+ subtype Iir_Kinds_Name_Attribute is Iir_Kind range
+ Iir_Kind_Simple_Name_Attribute ..
+ --Iir_Kind_Instance_Name_Attribute
+ Iir_Kind_Path_Name_Attribute;
+
+ subtype Iir_Kinds_Concurrent_Statement is Iir_Kind range
+ Iir_Kind_Sensitized_Process_Statement ..
+ --Iir_Kind_Process_Statement
+ --Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ --Iir_Kind_Concurrent_Selected_Signal_Assignment
+ --Iir_Kind_Concurrent_Assertion_Statement
+ --Iir_Kind_Psl_Default_Clock
+ --Iir_Kind_Psl_Assert_Statement
+ --Iir_Kind_Psl_Cover_Statement
+ --Iir_Kind_Concurrent_Procedure_Call_Statement
+ --Iir_Kind_Block_Statement
+ --Iir_Kind_Generate_Statement
+ Iir_Kind_Component_Instantiation_Statement;
+
+ subtype Iir_Kinds_Concurrent_Signal_Assignment is Iir_Kind range
+ Iir_Kind_Concurrent_Conditional_Signal_Assignment ..
+ Iir_Kind_Concurrent_Selected_Signal_Assignment;
+
+ subtype Iir_Kinds_Sequential_Statement is Iir_Kind range
+ Iir_Kind_Signal_Assignment_Statement ..
+ --Iir_Kind_Null_Statement
+ --Iir_Kind_Assertion_Statement
+ --Iir_Kind_Report_Statement
+ --Iir_Kind_Wait_Statement
+ --Iir_Kind_Variable_Assignment_Statement
+ --Iir_Kind_Return_Statement
+ --Iir_Kind_For_Loop_Statement
+ --Iir_Kind_While_Loop_Statement
+ --Iir_Kind_Next_Statement
+ --Iir_Kind_Exit_Statement
+ --Iir_Kind_Case_Statement
+ --Iir_Kind_Procedure_Call_Statement
+ Iir_Kind_If_Statement;
+
+ subtype Iir_Kinds_Allocator is Iir_Kind range
+ Iir_Kind_Allocator_By_Expression ..
+ Iir_Kind_Allocator_By_Subtype;
+
+ subtype Iir_Kinds_Clause is Iir_Kind range
+ Iir_Kind_Library_Clause ..
+ Iir_Kind_Use_Clause;
+
+ subtype Iir_Kinds_Specification is Iir_Kind range
+ Iir_Kind_Attribute_Specification ..
+ --Iir_Kind_Disconnection_Specification
+ Iir_Kind_Configuration_Specification;
+
+ subtype Iir_Kinds_Declaration is Iir_Kind range
+ Iir_Kind_Type_Declaration ..
+ --Iir_Kind_Anonymous_Type_Declaration
+ --Iir_Kind_Subtype_Declaration
+ --Iir_Kind_Nature_Declaration
+ --Iir_Kind_Subnature_Declaration
+ --Iir_Kind_Package_Declaration
+ --Iir_Kind_Package_Instantiation_Declaration
+ --Iir_Kind_Package_Body
+ --Iir_Kind_Configuration_Declaration
+ --Iir_Kind_Entity_Declaration
+ --Iir_Kind_Architecture_Body
+ --Iir_Kind_Package_Header
+ --Iir_Kind_Unit_Declaration
+ --Iir_Kind_Library_Declaration
+ --Iir_Kind_Component_Declaration
+ --Iir_Kind_Attribute_Declaration
+ --Iir_Kind_Group_Template_Declaration
+ --Iir_Kind_Group_Declaration
+ --Iir_Kind_Element_Declaration
+ --Iir_Kind_Non_Object_Alias_Declaration
+ --Iir_Kind_Psl_Declaration
+ --Iir_Kind_Terminal_Declaration
+ --Iir_Kind_Free_Quantity_Declaration
+ --Iir_Kind_Across_Quantity_Declaration
+ --Iir_Kind_Through_Quantity_Declaration
+ --Iir_Kind_Enumeration_Literal
+ --Iir_Kind_Function_Declaration
+ --Iir_Kind_Implicit_Function_Declaration
+ --Iir_Kind_Implicit_Procedure_Declaration
+ --Iir_Kind_Procedure_Declaration
+ --Iir_Kind_Function_Body
+ --Iir_Kind_Procedure_Body
+ --Iir_Kind_Object_Alias_Declaration
+ --Iir_Kind_File_Declaration
+ --Iir_Kind_Guard_Signal_Declaration
+ --Iir_Kind_Signal_Declaration
+ --Iir_Kind_Variable_Declaration
+ --Iir_Kind_Constant_Declaration
+ --Iir_Kind_Iterator_Declaration
+ --Iir_Kind_Interface_Constant_Declaration
+ --Iir_Kind_Interface_Variable_Declaration
+ --Iir_Kind_Interface_Signal_Declaration
+ Iir_Kind_Interface_File_Declaration;
+
+ -------------------------------------
+ -- Types and subtypes declarations --
+ -------------------------------------
+
+ -- Level 1 base class.
+ subtype Iir is Nodes.Node_Type;
+ subtype Iir_List is Lists.List_Type;
+ Null_Iir_List : constant Iir_List := Lists.Null_List;
+ Iir_List_All : constant Iir_List := Lists.List_All;
+ Iir_List_Others : constant Iir_List := Lists.List_Others;
+ subtype Iir_Lists_All_Others is Iir_List
+ range Iir_List_Others .. Iir_List_All;
+
+ Null_Iir : constant Iir := Nodes.Null_Node;
+
+ function Is_Null (Node : Iir) return Boolean;
+ pragma Inline (Is_Null);
+
+ function Is_Null_List (Node : Iir_List) return Boolean;
+ pragma Inline (Is_Null_List);
+
+ function "=" (L, R : Iir) return Boolean renames Nodes."=";
+
+ function Get_Last_Node return Iir renames Nodes.Get_Last_Node;
+
+ function Create_Iir_List return Iir_List
+ renames Lists.Create_List;
+ function Get_Nth_Element (L : Iir_List; N : Natural) return Iir
+ renames Lists.Get_Nth_Element;
+ procedure Replace_Nth_Element (L : Iir_List; N : Natural; El : Iir)
+ renames Lists.Replace_Nth_Element;
+ procedure Append_Element (L : Iir_List; E : Iir)
+ renames Lists.Append_Element;
+ procedure Add_Element (L : Iir_List; E : Iir)
+ renames Lists.Add_Element;
+ procedure Destroy_Iir_List (L : in out Iir_List)
+ renames Lists.Destroy_List;
+ function Get_Nbr_Elements (L : Iir_List) return Natural
+ renames Lists.Get_Nbr_Elements;
+ procedure Set_Nbr_Elements (L : Iir_List; Nbr : Natural)
+ renames Lists.Set_Nbr_Elements;
+ function Get_First_Element (L : Iir_List) return Iir
+ renames Lists.Get_First_Element;
+ function Get_Last_Element (L : Iir_List) return Iir
+ renames Lists.Get_Last_Element;
+ function "=" (L, R : Iir_List) return Boolean renames Lists."=";
+
+ -- This is used only for lists.
+ type Iir_Array is array (Natural range <>) of Iir;
+ type Iir_Array_Acc is access Iir_Array;
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Iir_Array, Name => Iir_Array_Acc);
+
+ -- Date State.
+ -- This indicates the origin of the data information.
+ -- This also indicates the state of the unit (loaded or not).
+ type Date_State_Type is
+ (
+ -- The unit is not yet in the library.
+ Date_Extern,
+
+ -- The unit is not loaded (still on the disk).
+ -- All the informations come from the library file.
+ Date_Disk,
+
+ -- The unit has been parsed, but not analyzed.
+ -- Only the date information come from the library.
+ Date_Parse,
+
+ -- The unit has been analyzed.
+ Date_Analyze
+ );
+
+ -- A date is used for analysis order. All design units from a library
+ -- are ordered according to the date.
+ type Date_Type is new Nat32;
+ -- The unit is obseleted (ie replaced) by a more recently analyzed design
+ -- unit.another design unit.
+ -- If another design unit depends (directly or not) on an obseleted design
+ -- unit, it is also obselete, and cannot be defined.
+ Date_Obsolete : constant Date_Type := 0;
+ -- The unit was not analyzed.
+ Date_Not_Analyzed : constant Date_Type := 1;
+ -- The unit has been analyzed but it has bad dependences.
+ Date_Bad_Analyze : constant Date_Type := 2;
+ -- The unit has been parsed but not analyzed.
+ Date_Parsed : constant Date_Type := 4;
+ -- The unit is being analyzed.
+ Date_Analyzing : constant Date_Type := 5;
+ -- This unit has just been analyzed and should be marked at the last
+ -- analyzed unit.
+ Date_Analyzed : constant Date_Type := 6;
+ -- Used only for default configuration.
+ -- Such units are always up-to-date.
+ Date_Uptodate : constant Date_Type := 7;
+ subtype Date_Valid is Date_Type range 10 .. Date_Type'Last;
+
+ -- Predefined depth values.
+ -- Depth of a subprogram not declared in another subprogram.
+ Iir_Depth_Top : constant Iir_Int32 := 0;
+ -- Purity depth of a pure subprogram.
+ Iir_Depth_Pure : constant Iir_Int32 := Iir_Int32'Last;
+ -- Purity depth of an impure subprogram.
+ Iir_Depth_Impure : constant Iir_Int32 := -1;
+
+ type Base_Type is (Base_2, Base_8, Base_16);
+
+ -- design file
+ subtype Iir_Design_File is Iir;
+
+ subtype Iir_Design_Unit is Iir;
+
+ subtype Iir_Library_Clause is Iir;
+
+ -- Literals.
+ --subtype Iir_Text_Literal is Iir;
+
+ subtype Iir_Character_Literal is Iir;
+
+ subtype Iir_Integer_Literal is Iir;
+
+ subtype Iir_Floating_Point_Literal is Iir;
+
+ subtype Iir_String_Literal is Iir;
+
+ subtype Iir_Bit_String_Literal is Iir;
+
+ subtype Iir_Null_Literal is Iir;
+
+ subtype Iir_Physical_Int_Literal is Iir;
+
+ subtype Iir_Physical_Fp_Literal is Iir;
+
+ subtype Iir_Enumeration_Literal is Iir;
+
+ subtype Iir_Simple_Aggregate is Iir;
+
+ subtype Iir_Enumeration_Type_Definition is Iir;
+
+ subtype Iir_Enumeration_Subtype_Definition is Iir;
+
+ subtype Iir_Range_Expression is Iir;
+
+ subtype Iir_Integer_Subtype_Definition is Iir;
+
+ subtype Iir_Integer_Type_Definition is Iir;
+
+ subtype Iir_Floating_Subtype_Definition is Iir;
+
+ subtype Iir_Floating_Type_Definition is Iir;
+
+ subtype Iir_Array_Type_Definition is Iir;
+
+ subtype Iir_Record_Type_Definition is Iir;
+
+ subtype Iir_Protected_Type_Declaration is Iir;
+
+ subtype Iir_Protected_Type_Body is Iir;
+
+ subtype Iir_Subtype_Definition is Iir;
+
+ subtype Iir_Array_Subtype_Definition is Iir;
+
+ subtype Iir_Physical_Type_Definition is Iir;
+
+ subtype Iir_Physical_Subtype_Definition is Iir;
+
+ subtype Iir_Access_Type_Definition is Iir;
+
+ subtype Iir_Access_Subtype_Definition is Iir;
+
+ subtype Iir_File_Type_Definition is Iir;
+
+ subtype Iir_Waveform_Element is Iir;
+
+ subtype Iir_Conditional_Waveform is Iir;
+
+ subtype Iir_Association_Element_By_Expression is Iir;
+
+ subtype Iir_Association_Element_By_Individual is Iir;
+
+ subtype Iir_Association_Element_Open is Iir;
+
+ subtype Iir_Signature is Iir;
+
+ subtype Iir_Unit_Declaration is Iir;
+
+ subtype Iir_Entity_Aspect_Entity is Iir;
+
+ subtype Iir_Entity_Aspect_Configuration is Iir;
+
+ subtype Iir_Entity_Aspect_Open is Iir;
+
+ subtype Iir_Block_Configuration is Iir;
+
+ subtype Iir_Block_Header is Iir;
+
+ subtype Iir_Component_Configuration is Iir;
+
+ subtype Iir_Binding_Indication is Iir;
+
+ subtype Iir_Entity_Class is Iir;
+
+ subtype Iir_Attribute_Specification is Iir;
+
+ subtype Iir_Attribute_Value is Iir;
+
+ subtype Iir_Selected_Element is Iir;
+
+ subtype Iir_Implicit_Dereference is Iir;
+
+ subtype Iir_Aggregate_Info is Iir;
+
+ subtype Iir_Procedure_Call is Iir;
+
+ subtype Iir_Disconnection_Specification is Iir;
+
+ -- Lists.
+
+ subtype Iir_Index_List is Iir_List;
+
+ subtype Iir_Design_Unit_List is Iir_List;
+
+ subtype Iir_Enumeration_Literal_List is Iir_List;
+
+ subtype Iir_Designator_List is Iir_List;
+
+ subtype Iir_Attribute_Value_Chain is Iir_List;
+
+ subtype Iir_Overload_List is Iir;
+
+ subtype Iir_Group_Constituent_List is Iir_List;
+
+ subtype Iir_Callees_List is Iir_List;
+
+ -- Declaration and children.
+ subtype Iir_Entity_Declaration is Iir;
+
+ subtype Iir_Architecture_Body is Iir;
+
+ subtype Iir_Interface_Signal_Declaration is Iir;
+
+ subtype Iir_Configuration_Declaration is Iir;
+
+ subtype Iir_Type_Declaration is Iir;
+
+ subtype Iir_Anonymous_Type_Declaration is Iir;
+
+ subtype Iir_Subtype_Declaration is Iir;
+
+ subtype Iir_Package_Declaration is Iir;
+ subtype Iir_Package_Body is Iir;
+
+ subtype Iir_Library_Declaration is Iir;
+
+ subtype Iir_Function_Declaration is Iir;
+
+ subtype Iir_Function_Body is Iir;
+
+ subtype Iir_Procedure_Declaration is Iir;
+
+ subtype Iir_Procedure_Body is Iir;
+
+ subtype Iir_Implicit_Function_Declaration is Iir;
+
+ subtype Iir_Implicit_Procedure_Declaration is Iir;
+
+ subtype Iir_Use_Clause is Iir;
+
+ subtype Iir_Constant_Declaration is Iir;
+
+ subtype Iir_Iterator_Declaration is Iir;
+
+ subtype Iir_Interface_Constant_Declaration is Iir;
+
+ subtype Iir_Interface_Variable_Declaration is Iir;
+
+ subtype Iir_Interface_File_Declaration is Iir;
+
+ subtype Iir_Guard_Signal_Declaration is Iir;
+
+ subtype Iir_Signal_Declaration is Iir;
+
+ subtype Iir_Variable_Declaration is Iir;
+
+ subtype Iir_Component_Declaration is Iir;
+
+ subtype Iir_Element_Declaration is Iir;
+
+ subtype Iir_Object_Alias_Declaration is Iir;
+
+ subtype Iir_Non_Object_Alias_Declaration is Iir;
+
+ subtype Iir_Interface_Declaration is Iir;
+
+ subtype Iir_Configuration_Specification is Iir;
+
+ subtype Iir_File_Declaration is Iir;
+
+ subtype Iir_Attribute_Declaration is Iir;
+
+ subtype Iir_Group_Template_Declaration is Iir;
+
+ subtype Iir_Group_Declaration is Iir;
+
+ -- concurrent_statement and children.
+ subtype Iir_Concurrent_Statement is Iir;
+
+ subtype Iir_Concurrent_Conditional_Signal_Assignment is Iir;
+
+ subtype Iir_Sensitized_Process_Statement is Iir;
+
+ subtype Iir_Process_Statement is Iir;
+
+ subtype Iir_Component_Instantiation_Statement is Iir;
+
+ subtype Iir_Block_Statement is Iir;
+
+ subtype Iir_Generate_Statement is Iir;
+
+ -- sequential statements.
+ subtype Iir_If_Statement is Iir;
+
+ subtype Iir_Elsif is Iir;
+
+ subtype Iir_For_Loop_Statement is Iir;
+
+ subtype Iir_While_Loop_Statement is Iir;
+
+ subtype Iir_Exit_Statement is Iir;
+ subtype Iir_Next_Statement is Iir;
+
+ subtype Iir_Variable_Assignment_Statement is Iir;
+
+ subtype Iir_Signal_Assignment_Statement is Iir;
+
+ subtype Iir_Assertion_Statement is Iir;
+
+ subtype Iir_Report_Statement is Iir;
+
+ subtype Iir_Wait_Statement is Iir;
+
+ subtype Iir_Return_Statement is Iir;
+
+ subtype Iir_Case_Statement is Iir;
+
+ subtype Iir_Procedure_Call_Statement is Iir;
+
+ -- expression and children.
+ subtype Iir_Expression is Iir;
+
+ subtype Iir_Function_Call is Iir;
+
+ subtype Iir_Aggregate is Iir;
+
+ subtype Iir_Qualified_Expression is Iir;
+
+ subtype Iir_Type_Conversion is Iir;
+
+ subtype Iir_Allocator_By_Expression is Iir;
+
+ subtype Iir_Allocator_By_Subtype is Iir;
+
+ -- names.
+ subtype Iir_Simple_Name is Iir;
+
+ subtype Iir_Slice_Name is Iir;
+
+ subtype Iir_Selected_Name is Iir;
+
+ subtype Iir_Selected_By_All_Name is Iir;
+
+ subtype Iir_Indexed_Name is Iir;
+
+ subtype Iir_Parenthesis_Name is Iir;
+
+ -- attributes.
+ subtype Iir_Attribute_Name is Iir;
+
+ -- General methods.
+
+ -- Get the kind of the iir.
+ function Get_Kind (An_Iir: Iir) return Iir_Kind;
+ pragma Inline (Get_Kind);
+
+ -- Create a new IIR of kind NEW_KIND, and copy fields from SRC to this
+ -- iir. Src fields are cleaned.
+ --function Clone_Iir (Src: Iir; New_Kind : Iir_Kind) return Iir;
+
+ procedure Set_Location (Target: Iir; Location: Location_Type)
+ renames Nodes.Set_Location;
+ function Get_Location (Target: Iir) return Location_Type
+ renames Nodes.Get_Location;
+
+ procedure Location_Copy (Target: Iir; Src: Iir);
+
+ function Create_Iir (Kind: Iir_Kind) return Iir;
+ function Create_Iir_Error return Iir;
+ procedure Free_Iir (Target: Iir) renames Nodes.Free_Node;
+
+ -- Disp statistics about node usage.
+ procedure Disp_Stats;
+
+ -- Design units contained in a design file.
+ -- Field: Field5 Chain
+ function Get_First_Design_Unit (Design : Iir) return Iir;
+ procedure Set_First_Design_Unit (Design : Iir; Chain : Iir);
+
+ -- Field: Field6 Ref
+ function Get_Last_Design_Unit (Design : Iir) return Iir;
+ procedure Set_Last_Design_Unit (Design : Iir; Chain : Iir);
+
+ -- Library declaration of a library clause.
+ -- Field: Field1
+ function Get_Library_Declaration (Design : Iir) return Iir;
+ procedure Set_Library_Declaration (Design : Iir; Library : Iir);
+
+ -- File time stamp is the system time of the file last modification.
+ -- Field: Field4 (uc)
+ function Get_File_Time_Stamp (Design : Iir) return Time_Stamp_Id;
+ procedure Set_File_Time_Stamp (Design : Iir; Stamp : Time_Stamp_Id);
+
+ -- Time stamp of the last analysis system time.
+ -- Field: Field3 (uc)
+ function Get_Analysis_Time_Stamp (Design : Iir) return Time_Stamp_Id;
+ procedure Set_Analysis_Time_Stamp (Design : Iir; Stamp : Time_Stamp_Id);
+
+ -- The library which FILE belongs to.
+ -- Field: Field0 Ref
+ function Get_Library (File : Iir_Design_File) return Iir;
+ procedure Set_Library (File : Iir_Design_File; Lib : Iir);
+
+ -- List of files which this design file depends on.
+ -- Field: Field1 (uc)
+ function Get_File_Dependence_List (File : Iir_Design_File) return Iir_List;
+ procedure Set_File_Dependence_List (File : Iir_Design_File; Lst : Iir_List);
+
+ -- Identifier for the design file file name.
+ -- Field: Field12 (pos)
+ function Get_Design_File_Filename (File : Iir_Design_File) return Name_Id;
+ procedure Set_Design_File_Filename (File : Iir_Design_File; Name : Name_Id);
+
+ -- Directory of a design file.
+ -- Field: Field11 (pos)
+ function Get_Design_File_Directory (File : Iir_Design_File) return Name_Id;
+ procedure Set_Design_File_Directory (File : Iir_Design_File; Dir : Name_Id);
+
+ -- The parent of a design unit is a design file.
+ -- Field: Field0 Ref
+ function Get_Design_File (Unit : Iir_Design_Unit) return Iir;
+ procedure Set_Design_File (Unit : Iir_Design_Unit; File : Iir);
+
+ -- Design files of a library.
+ -- Field: Field1 Chain
+ function Get_Design_File_Chain (Library : Iir) return Iir;
+ procedure Set_Design_File_Chain (Library : Iir; Chain : Iir);
+
+ -- System directory where the library is stored.
+ -- Field: Field11 (pos)
+ function Get_Library_Directory (Library : Iir) return Name_Id;
+ procedure Set_Library_Directory (Library : Iir; Dir : Name_Id);
+
+ -- Symbolic date, used to order design units in a library.
+ -- Field: Field10 (pos)
+ function Get_Date (Target : Iir) return Date_Type;
+ procedure Set_Date (Target : Iir; Date : Date_Type);
+
+ -- Chain of context clauses.
+ -- Field: Field1 Chain
+ function Get_Context_Items (Design_Unit : Iir) return Iir;
+ procedure Set_Context_Items (Design_Unit : Iir; Items_Chain : Iir);
+
+ -- List of design units on which the design unit depends. There is an
+ -- exception: the architecture of an entity aspect (of a component
+ -- instantiation) may not have been analyzed. The Entity_Aspect_Entity
+ -- is added to this list (instead of the non-existing design unit).
+ -- Field: Field8 Of_Ref (uc)
+ function Get_Dependence_List (Unit : Iir) return Iir_List;
+ procedure Set_Dependence_List (Unit : Iir; List : Iir_List);
+
+ -- List of functions or sensitized processes whose analysis checks are not
+ -- complete.
+ -- These elements have direct or indirect calls to procedure whose body is
+ -- not yet analyzed. Therefore, purity or wait checks are not complete.
+ -- Field: Field9 (uc)
+ function Get_Analysis_Checks_List (Unit : Iir) return Iir_List;
+ procedure Set_Analysis_Checks_List (Unit : Iir; List : Iir_List);
+
+ -- Wether the unit is on disk, parsed or analyzed.
+ -- Field: State1 (pos)
+ function Get_Date_State (Unit : Iir_Design_Unit) return Date_State_Type;
+ procedure Set_Date_State (Unit : Iir_Design_Unit; State : Date_State_Type);
+
+ -- If TRUE, the target of the signal assignment is guarded.
+ -- If FALSE, the target is not guarded.
+ -- This is determined during sem by examining the declaration(s) of the
+ -- target (there may be severals declarations in the case of a aggregate
+ -- target).
+ -- If UNKNOWN, this is not determined at compile time but at run-time.
+ -- This is the case for formal signal interfaces of subprograms.
+ -- Field: State3 (pos)
+ function Get_Guarded_Target_State (Stmt : Iir) return Tri_State_Type;
+ procedure Set_Guarded_Target_State (Stmt : Iir; State : Tri_State_Type);
+
+ -- Library unit of a design unit.
+ -- Field: Field5
+ function Get_Library_Unit (Design_Unit : Iir_Design_Unit) return Iir;
+ procedure Set_Library_Unit (Design_Unit : Iir_Design_Unit; Lib_Unit : Iir);
+ pragma Inline (Get_Library_Unit);
+
+ -- Every design unit is put in an hash table to find quickly found by its
+ -- name. This field is a single chain for collisions.
+ -- Field: Field7 Ref
+ function Get_Hash_Chain (Design_Unit : Iir_Design_Unit) return Iir;
+ procedure Set_Hash_Chain (Design_Unit : Iir_Design_Unit; Chain : Iir);
+
+ -- Set the line and the offset in the line, only for the library manager.
+ -- This is valid until the file is really loaded in memory. On loading,
+ -- location will contain all this informations.
+ -- Field: Field4 (uc)
+ function Get_Design_Unit_Source_Pos (Design_Unit : Iir) return Source_Ptr;
+ procedure Set_Design_Unit_Source_Pos (Design_Unit : Iir; Pos : Source_Ptr);
+
+ -- Field: Field11 (uc)
+ function Get_Design_Unit_Source_Line (Design_Unit : Iir) return Int32;
+ procedure Set_Design_Unit_Source_Line (Design_Unit : Iir; Line : Int32);
+
+ -- Field: Field12 (uc)
+ function Get_Design_Unit_Source_Col (Design_Unit : Iir) return Int32;
+ procedure Set_Design_Unit_Source_Col (Design_Unit : Iir; Line : Int32);
+
+ -- literals.
+
+ -- Value of an integer/physical literal.
+ -- Field: Int64
+ function Get_Value (Lit : Iir) return Iir_Int64;
+ procedure Set_Value (Lit : Iir; Val : Iir_Int64);
+
+ -- Position (same as lit_type'pos) of an enumeration literal.
+ -- Field: Field10 (pos)
+ function Get_Enum_Pos (Lit : Iir) return Iir_Int32;
+ procedure Set_Enum_Pos (Lit : Iir; Val : Iir_Int32);
+
+ -- Field: Field6
+ function Get_Physical_Literal (Unit : Iir) return Iir;
+ procedure Set_Physical_Literal (Unit : Iir; Lit : Iir);
+
+ -- Value of a physical unit declaration.
+ -- Field: Field7
+ function Get_Physical_Unit_Value (Unit : Iir) return Iir;
+ procedure Set_Physical_Unit_Value (Unit : Iir; Lit : Iir);
+
+ -- Value of a floating point literal.
+ -- Field: Fp64
+ function Get_Fp_Value (Lit : Iir) return Iir_Fp64;
+ procedure Set_Fp_Value (Lit : Iir; Val : Iir_Fp64);
+
+ -- Declaration of the literal.
+ -- This is used to retrieve the genuine enumeration literal for literals
+ -- created from static expression.
+ -- Field: Field6 Ref
+ function Get_Enumeration_Decl (Target : Iir) return Iir;
+ procedure Set_Enumeration_Decl (Target : Iir; Lit : Iir);
+
+ -- List of elements of a simple aggregate.
+ -- Field: Field3 (uc)
+ function Get_Simple_Aggregate_List (Target : Iir) return Iir_List;
+ procedure Set_Simple_Aggregate_List (Target : Iir; List : Iir_List);
+
+ -- The logarithm of the base (1, 3 or 4) of a bit string.
+ -- Field: Field8 (pos)
+ function Get_Bit_String_Base (Lit : Iir) return Base_Type;
+ procedure Set_Bit_String_Base (Lit : Iir; Base : Base_Type);
+
+ -- The enumeration literal which defines the '0' and '1' value.
+ -- Field: Field6
+ function Get_Bit_String_0 (Lit : Iir) return Iir;
+ procedure Set_Bit_String_0 (Lit : Iir; El : Iir);
+
+ -- Field: Field7
+ function Get_Bit_String_1 (Lit : Iir) return Iir;
+ procedure Set_Bit_String_1 (Lit : Iir; El : Iir);
+
+ -- The origin of a literal can be null_iir for a literal generated by the
+ -- parser, or a node which was statically evaluated to this literal.
+ -- Such nodes are created by eval_expr.
+ -- Field: Field2
+ function Get_Literal_Origin (Lit : Iir) return Iir;
+ procedure Set_Literal_Origin (Lit : Iir; Orig : Iir);
+
+ -- Field: Field4
+ function Get_Range_Origin (Lit : Iir) return Iir;
+ procedure Set_Range_Origin (Lit : Iir; Orig : Iir);
+
+ -- Same as Type, but not marked as Ref. This is when a literal has a
+ -- subtype (such as string or bit_string) created specially for the
+ -- literal.
+ -- Field: Field5
+ function Get_Literal_Subtype (Lit : Iir) return Iir;
+ procedure Set_Literal_Subtype (Lit : Iir; Atype : Iir);
+
+ -- Field: Field3 (uc)
+ function Get_Entity_Class (Target : Iir) return Token_Type;
+ procedure Set_Entity_Class (Target : Iir; Kind : Token_Type);
+
+ -- Field: Field1 (uc)
+ function Get_Entity_Name_List (Target : Iir) return Iir_List;
+ procedure Set_Entity_Name_List (Target : Iir; Names : Iir_List);
+
+ -- Field: Field6
+ function Get_Attribute_Designator (Target : Iir) return Iir;
+ procedure Set_Attribute_Designator (Target : Iir; Designator : Iir);
+
+ -- Chain of attribute specifications. This is used only during sem, to
+ -- check that no named entity of a given class appear after an attr. spec.
+ -- with the entity name list OTHERS or ALL.
+ -- Field: Field7
+ function Get_Attribute_Specification_Chain (Target : Iir) return Iir;
+ procedure Set_Attribute_Specification_Chain (Target : Iir; Chain : Iir);
+
+ -- Field: Field4 Ref
+ function Get_Attribute_Specification (Val : Iir) return Iir;
+ procedure Set_Attribute_Specification (Val : Iir; Attr : Iir);
+
+ -- Field: Field3 (uc)
+ function Get_Signal_List (Target : Iir) return Iir_List;
+ procedure Set_Signal_List (Target : Iir; List : Iir_List);
+
+ -- Field: Field3 Ref
+ function Get_Designated_Entity (Val : Iir_Attribute_Value) return Iir;
+ procedure Set_Designated_Entity (Val : Iir_Attribute_Value; Entity : Iir);
+
+ -- Field: Field1
+ function Get_Formal (Target : Iir) return Iir;
+ procedure Set_Formal (Target : Iir; Formal : Iir);
+
+ -- Field: Field3
+ function Get_Actual (Target : Iir) return Iir;
+ procedure Set_Actual (Target : Iir; Actual : Iir);
+
+ -- Field: Field4
+ function Get_In_Conversion (Target : Iir) return Iir;
+ procedure Set_In_Conversion (Target : Iir; Conv : Iir);
+
+ -- Field: Field5
+ function Get_Out_Conversion (Target : Iir) return Iir;
+ procedure Set_Out_Conversion (Target : Iir; Conv : Iir);
+
+ -- This flag is set when the formal is associated in whole (ie, not
+ -- individually).
+ -- Field: Flag1
+ function Get_Whole_Association_Flag (Target : Iir) return Boolean;
+ procedure Set_Whole_Association_Flag (Target : Iir; Flag : Boolean);
+
+ -- This flag is set when the formal signal can be the actual signal. In
+ -- this case, the formal signal is not created, and the actual is shared.
+ -- This is the signal collapsing optimisation.
+ -- Field: Flag2
+ function Get_Collapse_Signal_Flag (Target : Iir) return Boolean;
+ procedure Set_Collapse_Signal_Flag (Target : Iir; Flag : Boolean);
+
+ -- Set when the node was artificially created, eg by canon.
+ -- Currently used only by association_element_open.
+ -- Field: Flag3
+ function Get_Artificial_Flag (Target : Iir) return Boolean;
+ procedure Set_Artificial_Flag (Target : Iir; Flag : Boolean);
+
+ -- This flag is set for a very short time during the check that no in
+ -- port is unconnected.
+ -- Field: Flag3
+ function Get_Open_Flag (Target : Iir) return Boolean;
+ procedure Set_Open_Flag (Target : Iir; Flag : Boolean);
+
+ -- This flag is set by trans_analyze if there is a projected waveform
+ -- assignment in the process.
+ -- Field: Flag5
+ function Get_After_Drivers_Flag (Target : Iir) return Boolean;
+ procedure Set_After_Drivers_Flag (Target : Iir; Flag : Boolean);
+
+ -- Field: Field1
+ function Get_We_Value (We : Iir_Waveform_Element) return Iir;
+ procedure Set_We_Value (We : Iir_Waveform_Element; An_Iir : Iir);
+
+ -- Field: Field3
+ function Get_Time (We : Iir_Waveform_Element) return Iir;
+ procedure Set_Time (We : Iir_Waveform_Element; An_Iir : Iir);
+
+ -- Node associated with a choice.
+ -- Field: Field3
+ function Get_Associated_Expr (Target : Iir) return Iir;
+ procedure Set_Associated_Expr (Target : Iir; Associated : Iir);
+
+ -- Chain associated with a choice.
+ -- Field: Field4 Chain
+ function Get_Associated_Chain (Target : Iir) return Iir;
+ procedure Set_Associated_Chain (Target : Iir; Associated : Iir);
+
+ -- Field: Field5
+ function Get_Choice_Name (Choice : Iir) return Iir;
+ procedure Set_Choice_Name (Choice : Iir; Name : Iir);
+
+ -- Field: Field5
+ function Get_Choice_Expression (Choice : Iir) return Iir;
+ procedure Set_Choice_Expression (Choice : Iir; Name : Iir);
+
+ -- Field: Field5
+ function Get_Choice_Range (Choice : Iir) return Iir;
+ procedure Set_Choice_Range (Choice : Iir; Name : Iir);
+
+ -- Set when a choice belongs to the same alternative as the previous one.
+ -- Field: Flag1
+ function Get_Same_Alternative_Flag (Target : Iir) return Boolean;
+ procedure Set_Same_Alternative_Flag (Target : Iir; Val : Boolean);
+
+ -- Field: Field3
+ function Get_Architecture (Target : Iir_Entity_Aspect_Entity) return Iir;
+ procedure Set_Architecture (Target : Iir_Entity_Aspect_Entity; Arch : Iir);
+
+ -- Field: Field5
+ function Get_Block_Specification (Target : Iir) return Iir;
+ procedure Set_Block_Specification (Target : Iir; Block : Iir);
+
+ -- Return the link of the previous block_configuration of a
+ -- block_configuration.
+ -- This single linked list is used to list all the block_configuration that
+ -- configuration the same block (which can only be an iterative generate
+ -- statement).
+ -- All elements of this list must belong to the same block configuration.
+ -- The order is not important.
+ -- Field: Field4 Ref
+ function Get_Prev_Block_Configuration (Target : Iir) return Iir;
+ procedure Set_Prev_Block_Configuration (Target : Iir; Block : Iir);
+
+ -- Field: Field3 Chain
+ function Get_Configuration_Item_Chain (Target : Iir) return Iir;
+ procedure Set_Configuration_Item_Chain (Target : Iir; Chain : Iir);
+
+ -- Chain of attribute values for a named entity.
+ -- To be used with Get/Set_Chain.
+ -- There is no order, therefore, a new attribute value may be always
+ -- prepended.
+ -- Field: Field4 Chain
+ function Get_Attribute_Value_Chain (Target : Iir) return Iir;
+ procedure Set_Attribute_Value_Chain (Target : Iir; Chain : Iir);
+
+ -- Next attribute value in the attribute specification chain (of attribute
+ -- value).
+ -- Field: Field0
+ function Get_Spec_Chain (Target : Iir) return Iir;
+ procedure Set_Spec_Chain (Target : Iir; Chain : Iir);
+
+ -- Chain of attribute values for attribute specification.
+ -- To be used with Get/Set_Spec_Chain.
+ -- Field: Field4
+ function Get_Attribute_Value_Spec_Chain (Target : Iir) return Iir;
+ procedure Set_Attribute_Value_Spec_Chain (Target : Iir; Chain : Iir);
+
+ -- The entity name for an architecture or a configuration.
+ -- Field: Field2
+ function Get_Entity_Name (Arch : Iir) return Iir;
+ procedure Set_Entity_Name (Arch : Iir; Entity : Iir);
+
+ -- The package declaration corresponding to the body.
+ -- Field: Field4 Ref
+ function Get_Package (Package_Body : Iir) return Iir;
+ procedure Set_Package (Package_Body : Iir; Decl : Iir);
+
+ -- The package body corresponding to the package declaration.
+ -- Field: Field2 Ref
+ function Get_Package_Body (Pkg : Iir) return Iir;
+ procedure Set_Package_Body (Pkg : Iir; Decl : Iir);
+
+ -- If true, the package need a body.
+ -- Field: Flag1
+ function Get_Need_Body (Decl : Iir_Package_Declaration) return Boolean;
+ procedure Set_Need_Body (Decl : Iir_Package_Declaration; Flag : Boolean);
+
+ -- Field: Field5
+ function Get_Block_Configuration (Target : Iir) return Iir;
+ procedure Set_Block_Configuration (Target : Iir; Block : Iir);
+
+ -- Field: Field5 Chain
+ function Get_Concurrent_Statement_Chain (Target : Iir) return Iir;
+ procedure Set_Concurrent_Statement_Chain (Target : Iir; First : Iir);
+
+ -- Field: Field2 Chain_Next
+ function Get_Chain (Target : Iir) return Iir;
+ procedure Set_Chain (Target : Iir; Chain : Iir);
+ pragma Inline (Get_Chain);
+
+ -- Field: Field7 Chain
+ function Get_Port_Chain (Target : Iir) return Iir;
+ procedure Set_Port_Chain (Target : Iir; Chain : Iir);
+
+ -- Field: Field6 Chain
+ function Get_Generic_Chain (Target : Iir) return Iir;
+ procedure Set_Generic_Chain (Target : Iir; Generics : Iir);
+
+ -- Field: Field1 Ref
+ function Get_Type (Target : Iir) return Iir;
+ procedure Set_Type (Target : Iir; Atype : Iir);
+ pragma Inline (Get_Type);
+
+ -- The subtype indication of a declaration. Note that this node can be
+ -- shared between declarations if they are separated by comma, such as in:
+ -- variable a, b : integer := 5;
+ -- Field: Field5 Maybe_Ref
+ function Get_Subtype_Indication (Target : Iir) return Iir;
+ procedure Set_Subtype_Indication (Target : Iir; Atype : Iir);
+
+ -- Field: Field6
+ function Get_Discrete_Range (Target : Iir) return Iir;
+ procedure Set_Discrete_Range (Target : Iir; Rng : Iir);
+
+ -- Field: Field1
+ function Get_Type_Definition (Decl : Iir) return Iir;
+ procedure Set_Type_Definition (Decl : Iir; Atype : Iir);
+
+ -- The subtype definition associated with the type declaration (if any).
+ -- Field: Field4
+ function Get_Subtype_Definition (Target : Iir) return Iir;
+ procedure Set_Subtype_Definition (Target : Iir; Def : Iir);
+
+ -- Field: Field1
+ function Get_Nature (Target : Iir) return Iir;
+ procedure Set_Nature (Target : Iir; Nature : Iir);
+
+ -- Mode of interfaces or file (v87).
+ -- Field: Odigit1 (pos)
+ function Get_Mode (Target : Iir) return Iir_Mode;
+ procedure Set_Mode (Target : Iir; Mode : Iir_Mode);
+
+ -- Field: State3 (pos)
+ function Get_Signal_Kind (Target : Iir) return Iir_Signal_Kind;
+ procedure Set_Signal_Kind (Target : Iir; Signal_Kind : Iir_Signal_Kind);
+
+ -- The base name of a name is the node at the origin of the name.
+ -- The base name is a declaration (signal, object, constant or interface),
+ -- a selected_by_all name, an implicit_dereference name.
+ -- Field: Field5 Ref
+ function Get_Base_Name (Target : Iir) return Iir;
+ procedure Set_Base_Name (Target : Iir; Name : Iir);
+ pragma Inline (Get_Base_Name);
+
+ -- Field: Field5 Chain
+ function Get_Interface_Declaration_Chain (Target : Iir) return Iir;
+ procedure Set_Interface_Declaration_Chain (Target : Iir; Chain : Iir);
+ pragma Inline (Get_Interface_Declaration_Chain);
+
+ -- Field: Field4 Ref
+ function Get_Subprogram_Specification (Target : Iir) return Iir;
+ procedure Set_Subprogram_Specification (Target : Iir; Spec : Iir);
+
+ -- Field: Field5 Chain
+ function Get_Sequential_Statement_Chain (Target : Iir) return Iir;
+ procedure Set_Sequential_Statement_Chain (Target : Iir; Chain : Iir);
+
+ -- Field: Field9 Ref
+ function Get_Subprogram_Body (Target : Iir) return Iir;
+ procedure Set_Subprogram_Body (Target : Iir; A_Body : Iir);
+
+ -- Several subprograms in a declarative region may have the same
+ -- identifier. If the overload number is not 0, it is the rank of the
+ -- subprogram. If the overload number is 0, then the identifier is not
+ -- overloaded in the declarative region.
+ -- Field: Field12 (pos)
+ function Get_Overload_Number (Target : Iir) return Iir_Int32;
+ procedure Set_Overload_Number (Target : Iir; Val : Iir_Int32);
+
+ -- Depth of a subprogram.
+ -- For a subprogram declared immediatly within an entity, architecture,
+ -- package, process, block, generate, the depth is 0.
+ -- For a subprogram declared immediatly within a subprogram of level N,
+ -- the depth is N + 1.
+ -- Depth is used with depth of impure objects to check purity rules.
+ -- Field: Field10 (pos)
+ function Get_Subprogram_Depth (Target : Iir) return Iir_Int32;
+ procedure Set_Subprogram_Depth (Target : Iir; Depth : Iir_Int32);
+
+ -- Hash of a subprogram profile.
+ -- This is used to speed up subprogram profile comparaison, which is very
+ -- often used by overload.
+ -- Field: Field11 (pos)
+ function Get_Subprogram_Hash (Target : Iir) return Iir_Int32;
+ procedure Set_Subprogram_Hash (Target : Iir; Val : Iir_Int32);
+ pragma Inline (Get_Subprogram_Hash);
+
+ -- Depth of the deepest impure object.
+ -- Field: Field3 (uc)
+ function Get_Impure_Depth (Target : Iir) return Iir_Int32;
+ procedure Set_Impure_Depth (Target : Iir; Depth : Iir_Int32);
+
+ -- Field: Field1 Ref
+ function Get_Return_Type (Target : Iir) return Iir;
+ procedure Set_Return_Type (Target : Iir; Decl : Iir);
+ pragma Inline (Get_Return_Type);
+
+ -- Code of an implicit subprogram definition.
+ -- Field: Field9 (pos)
+ function Get_Implicit_Definition (D : Iir) return Iir_Predefined_Functions;
+ procedure Set_Implicit_Definition (D : Iir; Def : Iir_Predefined_Functions);
+
+ -- For an implicit subprogram, the type_reference is the type declaration
+ -- for which the implicit subprogram was defined.
+ -- Field: Field10 Ref
+ function Get_Type_Reference (Target : Iir) return Iir;
+ procedure Set_Type_Reference (Target : Iir; Decl : Iir);
+
+ -- Get the default value of an object declaration.
+ -- Null_iir if no default value.
+ -- Note that this node can be shared between declarations if they are
+ -- separated by comma, such as in:
+ -- variable a, b : integer := 5;
+ -- Field: Field6 Maybe_Ref
+ function Get_Default_Value (Target : Iir) return Iir;
+ procedure Set_Default_Value (Target : Iir; Value : Iir);
+
+ -- The deferred_declaration field points to the deferred constant
+ -- declaration for a full constant declaration, or is null_iir for a
+ -- usual or deferred constant declaration.
+ -- Set only during sem.
+ -- Field: Field7
+ function Get_Deferred_Declaration (Target : Iir) return Iir;
+ procedure Set_Deferred_Declaration (Target : Iir; Decl : Iir);
+
+ -- The deferred_declaration_flag must be set if the constant declaration is
+ -- a deferred_constant declaration.
+ -- Set only during sem.
+ -- Field: Flag1
+ function Get_Deferred_Declaration_Flag (Target : Iir) return Boolean;
+ procedure Set_Deferred_Declaration_Flag (Target : Iir; Flag : Boolean);
+
+ -- If true, the variable is declared shared.
+ -- Field: Flag2
+ function Get_Shared_Flag (Target : Iir) return Boolean;
+ procedure Set_Shared_Flag (Target : Iir; Shared : Boolean);
+
+ -- Get the design unit in which the target is declared.
+ -- For a library unit, this is to get the design unit node.
+ -- Field: Field0
+ function Get_Design_Unit (Target : Iir) return Iir;
+ procedure Set_Design_Unit (Target : Iir; Unit : Iir);
+
+ -- Field: Field7
+ function Get_Block_Statement (Target : Iir) return Iir;
+ procedure Set_Block_Statement (Target : Iir; Block : Iir);
+
+ -- For a non-resolved signal: null_iir if the signal has no driver, or
+ -- a process/concurrent_statement for which the signal should have a
+ -- driver. This is used to catch at analyse time unresolved signals with
+ -- several drivers.
+ -- Field: Field7
+ function Get_Signal_Driver (Target : Iir_Signal_Declaration) return Iir;
+ procedure Set_Signal_Driver (Target : Iir_Signal_Declaration; Driver : Iir);
+
+ -- Field: Field1 Chain
+ function Get_Declaration_Chain (Target : Iir) return Iir;
+ procedure Set_Declaration_Chain (Target : Iir; Decls : Iir);
+
+ -- Field: Field6
+ function Get_File_Logical_Name (Target : Iir_File_Declaration) return Iir;
+ procedure Set_File_Logical_Name (Target : Iir_File_Declaration; Name : Iir);
+
+ -- Field: Field7
+ function Get_File_Open_Kind (Target : Iir_File_Declaration) return Iir;
+ procedure Set_File_Open_Kind (Target : Iir_File_Declaration; Kind : Iir);
+
+ -- Field: Field4 (pos)
+ function Get_Element_Position (Target : Iir) return Iir_Index32;
+ procedure Set_Element_Position (Target : Iir; Pos : Iir_Index32);
+
+ -- Field: Field2
+ function Get_Element_Declaration (Target : Iir) return Iir;
+ procedure Set_Element_Declaration (Target : Iir; El : Iir);
+
+ -- Field: Field2 Ref
+ function Get_Selected_Element (Target : Iir) return Iir;
+ procedure Set_Selected_Element (Target : Iir; El : Iir);
+
+ -- Selected names of an use_clause are chained.
+ -- Field: Field3
+ function Get_Use_Clause_Chain (Target : Iir) return Iir;
+ procedure Set_Use_Clause_Chain (Target : Iir; Chain : Iir);
+
+ -- Selected name of an use_clause.
+ -- Field: Field1
+ function Get_Selected_Name (Target : Iir_Use_Clause) return Iir;
+ procedure Set_Selected_Name (Target : Iir_Use_Clause; Name : Iir);
+
+ -- The type declarator which declares the type definition DEF.
+ -- Field: Field3 Ref
+ function Get_Type_Declarator (Def : Iir) return Iir;
+ procedure Set_Type_Declarator (Def : Iir; Decl : Iir);
+
+ -- Field: Field2 (uc)
+ function Get_Enumeration_Literal_List (Target : Iir) return Iir_List;
+ procedure Set_Enumeration_Literal_List (Target : Iir; List : Iir_List);
+
+ -- Field: Field1 Chain
+ function Get_Entity_Class_Entry_Chain (Target : Iir) return Iir;
+ procedure Set_Entity_Class_Entry_Chain (Target : Iir; Chain : Iir);
+
+ -- Field: Field1 (uc)
+ function Get_Group_Constituent_List (Group : Iir) return Iir_List;
+ procedure Set_Group_Constituent_List (Group : Iir; List : Iir_List);
+
+ -- Chain of physical type units.
+ -- The first unit is the primary unit. If you really need the primary
+ -- unit (and not the chain), you'd better to use Get_Primary_Unit.
+ -- Field: Field1 Chain
+ function Get_Unit_Chain (Target : Iir) return Iir;
+ procedure Set_Unit_Chain (Target : Iir; Chain : Iir);
+
+ -- Alias of Get_Unit_Chain.
+ -- Return the primary unit of a physical type.
+ -- Field: Field1 Ref
+ function Get_Primary_Unit (Target : Iir) return Iir;
+ procedure Set_Primary_Unit (Target : Iir; Unit : Iir);
+
+ -- Get/Set the identifier of a declaration.
+ -- Can also be used instead of get/set_label.
+ -- Field: Field3 (uc)
+ function Get_Identifier (Target : Iir) return Name_Id;
+ procedure Set_Identifier (Target : Iir; Identifier : Name_Id);
+ pragma Inline (Get_Identifier);
+
+ -- Field: Field3 (uc)
+ function Get_Label (Target : Iir) return Name_Id;
+ procedure Set_Label (Target : Iir; Label : Name_Id);
+
+ -- Get/Set the visible flag of a declaration.
+ -- The visible flag is true to make invalid the use of the identifier
+ -- during its declaration. It is set to false when the identifier is added
+ -- to the name table, and set to true when the declaration is finished.
+ -- Field: Flag4
+ function Get_Visible_Flag (Target : Iir) return Boolean;
+ procedure Set_Visible_Flag (Target : Iir; Flag : Boolean);
+
+ -- Field: Field1
+ function Get_Range_Constraint (Target : Iir) return Iir;
+ procedure Set_Range_Constraint (Target : Iir; Constraint : Iir);
+
+ -- Field: State2 (pos)
+ function Get_Direction (Decl : Iir) return Iir_Direction;
+ procedure Set_Direction (Decl : Iir; Dir : Iir_Direction);
+
+ -- Field: Field2
+ function Get_Left_Limit (Decl : Iir_Range_Expression) return Iir;
+ procedure Set_Left_Limit (Decl : Iir_Range_Expression; Limit : Iir);
+
+ -- Field: Field3
+ function Get_Right_Limit (Decl : Iir_Range_Expression) return Iir;
+ procedure Set_Right_Limit (Decl : Iir_Range_Expression; Limit : Iir);
+
+ -- Field: Field4 Ref
+ function Get_Base_Type (Decl : Iir) return Iir;
+ procedure Set_Base_Type (Decl : Iir; Base_Type : Iir);
+ pragma Inline (Get_Base_Type);
+
+ -- Either a resolution function name, an array_element_resolution or a
+ -- record_resolution
+ -- Field: Field5
+ function Get_Resolution_Indication (Decl : Iir) return Iir;
+ procedure Set_Resolution_Indication (Decl : Iir; Ind : Iir);
+
+ -- Field: Field1 Chain
+ function Get_Record_Element_Resolution_Chain (Res : Iir) return Iir;
+ procedure Set_Record_Element_Resolution_Chain (Res : Iir; Chain : Iir);
+
+ -- Field: Field7
+ function Get_Tolerance (Def : Iir) return Iir;
+ procedure Set_Tolerance (Def : Iir; Tol : Iir);
+
+ -- Field: Field8
+ function Get_Plus_Terminal (Def : Iir) return Iir;
+ procedure Set_Plus_Terminal (Def : Iir; Terminal : Iir);
+
+ -- Field: Field9
+ function Get_Minus_Terminal (Def : Iir) return Iir;
+ procedure Set_Minus_Terminal (Def : Iir; Terminal : Iir);
+
+ -- Field: Field5
+ function Get_Simultaneous_Left (Def : Iir) return Iir;
+ procedure Set_Simultaneous_Left (Def : Iir; Expr : Iir);
+
+ -- Field: Field6
+ function Get_Simultaneous_Right (Def : Iir) return Iir;
+ procedure Set_Simultaneous_Right (Def : Iir; Expr : Iir);
+
+ -- True if ATYPE defines std.textio.text file type.
+ -- Field: Flag4
+ function Get_Text_File_Flag (Atype : Iir) return Boolean;
+ procedure Set_Text_File_Flag (Atype : Iir; Flag : Boolean);
+
+ -- True if enumeration type ATYPE has only character literals.
+ -- Field: Flag4
+ function Get_Only_Characters_Flag (Atype : Iir) return Boolean;
+ procedure Set_Only_Characters_Flag (Atype : Iir; Flag : Boolean);
+
+ -- Field: State1 (pos)
+ function Get_Type_Staticness (Atype : Iir) return Iir_Staticness;
+ procedure Set_Type_Staticness (Atype : Iir; Static : Iir_Staticness);
+
+ -- Field: State2 (pos)
+ function Get_Constraint_State (Atype : Iir) return Iir_Constraint;
+ procedure Set_Constraint_State (Atype : Iir; State : Iir_Constraint);
+
+ -- Reference either index_subtype_definition_list of array_type_definition
+ -- or index_constraint_list of array_subtype_definition.
+ -- Field: Field9 Ref (uc)
+ function Get_Index_Subtype_List (Decl : Iir) return Iir_List;
+ procedure Set_Index_Subtype_List (Decl : Iir; List : Iir_List);
+
+ -- List of type marks for indexes type of array types.
+ -- Field: Field6 (uc)
+ function Get_Index_Subtype_Definition_List (Def : Iir) return Iir_List;
+ procedure Set_Index_Subtype_Definition_List (Def : Iir; Idx : Iir_List);
+
+ -- The subtype_indication as it appears in a array type declaration.
+ -- Field: Field2
+ function Get_Element_Subtype_Indication (Decl : Iir) return Iir;
+ procedure Set_Element_Subtype_Indication (Decl : Iir; Sub_Type : Iir);
+
+ -- Field: Field1 Ref
+ function Get_Element_Subtype (Decl : Iir) return Iir;
+ procedure Set_Element_Subtype (Decl : Iir; Sub_Type : Iir);
+
+ -- Field: Field6 (uc)
+ function Get_Index_Constraint_List (Def : Iir) return Iir_List;
+ procedure Set_Index_Constraint_List (Def : Iir; List : Iir_List);
+
+ -- Field: Field8
+ function Get_Array_Element_Constraint (Def : Iir) return Iir;
+ procedure Set_Array_Element_Constraint (Def : Iir; El : Iir);
+
+ -- Chains of elements of a record.
+ -- Field: Field1 (uc)
+ function Get_Elements_Declaration_List (Decl : Iir) return Iir_List;
+ procedure Set_Elements_Declaration_List (Decl : Iir; List : Iir_List);
+
+ -- Field: Field1 Ref
+ function Get_Designated_Type (Target : Iir) return Iir;
+ procedure Set_Designated_Type (Target : Iir; Dtype : Iir);
+
+ -- Field: Field5
+ function Get_Designated_Subtype_Indication (Target : Iir) return Iir;
+ procedure Set_Designated_Subtype_Indication (Target : Iir; Dtype : Iir);
+
+ -- List of indexes for indexed name.
+ -- Field: Field2 (uc)
+ function Get_Index_List (Decl : Iir) return Iir_List;
+ procedure Set_Index_List (Decl : Iir; List : Iir_List);
+
+ -- The terminal declaration for the reference (ground) of a nature
+ -- Field: Field2
+ function Get_Reference (Def : Iir) return Iir;
+ procedure Set_Reference (Def : Iir; Ref : Iir);
+
+ -- Field: Field3
+ function Get_Nature_Declarator (Def : Iir) return Iir;
+ procedure Set_Nature_Declarator (Def : Iir; Decl : Iir);
+
+ -- Field: Field7
+ function Get_Across_Type (Def : Iir) return Iir;
+ procedure Set_Across_Type (Def : Iir; Atype : Iir);
+
+ -- Field: Field8
+ function Get_Through_Type (Def : Iir) return Iir;
+ procedure Set_Through_Type (Def : Iir; Atype : Iir);
+
+ -- Field: Field1
+ function Get_Target (Target : Iir) return Iir;
+ procedure Set_Target (Target : Iir; Atarget : Iir);
+
+ -- Field: Field5 Chain
+ function Get_Waveform_Chain (Target : Iir) return Iir;
+ procedure Set_Waveform_Chain (Target : Iir; Chain : Iir);
+
+ -- Field: Field8
+ function Get_Guard (Target : Iir) return Iir;
+ procedure Set_Guard (Target : Iir; Guard : Iir);
+
+ -- Field: Field12 (pos)
+ function Get_Delay_Mechanism (Target : Iir) return Iir_Delay_Mechanism;
+ procedure Set_Delay_Mechanism (Target : Iir; Kind : Iir_Delay_Mechanism);
+
+ -- Field: Field6
+ function Get_Reject_Time_Expression (Target : Iir) return Iir;
+ procedure Set_Reject_Time_Expression (Target : Iir; Expr : Iir);
+
+ -- Field: Field6 (uc)
+ function Get_Sensitivity_List (Wait : Iir) return Iir_List;
+ procedure Set_Sensitivity_List (Wait : Iir; List : Iir_List);
+
+ -- Field: Field8
+ function Get_Process_Origin (Proc : Iir) return Iir;
+ procedure Set_Process_Origin (Proc : Iir; Orig : Iir);
+
+ -- Field: Field5
+ function Get_Condition_Clause (Wait : Iir_Wait_Statement) return Iir;
+ procedure Set_Condition_Clause (Wait : Iir_Wait_Statement; Cond : Iir);
+
+ -- Field: Field1
+ function Get_Timeout_Clause (Wait : Iir_Wait_Statement) return Iir;
+ procedure Set_Timeout_Clause (Wait : Iir_Wait_Statement; Timeout : Iir);
+
+ -- If set, the concurrent statement is postponed.
+ -- Field: Flag3
+ function Get_Postponed_Flag (Target : Iir) return Boolean;
+ procedure Set_Postponed_Flag (Target : Iir; Value : Boolean);
+
+ -- Returns the list of subprogram called in this subprogram or process.
+ -- Note: implicit function (such as implicit operators) are omitted
+ -- from this list, since the purpose of this list is to correctly set
+ -- flags for side effects (purity_state, wait_state).
+ -- Can return null_iir if there is no subprogram called.
+ -- Field: Field7 Of_Ref (uc)
+ function Get_Callees_List (Proc : Iir) return Iir_List;
+ procedure Set_Callees_List (Proc : Iir; List : Iir_List);
+
+ -- Get/Set the passive flag of a process.
+ -- TRUE if the process must be passive.
+ -- FALSE if the process may be not passive.
+ -- For a procedure declaration, set if it is passive.
+ -- Field: Flag2
+ function Get_Passive_Flag (Proc : Iir) return Boolean;
+ procedure Set_Passive_Flag (Proc : Iir; Flag : Boolean);
+
+ -- True if the function is used as a resolution function.
+ -- Field: Flag7
+ function Get_Resolution_Function_Flag (Func : Iir) return Boolean;
+ procedure Set_Resolution_Function_Flag (Func : Iir; Flag : Boolean);
+
+ -- Get/Set the wait state of the current subprogram or process.
+ -- TRUE if it contains a wait statement, either directly or
+ -- indirectly.
+ -- FALSE if it doesn't contain a wait statement.
+ -- UNKNOWN if the wait status is not yet known.
+ -- Field: State1 (pos)
+ function Get_Wait_State (Proc : Iir) return Tri_State_Type;
+ procedure Set_Wait_State (Proc : Iir; State : Tri_State_Type);
+
+ -- Get/Set wether the subprogram may be called by a sensitized process
+ -- whose sensitivity list is ALL.
+ -- FALSE if declared in a package unit and reads a signal that is not
+ -- one of its interface, or if it calls such a subprogram.
+ -- TRUE if it doesn't call a subprogram whose state is False and
+ -- either doesn't read a signal or declared within an entity or
+ -- architecture.
+ -- UNKNOWN if the status is not yet known.
+ -- Field: State3 (pos)
+ function Get_All_Sensitized_State (Proc : Iir) return Iir_All_Sensitized;
+ procedure Set_All_Sensitized_State (Proc : Iir; State : Iir_All_Sensitized);
+
+ -- Get/Set the seen flag.
+ -- Used when the graph of callees is walked, to avoid infinite loops, since
+ -- the graph is not a DAG (there may be cycles).
+ -- Field: Flag1
+ function Get_Seen_Flag (Proc : Iir) return Boolean;
+ procedure Set_Seen_Flag (Proc : Iir; Flag : Boolean);
+
+ -- Get/Set the pure flag of a function.
+ -- TRUE if the function is declared pure.
+ -- FALSE if the function is declared impure.
+ -- Field: Flag2
+ function Get_Pure_Flag (Func : Iir) return Boolean;
+ procedure Set_Pure_Flag (Func : Iir; Flag : Boolean);
+
+ -- Get/Set the foreign flag of a declaration.
+ -- TRUE if the declaration was decored with the std.foreign attribute.
+ -- Field: Flag3
+ function Get_Foreign_Flag (Decl : Iir) return Boolean;
+ procedure Set_Foreign_Flag (Decl : Iir; Flag : Boolean);
+
+ -- Get/Set the resolved flag of a subtype definition.
+ -- A subtype definition may be resolved either because a
+ -- resolution_indication is present in the subtype_indication, or
+ -- because all elements type are resolved.
+ -- Field: Flag1
+ function Get_Resolved_Flag (Atype : Iir) return Boolean;
+ procedure Set_Resolved_Flag (Atype : Iir; Flag : Boolean);
+
+ -- Get/Set the signal_type flag of a type/subtype definition.
+ -- This flags indicates whether the type can be used as a signal type.
+ -- Access types, file types and composite types whose a sub-element is
+ -- an access type cannot be used as a signal type.
+ -- Field: Flag2
+ function Get_Signal_Type_Flag (Atype : Iir) return Boolean;
+ procedure Set_Signal_Type_Flag (Atype : Iir; Flag : Boolean);
+
+ -- True if ATYPE is used to declare a signal or to handle a signal
+ -- (such as slice or aliases).
+ -- Field: Flag3
+ function Get_Has_Signal_Flag (Atype : Iir) return Boolean;
+ procedure Set_Has_Signal_Flag (Atype : Iir; Flag : Boolean);
+
+ -- Get/Set the purity status of a subprogram.
+ -- Field: State2 (pos)
+ function Get_Purity_State (Proc : Iir) return Iir_Pure_State;
+ procedure Set_Purity_State (Proc : Iir; State : Iir_Pure_State);
+
+ -- Set during binding when DESIGN is added in a list of file to bind.
+ -- Field: Flag3
+ function Get_Elab_Flag (Design : Iir) return Boolean;
+ procedure Set_Elab_Flag (Design : Iir; Flag : Boolean);
+
+ -- Set on an array_subtype if there is an index constraint.
+ -- If not set, the subtype is unconstrained.
+ -- Field: Flag4
+ function Get_Index_Constraint_Flag (Atype : Iir) return Boolean;
+ procedure Set_Index_Constraint_Flag (Atype : Iir; Flag : Boolean);
+
+ -- Condition of an assertion.
+ -- Field: Field1
+ function Get_Assertion_Condition (Target : Iir) return Iir;
+ procedure Set_Assertion_Condition (Target : Iir; Cond : Iir);
+
+ -- Report expression of an assertion or report statement.
+ -- Field: Field6
+ function Get_Report_Expression (Target : Iir) return Iir;
+ procedure Set_Report_Expression (Target : Iir; Expr : Iir);
+
+ -- Severity expression of an assertion or report statement.
+ -- Field: Field5
+ function Get_Severity_Expression (Target : Iir) return Iir;
+ procedure Set_Severity_Expression (Target : Iir; Expr : Iir);
+
+ -- Instantiated unit of a component instantiation statement.
+ -- Field: Field1
+ function Get_Instantiated_Unit (Target : Iir) return Iir;
+ procedure Set_Instantiated_Unit (Target : Iir; Unit : Iir);
+
+ -- Generic map aspect list.
+ -- Field: Field8 Chain
+ function Get_Generic_Map_Aspect_Chain (Target : Iir) return Iir;
+ procedure Set_Generic_Map_Aspect_Chain (Target : Iir; Generics : Iir);
+
+ -- Port map aspect list.
+ -- Field: Field9 Chain
+ function Get_Port_Map_Aspect_Chain (Target : Iir) return Iir;
+ procedure Set_Port_Map_Aspect_Chain (Target : Iir; Port : Iir);
+
+ -- Configuration of an entity_aspect_configuration.
+ -- Field: Field1
+ function Get_Configuration_Name (Target : Iir) return Iir;
+ procedure Set_Configuration_Name (Target : Iir; Conf : Iir);
+
+ -- Component configuration for a component_instantiation_statement.
+ -- Field: Field6
+ function Get_Component_Configuration (Target : Iir) return Iir;
+ procedure Set_Component_Configuration (Target : Iir; Conf : Iir);
+
+ -- Configuration specification for a component_instantiation_statement.
+ -- Field: Field7
+ function Get_Configuration_Specification (Target : Iir) return Iir;
+ procedure Set_Configuration_Specification (Target : Iir; Conf : Iir);
+
+ -- Set/Get the default binding indication of a configuration specification
+ -- or a component configuration.
+ -- Field: Field5
+ function Get_Default_Binding_Indication (Target : Iir) return Iir;
+ procedure Set_Default_Binding_Indication (Target : Iir; Conf : Iir);
+
+ -- Set/Get the default configuration of an architecture.
+ -- Field: Field6
+ function Get_Default_Configuration_Declaration (Target : Iir) return Iir;
+ procedure Set_Default_Configuration_Declaration (Target : Iir; Conf : Iir);
+
+ -- Expression for an various nodes.
+ -- Field: Field5
+ function Get_Expression (Target : Iir) return Iir;
+ procedure Set_Expression (Target : Iir; Expr : Iir);
+
+ -- Set to the designated type (either the type of the expression or the
+ -- subtype) when the expression is analyzed.
+ -- Field: Field2 Ref
+ function Get_Allocator_Designated_Type (Target : Iir) return Iir;
+ procedure Set_Allocator_Designated_Type (Target : Iir; A_Type : Iir);
+
+ -- Field: Field7 Chain
+ function Get_Selected_Waveform_Chain (Target : Iir) return Iir;
+ procedure Set_Selected_Waveform_Chain (Target : Iir; Chain : Iir);
+
+ -- Field: Field7 Chain
+ function Get_Conditional_Waveform_Chain (Target : Iir) return Iir;
+ procedure Set_Conditional_Waveform_Chain (Target : Iir; Chain : Iir);
+
+ -- Expression defining the value of the implicit guard signal.
+ -- Field: Field2
+ function Get_Guard_Expression (Target : Iir) return Iir;
+ procedure Set_Guard_Expression (Target : Iir; Expr : Iir);
+
+ -- The declaration (if any) of the implicit guard signal of a block
+ -- statement.
+ -- Field: Field8
+ function Get_Guard_Decl (Target : Iir_Block_Statement) return Iir;
+ procedure Set_Guard_Decl (Target : Iir_Block_Statement; Decl : Iir);
+
+ -- Sensitivity list for the implicit guard signal.
+ -- Field: Field6 (uc)
+ function Get_Guard_Sensitivity_List (Guard : Iir) return Iir_List;
+ procedure Set_Guard_Sensitivity_List (Guard : Iir; List : Iir_List);
+
+ -- Block_Configuration that applies to this block statement.
+ -- Field: Field6
+ function Get_Block_Block_Configuration (Block : Iir) return Iir;
+ procedure Set_Block_Block_Configuration (Block : Iir; Conf : Iir);
+
+ -- Field: Field5
+ function Get_Package_Header (Pkg : Iir) return Iir;
+ procedure Set_Package_Header (Pkg : Iir; Header : Iir);
+
+ -- Field: Field7
+ function Get_Block_Header (Target : Iir) return Iir;
+ procedure Set_Block_Header (Target : Iir; Header : Iir);
+
+ -- Field: Field5
+ function Get_Uninstantiated_Package_Name (Inst : Iir) return Iir;
+ procedure Set_Uninstantiated_Package_Name (Inst : Iir; Name : Iir);
+
+ -- Get/Set the block_configuration (there may be several
+ -- block_configuration through the use of prev_configuration singly linked
+ -- list) that apply to this generate statement.
+ -- Field: Field7
+ function Get_Generate_Block_Configuration (Target : Iir) return Iir;
+ procedure Set_Generate_Block_Configuration (Target : Iir; Conf : Iir);
+
+ -- Field: Field6
+ function Get_Generation_Scheme (Target : Iir) return Iir;
+ procedure Set_Generation_Scheme (Target : Iir; Scheme : Iir);
+
+ -- Condition of a conditionam_waveform, if_statement, elsif,
+ -- while_loop_statement, next_statement or exit_statement.
+ -- Field: Field1
+ function Get_Condition (Target : Iir) return Iir;
+ procedure Set_Condition (Target : Iir; Condition : Iir);
+
+ -- Field: Field6
+ function Get_Else_Clause (Target : Iir) return Iir;
+ procedure Set_Else_Clause (Target : Iir; Clause : Iir);
+
+ -- Iterator of a for_loop_statement.
+ -- Field: Field1
+ function Get_Parameter_Specification (Target : Iir) return Iir;
+ procedure Set_Parameter_Specification (Target : Iir; Param : Iir);
+
+ -- Get/Set the statement in which TARGET appears. This is used to check
+ -- if next/exit is in a loop.
+ -- Field: Field0 Ref
+ function Get_Parent (Target : Iir) return Iir;
+ procedure Set_Parent (Target : Iir; Parent : Iir);
+
+ -- Loop label for an exit_statement or next_statement.
+ -- Field: Field5
+ function Get_Loop_Label (Target : Iir) return Iir;
+ procedure Set_Loop_Label (Target : Iir; Stmt : Iir);
+
+ -- Component name for a component_configuration or
+ -- a configuration_specification.
+ -- Field: Field4
+ function Get_Component_Name (Target : Iir) return Iir;
+ procedure Set_Component_Name (Target : Iir; Name : Iir);
+
+ -- Field: Field1 (uc)
+ function Get_Instantiation_List (Target : Iir) return Iir_List;
+ procedure Set_Instantiation_List (Target : Iir; List : Iir_List);
+
+ -- Field: Field3
+ function Get_Entity_Aspect (Target : Iir_Binding_Indication) return Iir;
+ procedure Set_Entity_Aspect (Target : Iir_Binding_Indication; Entity : Iir);
+
+ -- Field: Field1
+ function Get_Default_Entity_Aspect (Target : Iir) return Iir;
+ procedure Set_Default_Entity_Aspect (Target : Iir; Aspect : Iir);
+
+ -- Field: Field6 Chain
+ function Get_Default_Generic_Map_Aspect_Chain (Target : Iir) return Iir;
+ procedure Set_Default_Generic_Map_Aspect_Chain (Target : Iir; Chain : Iir);
+
+ -- Field: Field7 Chain
+ function Get_Default_Port_Map_Aspect_Chain (Target : Iir) return Iir;
+ procedure Set_Default_Port_Map_Aspect_Chain (Target : Iir; Chain : Iir);
+
+ -- Field: Field3
+ function Get_Binding_Indication (Target : Iir) return Iir;
+ procedure Set_Binding_Indication (Target : Iir; Binding : Iir);
+
+ -- The named entity designated by a name.
+ -- Field: Field4 Ref
+ function Get_Named_Entity (Name : Iir) return Iir;
+ procedure Set_Named_Entity (Name : Iir; Val : Iir);
+
+ -- If a name designate a non-object alias, the designated alias.
+ -- Named_Entity will designate the aliased entity.
+ -- Field: Field2
+ function Get_Alias_Declaration (Name : Iir) return Iir;
+ procedure Set_Alias_Declaration (Name : Iir; Val : Iir);
+
+ -- Expression staticness, defined by rules of LRM 7.4
+ -- Field: State1 (pos)
+ function Get_Expr_Staticness (Target : Iir) return Iir_Staticness;
+ procedure Set_Expr_Staticness (Target : Iir; Static : Iir_Staticness);
+
+ -- Node which couldn't be correctly analyzed.
+ -- Field: Field2
+ function Get_Error_Origin (Target : Iir) return Iir;
+ procedure Set_Error_Origin (Target : Iir; Origin : Iir);
+
+ -- Operand of a monadic operator.
+ -- Field: Field2
+ function Get_Operand (Target : Iir) return Iir;
+ procedure Set_Operand (Target : Iir; An_Iir : Iir);
+
+ -- Left operand of a dyadic operator.
+ -- Field: Field2
+ function Get_Left (Target : Iir) return Iir;
+ procedure Set_Left (Target : Iir; An_Iir : Iir);
+
+ -- Right operand of a dyadic operator.
+ -- Field: Field4
+ function Get_Right (Target : Iir) return Iir;
+ procedure Set_Right (Target : Iir; An_Iir : Iir);
+
+ -- Field: Field3
+ function Get_Unit_Name (Target : Iir) return Iir;
+ procedure Set_Unit_Name (Target : Iir; Name : Iir);
+
+ -- Field: Field4
+ function Get_Name (Target : Iir) return Iir;
+ procedure Set_Name (Target : Iir; Name : Iir);
+
+ -- Field: Field5
+ function Get_Group_Template_Name (Target : Iir) return Iir;
+ procedure Set_Group_Template_Name (Target : Iir; Name : Iir);
+
+ -- Staticness of a name, according to rules of LRM 6.1
+ -- Field: State2 (pos)
+ function Get_Name_Staticness (Target : Iir) return Iir_Staticness;
+ procedure Set_Name_Staticness (Target : Iir; Static : Iir_Staticness);
+
+ -- Prefix of a name.
+ -- Field: Field0
+ function Get_Prefix (Target : Iir) return Iir;
+ procedure Set_Prefix (Target : Iir; Prefix : Iir);
+
+ -- Prefix of a name signature
+ -- Field: Field1 Ref
+ function Get_Signature_Prefix (Sign : Iir) return Iir;
+ procedure Set_Signature_Prefix (Sign : Iir; Prefix : Iir);
+
+ -- The subtype of a slice. Contrary to the Type field, this is not a
+ -- reference.
+ -- Field: Field3
+ function Get_Slice_Subtype (Slice : Iir) return Iir;
+ procedure Set_Slice_Subtype (Slice : Iir; Atype : Iir);
+
+ -- Suffix of a slice or attribute.
+ -- Field: Field2
+ function Get_Suffix (Target : Iir) return Iir;
+ procedure Set_Suffix (Target : Iir; Suffix : Iir);
+
+ -- Set the designated index subtype of an array attribute.
+ -- Field: Field2
+ function Get_Index_Subtype (Attr : Iir) return Iir;
+ procedure Set_Index_Subtype (Attr : Iir; St : Iir);
+
+ -- Parameter of an attribute.
+ -- Field: Field4
+ function Get_Parameter (Target : Iir) return Iir;
+ procedure Set_Parameter (Target : Iir; Param : Iir);
+
+ -- Type of the actual for an association by individual.
+ -- Unless the formal is an unconstrained array type, this is the same as
+ -- the formal type.
+ -- Field: Field3
+ function Get_Actual_Type (Target : Iir) return Iir;
+ procedure Set_Actual_Type (Target : Iir; Atype : Iir);
+
+ -- Interface for a package association.
+ -- Field: Field4 Ref
+ function Get_Associated_Interface (Assoc : Iir) return Iir;
+ procedure Set_Associated_Interface (Assoc : Iir; Inter : Iir);
+
+ -- List of individual associations for association_element_by_individual.
+ -- Associations for parenthesis_name.
+ -- Field: Field2 Chain
+ function Get_Association_Chain (Target : Iir) return Iir;
+ procedure Set_Association_Chain (Target : Iir; Chain : Iir);
+
+ -- List of individual associations for association_element_by_individual.
+ -- Field: Field4 Chain
+ function Get_Individual_Association_Chain (Target : Iir) return Iir;
+ procedure Set_Individual_Association_Chain (Target : Iir; Chain : Iir);
+
+ -- Get/Set info for the aggregate.
+ -- There is one aggregate_info for for each dimension.
+ -- Field: Field2
+ function Get_Aggregate_Info (Target : Iir) return Iir;
+ procedure Set_Aggregate_Info (Target : Iir; Info : Iir);
+
+ -- Get/Set the info node for the next dimension.
+ -- Field: Field1
+ function Get_Sub_Aggregate_Info (Target : Iir) return Iir;
+ procedure Set_Sub_Aggregate_Info (Target : Iir; Info : Iir);
+
+ -- TRUE when the length of the aggregate is not locally static.
+ -- Field: Flag3
+ function Get_Aggr_Dynamic_Flag (Target : Iir) return Boolean;
+ procedure Set_Aggr_Dynamic_Flag (Target : Iir; Val : Boolean);
+
+ -- Get/Set the minimum number of elements for the lowest dimension of
+ -- the aggregate or for the current dimension of a sub-aggregate.
+ -- The real number of elements may be greater than this number if there
+ -- is an 'other' choice.
+ -- Field: Field4 (uc)
+ function Get_Aggr_Min_Length (Info : Iir_Aggregate_Info) return Iir_Int32;
+ procedure Set_Aggr_Min_Length (Info : Iir_Aggregate_Info; Nbr : Iir_Int32);
+
+ -- Highest index choice, if any.
+ -- Field: Field2
+ function Get_Aggr_Low_Limit (Target : Iir_Aggregate_Info) return Iir;
+ procedure Set_Aggr_Low_Limit (Target : Iir_Aggregate_Info; Limit : Iir);
+
+ -- Highest index choice, if any.
+ -- Field: Field3
+ function Get_Aggr_High_Limit (Target : Iir_Aggregate_Info) return Iir;
+ procedure Set_Aggr_High_Limit (Target : Iir_Aggregate_Info; Limit : Iir);
+
+ -- True if the aggregate has an 'others' choice.
+ -- Field: Flag2
+ function Get_Aggr_Others_Flag (Target : Iir_Aggregate_Info) return Boolean;
+ procedure Set_Aggr_Others_Flag (Target : Iir_Aggregate_Info; Val : Boolean);
+
+ -- True if the aggregate have named associations.
+ -- Field: Flag4
+ function Get_Aggr_Named_Flag (Target : Iir_Aggregate_Info) return Boolean;
+ procedure Set_Aggr_Named_Flag (Target : Iir_Aggregate_Info; Val : Boolean);
+
+ -- Staticness of the expressions in an aggregate.
+ -- We can't use expr_staticness for this purpose, since the staticness
+ -- of an aggregate is at most globally.
+ -- Field: State2 (pos)
+ function Get_Value_Staticness (Target : Iir) return Iir_Staticness;
+ procedure Set_Value_Staticness (Target : Iir; Staticness : Iir_Staticness);
+
+ -- Chain of choices.
+ -- Field: Field4 Chain
+ function Get_Association_Choices_Chain (Target : Iir) return Iir;
+ procedure Set_Association_Choices_Chain (Target : Iir; Chain : Iir);
+
+ -- Chain of choices.
+ -- Field: Field1 Chain
+ function Get_Case_Statement_Alternative_Chain (Target : Iir) return Iir;
+ procedure Set_Case_Statement_Alternative_Chain (Target : Iir; Chain : Iir);
+
+ -- Staticness of the choice.
+ -- Field: State2 (pos)
+ function Get_Choice_Staticness (Target : Iir) return Iir_Staticness;
+ procedure Set_Choice_Staticness (Target : Iir; Staticness : Iir_Staticness);
+
+ -- Field: Field1
+ function Get_Procedure_Call (Stmt : Iir) return Iir;
+ procedure Set_Procedure_Call (Stmt : Iir; Call : Iir);
+
+ -- Subprogram to be called by a procedure, function call or operator. This
+ -- is the declaration of the subprogram (or a list of during analysis).
+ -- Field: Field3 Ref
+ function Get_Implementation (Target : Iir) return Iir;
+ procedure Set_Implementation (Target : Iir; Decl : Iir);
+
+ -- Paramater associations for procedure and function call.
+ -- Field: Field2 Chain
+ function Get_Parameter_Association_Chain (Target : Iir) return Iir;
+ procedure Set_Parameter_Association_Chain (Target : Iir; Chain : Iir);
+
+ -- Object of a method call. NULL_IIR if the subprogram is not a method.
+ -- Field: Field4
+ function Get_Method_Object (Target : Iir) return Iir;
+ procedure Set_Method_Object (Target : Iir; Object : Iir);
+
+ -- The type_mark that appeared in the subtype indication. This is a name.
+ -- May be null_iir if there is no type mark (as in an iterator).
+ -- Field: Field2
+ function Get_Subtype_Type_Mark (Target : Iir) return Iir;
+ procedure Set_Subtype_Type_Mark (Target : Iir; Mark : Iir);
+
+ -- Field: Field3
+ function Get_Type_Conversion_Subtype (Target : Iir) return Iir;
+ procedure Set_Type_Conversion_Subtype (Target : Iir; Atype : Iir);
+
+ -- The type_mark that appeared in qualified expressions or type
+ -- conversions.
+ -- Field: Field4
+ function Get_Type_Mark (Target : Iir) return Iir;
+ procedure Set_Type_Mark (Target : Iir; Mark : Iir);
+
+ -- The type of values for a type file.
+ -- Field: Field2
+ function Get_File_Type_Mark (Target : Iir) return Iir;
+ procedure Set_File_Type_Mark (Target : Iir; Mark : Iir);
+
+ -- Field: Field8
+ function Get_Return_Type_Mark (Target : Iir) return Iir;
+ procedure Set_Return_Type_Mark (Target : Iir; Mark : Iir);
+
+ -- Get/set the lexical layout of an interface.
+ -- Field: Odigit2 (pos)
+ function Get_Lexical_Layout (Decl : Iir) return Iir_Lexical_Layout_Type;
+ procedure Set_Lexical_Layout (Decl : Iir; Lay : Iir_Lexical_Layout_Type);
+
+ -- List of use (designated type of access types) of an incomplete type
+ -- definition. The purpose is to complete the uses with the full type
+ -- definition.
+ -- Field: Field2 (uc)
+ function Get_Incomplete_Type_List (Target : Iir) return Iir_List;
+ procedure Set_Incomplete_Type_List (Target : Iir; List : Iir_List);
+
+ -- This flag is set on a signal_declaration, when a disconnection
+ -- specification applies to the signal (or a subelement of it).
+ -- This is used to check 'others' and 'all' designators.
+ -- Field: Flag1
+ function Get_Has_Disconnect_Flag (Target : Iir) return Boolean;
+ procedure Set_Has_Disconnect_Flag (Target : Iir; Val : Boolean);
+
+ -- This flag is set on a signal when its activity is read by the user.
+ -- Some signals handling can be optimized when this flag is set.
+ -- Field: Flag2
+ function Get_Has_Active_Flag (Target : Iir) return Boolean;
+ procedure Set_Has_Active_Flag (Target : Iir; Val : Boolean);
+
+ -- This flag is set is code being analyzed is textually within TARGET.
+ -- This is used for selected by name rule.
+ -- Field: Flag5
+ function Get_Is_Within_Flag (Target : Iir) return Boolean;
+ procedure Set_Is_Within_Flag (Target : Iir; Val : Boolean);
+
+ -- List of type_mark for an Iir_Kind_Signature
+ -- Field: Field2 (uc)
+ function Get_Type_Marks_List (Target : Iir) return Iir_List;
+ procedure Set_Type_Marks_List (Target : Iir; List : Iir_List);
+
+ -- Field: Flag1
+ function Get_Implicit_Alias_Flag (Decl : Iir) return Boolean;
+ procedure Set_Implicit_Alias_Flag (Decl : Iir; Flag : Boolean);
+
+ -- Field: Field5
+ function Get_Alias_Signature (Alias : Iir) return Iir;
+ procedure Set_Alias_Signature (Alias : Iir; Signature : Iir);
+
+ -- Field: Field2
+ function Get_Attribute_Signature (Attr : Iir) return Iir;
+ procedure Set_Attribute_Signature (Attr : Iir; Signature : Iir);
+
+ -- Field: Field1 Of_Ref (uc)
+ function Get_Overload_List (Target : Iir) return Iir_List;
+ procedure Set_Overload_List (Target : Iir; List : Iir_List);
+
+ -- Identifier of the simple_name attribute.
+ -- Field: Field3 (uc)
+ function Get_Simple_Name_Identifier (Target : Iir) return Name_Id;
+ procedure Set_Simple_Name_Identifier (Target : Iir; Ident : Name_Id);
+
+ -- Subtype for Simple_Name attribute.
+ -- Field: Field4
+ function Get_Simple_Name_Subtype (Target : Iir) return Iir;
+ procedure Set_Simple_Name_Subtype (Target : Iir; Atype : Iir);
+
+ -- Body of a protected type declaration.
+ -- Field: Field2
+ function Get_Protected_Type_Body (Target : Iir) return Iir;
+ procedure Set_Protected_Type_Body (Target : Iir; Bod : Iir);
+
+ -- Corresponsing protected type declaration of a protected type body.
+ -- Field: Field4
+ function Get_Protected_Type_Declaration (Target : Iir) return Iir;
+ procedure Set_Protected_Type_Declaration (Target : Iir; Decl : Iir);
+
+ -- Location of the 'end' token.
+ -- Field: Field6 (uc)
+ function Get_End_Location (Target : Iir) return Location_Type;
+ procedure Set_End_Location (Target : Iir; Loc : Location_Type);
+
+ -- For a string literal: the string identifier.
+ -- Field: Field3 (uc)
+ function Get_String_Id (Lit : Iir) return String_Id;
+ procedure Set_String_Id (Lit : Iir; Id : String_Id);
+
+ -- For a string literal: the string length.
+ -- Field: Field4 (uc)
+ function Get_String_Length (Lit : Iir) return Int32;
+ procedure Set_String_Length (Lit : Iir; Len : Int32);
+
+ -- For a declaration: true if the declaration is used somewhere.
+ -- Field: Flag6
+ function Get_Use_Flag (Decl : Iir) return Boolean;
+ procedure Set_Use_Flag (Decl : Iir; Val : Boolean);
+
+ -- Layout flag: true if 'end' is followed by the reserved identifier.
+ -- Field: Flag8
+ function Get_End_Has_Reserved_Id (Decl : Iir) return Boolean;
+ procedure Set_End_Has_Reserved_Id (Decl : Iir; Flag : Boolean);
+
+ -- Layout flag: true if 'end' is followed by the identifier.
+ -- Field: Flag9
+ function Get_End_Has_Identifier (Decl : Iir) return Boolean;
+ procedure Set_End_Has_Identifier (Decl : Iir; Flag : Boolean);
+
+ -- Layout flag: true if 'end' is followed by 'postponed'.
+ -- Field: Flag10
+ function Get_End_Has_Postponed (Decl : Iir) return Boolean;
+ procedure Set_End_Has_Postponed (Decl : Iir; Flag : Boolean);
+
+ -- Layout flag: true if 'begin' is present.
+ -- Field: Flag10
+ function Get_Has_Begin (Decl : Iir) return Boolean;
+ procedure Set_Has_Begin (Decl : Iir; Flag : Boolean);
+
+ -- Layout flag: true if 'is' is present.
+ -- Field: Flag7
+ function Get_Has_Is (Decl : Iir) return Boolean;
+ procedure Set_Has_Is (Decl : Iir; Flag : Boolean);
+
+ -- Layout flag: true if 'pure' or 'impure' is present.
+ -- Field: Flag8
+ function Get_Has_Pure (Decl : Iir) return Boolean;
+ procedure Set_Has_Pure (Decl : Iir; Flag : Boolean);
+
+ -- Layout flag: true if body appears just after the specification.
+ -- Field: Flag9
+ function Get_Has_Body (Decl : Iir) return Boolean;
+ procedure Set_Has_Body (Decl : Iir; Flag : Boolean);
+
+ -- Layout flag for object declaration. If True, the identifier of this
+ -- declaration is followed by an identifier (and separated by a comma).
+ -- This flag is set on all but the last declarations.
+ -- Eg: on 'signal A, B, C : Bit', the flag is set on A and B (but not C).
+ -- Field: Flag3
+ function Get_Has_Identifier_List (Decl : Iir) return Boolean;
+ procedure Set_Has_Identifier_List (Decl : Iir; Flag : Boolean);
+
+ -- Layout flag for object declaration. If True, the mode is present.
+ -- Field: Flag8
+ function Get_Has_Mode (Decl : Iir) return Boolean;
+ procedure Set_Has_Mode (Decl : Iir; Flag : Boolean);
+
+ -- Set to True if Maybe_Ref fields are references. This cannot be shared
+ -- with Has_Identifier_List as: Is_Ref is set to True on all items but
+ -- the first, while Has_Identifier_List is set to True on all items but
+ -- the last. Furthermore Is_Ref appears in nodes where Has_Identifier_List
+ -- is not present.
+ -- Field: Flag7
+ function Get_Is_Ref (N : Iir) return Boolean;
+ procedure Set_Is_Ref (N : Iir; Ref : Boolean);
+
+ -- Field: Field1 (uc)
+ function Get_Psl_Property (Decl : Iir) return PSL_Node;
+ procedure Set_Psl_Property (Decl : Iir; Prop : PSL_Node);
+
+ -- Field: Field1 (uc)
+ function Get_Psl_Declaration (Decl : Iir) return PSL_Node;
+ procedure Set_Psl_Declaration (Decl : Iir; Prop : PSL_Node);
+
+ -- Field: Field3 (uc)
+ function Get_Psl_Expression (Decl : Iir) return PSL_Node;
+ procedure Set_Psl_Expression (Decl : Iir; Prop : PSL_Node);
+
+ -- Field: Field1 (uc)
+ function Get_Psl_Boolean (N : Iir) return PSL_Node;
+ procedure Set_Psl_Boolean (N : Iir; Bool : PSL_Node);
+
+ -- Field: Field7 (uc)
+ function Get_PSL_Clock (N : Iir) return PSL_Node;
+ procedure Set_PSL_Clock (N : Iir; Clock : PSL_Node);
+
+ -- Field: Field8 (uc)
+ function Get_PSL_NFA (N : Iir) return PSL_NFA;
+ procedure Set_PSL_NFA (N : Iir; Fa : PSL_NFA);
+end Iirs;
diff --git a/src/iirs_utils.adb b/src/iirs_utils.adb
new file mode 100644
index 000000000..52c1ee8bb
--- /dev/null
+++ b/src/iirs_utils.adb
@@ -0,0 +1,1131 @@
+-- Common operations on nodes.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Scanner; use Scanner;
+with Tokens; use Tokens;
+with Errorout; use Errorout;
+with Name_Table;
+with Str_Table;
+with Std_Names; use Std_Names;
+with Flags; use Flags;
+with PSL.Nodes;
+with Sem_Inst;
+
+package body Iirs_Utils is
+ -- Transform the current token into an iir literal.
+ -- The current token must be either a character or an identifier.
+ function Current_Text return Iir is
+ Res: Iir;
+ begin
+ case Current_Token is
+ when Tok_Identifier =>
+ Res := Create_Iir (Iir_Kind_Simple_Name);
+ when Tok_Character =>
+ Res := Create_Iir (Iir_Kind_Character_Literal);
+ when others =>
+ raise Internal_Error;
+ end case;
+ Set_Identifier (Res, Current_Identifier);
+ Invalidate_Current_Identifier;
+ Invalidate_Current_Token;
+ Set_Location (Res, Get_Token_Location);
+ return Res;
+ end Current_Text;
+
+ function Is_Error (N : Iir) return Boolean is
+ begin
+ return Get_Kind (N) = Iir_Kind_Error;
+ end Is_Error;
+
+ function Get_Operator_Name (Op : Iir) return Name_Id is
+ begin
+ case Get_Kind (Op) is
+ when Iir_Kind_And_Operator
+ | Iir_Kind_Reduction_And_Operator =>
+ return Name_And;
+ when Iir_Kind_Or_Operator
+ | Iir_Kind_Reduction_Or_Operator =>
+ return Name_Or;
+ when Iir_Kind_Nand_Operator
+ | Iir_Kind_Reduction_Nand_Operator =>
+ return Name_Nand;
+ when Iir_Kind_Nor_Operator
+ | Iir_Kind_Reduction_Nor_Operator =>
+ return Name_Nor;
+ when Iir_Kind_Xor_Operator
+ | Iir_Kind_Reduction_Xor_Operator =>
+ return Name_Xor;
+ when Iir_Kind_Xnor_Operator
+ | Iir_Kind_Reduction_Xnor_Operator =>
+ return Name_Xnor;
+
+ when Iir_Kind_Equality_Operator =>
+ return Name_Op_Equality;
+ when Iir_Kind_Inequality_Operator =>
+ return Name_Op_Inequality;
+ when Iir_Kind_Less_Than_Operator =>
+ return Name_Op_Less;
+ when Iir_Kind_Less_Than_Or_Equal_Operator =>
+ return Name_Op_Less_Equal;
+ when Iir_Kind_Greater_Than_Operator =>
+ return Name_Op_Greater;
+ when Iir_Kind_Greater_Than_Or_Equal_Operator =>
+ return Name_Op_Greater_Equal;
+
+ when Iir_Kind_Match_Equality_Operator =>
+ return Name_Op_Match_Equality;
+ when Iir_Kind_Match_Inequality_Operator =>
+ return Name_Op_Match_Inequality;
+ when Iir_Kind_Match_Less_Than_Operator =>
+ return Name_Op_Match_Less;
+ when Iir_Kind_Match_Less_Than_Or_Equal_Operator =>
+ return Name_Op_Match_Less_Equal;
+ when Iir_Kind_Match_Greater_Than_Operator =>
+ return Name_Op_Match_Greater;
+ when Iir_Kind_Match_Greater_Than_Or_Equal_Operator =>
+ return Name_Op_Match_Greater_Equal;
+
+ when Iir_Kind_Sll_Operator =>
+ return Name_Sll;
+ when Iir_Kind_Sla_Operator =>
+ return Name_Sla;
+ when Iir_Kind_Srl_Operator =>
+ return Name_Srl;
+ when Iir_Kind_Sra_Operator =>
+ return Name_Sra;
+ when Iir_Kind_Rol_Operator =>
+ return Name_Rol;
+ when Iir_Kind_Ror_Operator =>
+ return Name_Ror;
+ when Iir_Kind_Addition_Operator =>
+ return Name_Op_Plus;
+ when Iir_Kind_Substraction_Operator =>
+ return Name_Op_Minus;
+ when Iir_Kind_Concatenation_Operator =>
+ return Name_Op_Concatenation;
+ when Iir_Kind_Multiplication_Operator =>
+ return Name_Op_Mul;
+ when Iir_Kind_Division_Operator =>
+ return Name_Op_Div;
+ when Iir_Kind_Modulus_Operator =>
+ return Name_Mod;
+ when Iir_Kind_Remainder_Operator =>
+ return Name_Rem;
+ when Iir_Kind_Exponentiation_Operator =>
+ return Name_Op_Exp;
+ when Iir_Kind_Not_Operator =>
+ return Name_Not;
+ when Iir_Kind_Negation_Operator =>
+ return Name_Op_Minus;
+ when Iir_Kind_Identity_Operator =>
+ return Name_Op_Plus;
+ when Iir_Kind_Absolute_Operator =>
+ return Name_Abs;
+ when Iir_Kind_Condition_Operator =>
+ return Name_Op_Condition;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Operator_Name;
+
+ function Get_Longuest_Static_Prefix (Expr: Iir) return Iir is
+ Adecl: Iir;
+ begin
+ Adecl := Expr;
+ loop
+ case Get_Kind (Adecl) is
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Interface_Variable_Declaration =>
+ return Adecl;
+ when Iir_Kind_Constant_Declaration
+ | Iir_Kind_Interface_Constant_Declaration =>
+ return Adecl;
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ return Adecl;
+ when Iir_Kind_Object_Alias_Declaration =>
+ -- LRM 4.3.3.1 Object Aliases
+ -- 2. The name must be a static name [...]
+ return Adecl;
+ when Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Element =>
+ if Get_Name_Staticness (Adecl) >= Globally then
+ return Adecl;
+ else
+ Adecl := Get_Prefix (Adecl);
+ end if;
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ Adecl := Get_Named_Entity (Adecl);
+ when Iir_Kind_Type_Conversion =>
+ return Null_Iir;
+ when others =>
+ Error_Kind ("get_longuest_static_prefix", Adecl);
+ end case;
+ end loop;
+ end Get_Longuest_Static_Prefix;
+
+ function Get_Object_Prefix (Name: Iir; With_Alias : Boolean := True)
+ return Iir
+ is
+ Adecl : Iir;
+ begin
+ Adecl := Name;
+ loop
+ case Get_Kind (Adecl) is
+ when Iir_Kind_Variable_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Iterator_Declaration =>
+ return Adecl;
+ when Iir_Kind_Object_Alias_Declaration =>
+ if With_Alias then
+ Adecl := Get_Name (Adecl);
+ else
+ return Adecl;
+ end if;
+ when Iir_Kind_Indexed_Name
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Selected_By_All_Name =>
+ Adecl := Get_Base_Name (Adecl);
+ when Iir_Kinds_Literal
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kinds_Monadic_Operator
+ | Iir_Kinds_Dyadic_Operator
+ | Iir_Kind_Function_Call
+ | Iir_Kind_Qualified_Expression
+ | Iir_Kind_Type_Conversion
+ | Iir_Kind_Allocator_By_Expression
+ | Iir_Kind_Allocator_By_Subtype
+ | Iir_Kinds_Attribute
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Aggregate
+ | Iir_Kind_Simple_Aggregate
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kinds_Concurrent_Statement =>
+ return Adecl;
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ Adecl := Get_Named_Entity (Adecl);
+ when Iir_Kind_Attribute_Name =>
+ return Get_Named_Entity (Adecl);
+ when others =>
+ Error_Kind ("get_object_prefix", Adecl);
+ end case;
+ end loop;
+ end Get_Object_Prefix;
+
+ function Get_Association_Interface (Assoc : Iir) return Iir
+ is
+ Formal : Iir;
+ begin
+ Formal := Get_Formal (Assoc);
+ loop
+ case Get_Kind (Formal) is
+ when Iir_Kind_Simple_Name =>
+ return Get_Named_Entity (Formal);
+ when Iir_Kinds_Interface_Object_Declaration =>
+ return Formal;
+ when Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Element =>
+ Formal := Get_Prefix (Formal);
+ when others =>
+ Error_Kind ("get_association_interface", Formal);
+ end case;
+ end loop;
+ end Get_Association_Interface;
+
+ function Find_Name_In_List (List: Iir_List; Lit: Name_Id) return Iir is
+ El: Iir;
+ Ident: Name_Id;
+ begin
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Ident := Get_Identifier (El);
+ if Ident = Lit then
+ return El;
+ end if;
+ end loop;
+ return Null_Iir;
+ end Find_Name_In_List;
+
+ function Find_Name_In_Chain (Chain: Iir; Lit: Name_Id) return Iir
+ is
+ El: Iir := Chain;
+ begin
+ while El /= Null_Iir loop
+ if Get_Identifier (El) = Lit then
+ return El;
+ end if;
+ El := Get_Chain (El);
+ end loop;
+ return Null_Iir;
+ end Find_Name_In_Chain;
+
+ function Is_In_Chain (Chain : Iir; El : Iir) return Boolean
+ is
+ Chain_El : Iir;
+ begin
+ Chain_El := Chain;
+ while Chain_El /= Null_Iir loop
+ if Chain_El = El then
+ return True;
+ end if;
+ Chain_El := Get_Chain (Chain_El);
+ end loop;
+ return False;
+ end Is_In_Chain;
+
+ procedure Add_Dependence (Target: Iir_Design_Unit; Unit: Iir) is
+ begin
+ -- Do not add self-dependency
+ if Unit = Target then
+ return;
+ end if;
+
+ case Get_Kind (Unit) is
+ when Iir_Kind_Design_Unit
+ | Iir_Kind_Entity_Aspect_Entity =>
+ null;
+ when others =>
+ Error_Kind ("add_dependence", Unit);
+ end case;
+
+ Add_Element (Get_Dependence_List (Target), Unit);
+ end Add_Dependence;
+
+ procedure Clear_Instantiation_Configuration_Vhdl87
+ (Parent : Iir; In_Generate : Boolean; Full : Boolean)
+ is
+ El : Iir;
+ Prev : Iir;
+ begin
+ El := Get_Concurrent_Statement_Chain (Parent);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Component_Instantiation_Statement =>
+ if In_Generate and not Full then
+ Prev := Get_Component_Configuration (El);
+ if Prev /= Null_Iir then
+ case Get_Kind (Prev) is
+ when Iir_Kind_Configuration_Specification =>
+ -- Keep it.
+ null;
+ when Iir_Kind_Component_Configuration =>
+ Set_Component_Configuration (El, Null_Iir);
+ when others =>
+ Error_Kind
+ ("clear_instantiation_configuration_vhdl87",
+ Prev);
+ end case;
+ end if;
+ else
+ Set_Component_Configuration (El, Null_Iir);
+ end if;
+ when Iir_Kind_Generate_Statement =>
+ Set_Generate_Block_Configuration (El, Null_Iir);
+ -- Clear inside a generate statement.
+ Clear_Instantiation_Configuration_Vhdl87 (El, True, Full);
+ when Iir_Kind_Block_Statement =>
+ Set_Block_Block_Configuration (El, Null_Iir);
+ when others =>
+ null;
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end Clear_Instantiation_Configuration_Vhdl87;
+
+ procedure Clear_Instantiation_Configuration (Parent : Iir; Full : Boolean)
+ is
+ El : Iir;
+ begin
+ if False and then Flags.Vhdl_Std = Vhdl_87 then
+ Clear_Instantiation_Configuration_Vhdl87
+ (Parent, Get_Kind (Parent) = Iir_Kind_Generate_Statement, Full);
+ else
+ El := Get_Concurrent_Statement_Chain (Parent);
+ while El /= Null_Iir loop
+ case Get_Kind (El) is
+ when Iir_Kind_Component_Instantiation_Statement =>
+ Set_Component_Configuration (El, Null_Iir);
+ when Iir_Kind_Generate_Statement =>
+ Set_Generate_Block_Configuration (El, Null_Iir);
+ when Iir_Kind_Block_Statement =>
+ Set_Block_Block_Configuration (El, Null_Iir);
+ when others =>
+ null;
+ end case;
+ El := Get_Chain (El);
+ end loop;
+ end if;
+ end Clear_Instantiation_Configuration;
+
+ function Get_String_Fat_Acc (Str : Iir) return String_Fat_Acc is
+ begin
+ return Str_Table.Get_String_Fat_Acc (Get_String_Id (Str));
+ end Get_String_Fat_Acc;
+
+ -- Get identifier of NODE as a string.
+ function Image_Identifier (Node : Iir) return String is
+ begin
+ return Name_Table.Image (Iirs.Get_Identifier (Node));
+ end Image_Identifier;
+
+ function Image_String_Lit (Str : Iir) return String
+ is
+ Ptr : String_Fat_Acc;
+ Len : Nat32;
+ begin
+ Ptr := Get_String_Fat_Acc (Str);
+ Len := Get_String_Length (Str);
+ return String (Ptr (1 .. Len));
+ end Image_String_Lit;
+
+ function Copy_Enumeration_Literal (Lit : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Enumeration_Literal);
+ Set_Identifier (Res, Get_Identifier (Lit));
+ Location_Copy (Res, Lit);
+ Set_Parent (Res, Get_Parent (Lit));
+ Set_Type (Res, Get_Type (Lit));
+ Set_Enum_Pos (Res, Get_Enum_Pos (Lit));
+ Set_Expr_Staticness (Res, Locally);
+ Set_Enumeration_Decl (Res, Lit);
+ return Res;
+ end Copy_Enumeration_Literal;
+
+ procedure Create_Range_Constraint_For_Enumeration_Type
+ (Def : Iir_Enumeration_Type_Definition)
+ is
+ Range_Expr : Iir_Range_Expression;
+ Literal_List : constant Iir_List := Get_Enumeration_Literal_List (Def);
+ begin
+ -- Create a constraint.
+ Range_Expr := Create_Iir (Iir_Kind_Range_Expression);
+ Location_Copy (Range_Expr, Def);
+ Set_Type (Range_Expr, Def);
+ Set_Direction (Range_Expr, Iir_To);
+ Set_Left_Limit
+ (Range_Expr,
+ Copy_Enumeration_Literal (Get_First_Element (Literal_List)));
+ Set_Right_Limit
+ (Range_Expr,
+ Copy_Enumeration_Literal (Get_Last_Element (Literal_List)));
+ Set_Expr_Staticness (Range_Expr, Locally);
+ Set_Range_Constraint (Def, Range_Expr);
+ end Create_Range_Constraint_For_Enumeration_Type;
+
+ procedure Free_Name (Node : Iir)
+ is
+ N : Iir;
+ N1 : Iir;
+ begin
+ if Node = Null_Iir then
+ return;
+ end if;
+ N := Node;
+ case Get_Kind (N) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_String_Literal
+ | Iir_Kind_Subtype_Definition =>
+ Free_Iir (N);
+ when Iir_Kind_Selected_Name
+ | Iir_Kind_Parenthesis_Name
+ | Iir_Kind_Selected_By_All_Name =>
+ N1 := Get_Prefix (N);
+ Free_Iir (N);
+ Free_Name (N1);
+ when Iir_Kind_Library_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Design_Unit
+ | Iir_Kinds_Concurrent_Statement
+ | Iir_Kinds_Sequential_Statement =>
+ return;
+ when others =>
+ Error_Kind ("free_name", Node);
+ --Free_Iir (N);
+ end case;
+ end Free_Name;
+
+ procedure Free_Recursive_List (List : Iir_List)
+ is
+ El : Iir;
+ begin
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Free_Recursive (El);
+ end loop;
+ end Free_Recursive_List;
+
+ procedure Free_Recursive (Node : Iir; Free_List : Boolean := False)
+ is
+ N : Iir;
+ begin
+ if Node = Null_Iir then
+ return;
+ end if;
+ N := Node;
+ case Get_Kind (N) is
+ when Iir_Kind_Library_Declaration =>
+ return;
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Parenthesis_Name
+ | Iir_Kind_Character_Literal =>
+ null;
+ when Iir_Kind_Enumeration_Literal =>
+ return;
+ when Iir_Kind_Selected_Name =>
+ Free_Recursive (Get_Prefix (N));
+ when Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ Free_Recursive (Get_Type (N));
+ Free_Recursive (Get_Default_Value (N));
+ when Iir_Kind_Range_Expression =>
+ Free_Recursive (Get_Left_Limit (N));
+ Free_Recursive (Get_Right_Limit (N));
+ when Iir_Kind_Subtype_Definition =>
+ Free_Recursive (Get_Base_Type (N));
+ when Iir_Kind_Integer_Literal =>
+ null;
+ when Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Configuration_Declaration =>
+ null;
+ when Iir_Kind_File_Type_Definition
+ | Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition =>
+ return;
+ when Iir_Kind_Architecture_Body =>
+ Free_Recursive (Get_Entity_Name (N));
+ when Iir_Kind_Overload_List =>
+ Free_Recursive_List (Get_Overload_List (N));
+ if not Free_List then
+ return;
+ end if;
+ when Iir_Kind_Array_Subtype_Definition =>
+ Free_Recursive_List (Get_Index_List (N));
+ Free_Recursive (Get_Base_Type (N));
+ when Iir_Kind_Entity_Aspect_Entity =>
+ Free_Recursive (Get_Entity (N));
+ Free_Recursive (Get_Architecture (N));
+ when others =>
+ Error_Kind ("free_recursive", Node);
+ end case;
+ Free_Iir (N);
+ end Free_Recursive;
+
+ function Get_Predefined_Function_Name (Func : Iir_Predefined_Functions)
+ return String
+ is
+ begin
+ return Iir_Predefined_Functions'Image (Func);
+ end Get_Predefined_Function_Name;
+
+ procedure Mark_Subprogram_Used (Subprg : Iir)
+ is
+ N : Iir;
+ begin
+ N := Subprg;
+ loop
+ exit when Get_Use_Flag (N);
+ Set_Use_Flag (N, True);
+ N := Sem_Inst.Get_Origin (N);
+ -- The origin may also be an instance.
+ exit when N = Null_Iir;
+ end loop;
+ end Mark_Subprogram_Used;
+
+ function Get_Callees_List_Holder (Subprg : Iir) return Iir is
+ begin
+ case Get_Kind (Subprg) is
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Declaration =>
+ return Get_Subprogram_Body (Subprg);
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ return Subprg;
+ when others =>
+ Error_Kind ("get_callees_list_holder", Subprg);
+ end case;
+ end Get_Callees_List_Holder;
+
+ procedure Clear_Seen_Flag (Top : Iir)
+ is
+ Callees_List : Iir_Callees_List;
+ El: Iir;
+ begin
+ if Get_Seen_Flag (Top) then
+ Set_Seen_Flag (Top, False);
+ Callees_List := Get_Callees_List (Get_Callees_List_Holder (Top));
+ if Callees_List /= Null_Iir_List then
+ for I in Natural loop
+ El := Get_Nth_Element (Callees_List, I);
+ exit when El = Null_Iir;
+ if Get_Seen_Flag (El) = False then
+ Clear_Seen_Flag (El);
+ end if;
+ end loop;
+ end if;
+ end if;
+ end Clear_Seen_Flag;
+
+ function Is_Anonymous_Type_Definition (Def : Iir) return Boolean is
+ begin
+ return Get_Type_Declarator (Def) = Null_Iir;
+ end Is_Anonymous_Type_Definition;
+
+ function Is_Fully_Constrained_Type (Def : Iir) return Boolean is
+ begin
+ return Get_Kind (Def) not in Iir_Kinds_Composite_Type_Definition
+ or else Get_Constraint_State (Def) = Fully_Constrained;
+ end Is_Fully_Constrained_Type;
+
+ function Strip_Denoting_Name (Name : Iir) return Iir is
+ begin
+ if Get_Kind (Name) in Iir_Kinds_Denoting_Name then
+ return Get_Named_Entity (Name);
+ else
+ return Name;
+ end if;
+ end Strip_Denoting_Name;
+
+ function Build_Simple_Name (Ref : Iir; Loc : Location_Type) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Simple_Name);
+ Set_Location (Res, Loc);
+ Set_Identifier (Res, Get_Identifier (Ref));
+ Set_Named_Entity (Res, Ref);
+ Set_Base_Name (Res, Res);
+ -- FIXME: set type and expr staticness ?
+ return Res;
+ end Build_Simple_Name;
+
+ function Build_Simple_Name (Ref : Iir; Loc : Iir) return Iir is
+ begin
+ return Build_Simple_Name (Ref, Get_Location (Loc));
+ end Build_Simple_Name;
+
+ function Has_Resolution_Function (Subtyp : Iir) return Iir
+ is
+ Ind : constant Iir := Get_Resolution_Indication (Subtyp);
+ begin
+ if Ind /= Null_Iir
+ and then Get_Kind (Ind) in Iir_Kinds_Denoting_Name
+ then
+ return Get_Named_Entity (Ind);
+ else
+ return Null_Iir;
+ end if;
+ end Has_Resolution_Function;
+
+ function Get_Primary_Unit_Name (Physical_Def : Iir) return Iir
+ is
+ Unit : constant Iir := Get_Primary_Unit (Physical_Def);
+ begin
+ return Get_Unit_Name (Get_Physical_Unit_Value (Unit));
+ end Get_Primary_Unit_Name;
+
+ function Is_Type_Name (Name : Iir) return Iir
+ is
+ Ent : Iir;
+ begin
+ if Get_Kind (Name) in Iir_Kinds_Denoting_Name then
+ Ent := Get_Named_Entity (Name);
+ case Get_Kind (Ent) is
+ when Iir_Kind_Type_Declaration =>
+ return Get_Type_Definition (Ent);
+ when Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Base_Attribute =>
+ return Get_Type (Ent);
+ when others =>
+ return Null_Iir;
+ end case;
+ else
+ return Null_Iir;
+ end if;
+ end Is_Type_Name;
+
+ function Get_Type_Of_Subtype_Indication (Ind : Iir) return Iir is
+ begin
+ case Get_Kind (Ind) is
+ when Iir_Kinds_Denoting_Name =>
+ return Get_Type (Ind);
+ when Iir_Kinds_Subtype_Definition =>
+ return Ind;
+ when others =>
+ Error_Kind ("get_type_of_subtype_indication", Ind);
+ end case;
+ end Get_Type_Of_Subtype_Indication;
+
+ function Get_Index_Type (Indexes : Iir_List; Idx : Natural) return Iir
+ is
+ Index : constant Iir := Get_Nth_Element (Indexes, Idx);
+ begin
+ if Index = Null_Iir then
+ return Null_Iir;
+ else
+ return Get_Index_Type (Index);
+ end if;
+ end Get_Index_Type;
+
+ function Get_Index_Type (Array_Type : Iir; Idx : Natural) return Iir is
+ begin
+ return Get_Index_Type (Get_Index_Subtype_List (Array_Type), Idx);
+ end Get_Index_Type;
+
+ function Get_Denoted_Type_Mark (Subtyp : Iir) return Iir
+ is
+ Type_Mark_Name : constant Iir := Get_Subtype_Type_Mark (Subtyp);
+ begin
+ if Type_Mark_Name = Null_Iir then
+ -- No type_mark (for array subtype created by constrained array
+ -- definition.
+ return Null_Iir;
+ else
+ return Get_Type (Get_Named_Entity (Type_Mark_Name));
+ end if;
+ end Get_Denoted_Type_Mark;
+
+ function Is_Second_Subprogram_Specification (Spec : Iir) return Boolean
+ is
+ Bod : constant Iir := Get_Subprogram_Body (Spec);
+ begin
+ return Bod /= Null_Iir
+ and then Get_Subprogram_Specification (Bod) /= Spec;
+ end Is_Second_Subprogram_Specification;
+
+ function Is_Same_Profile (L, R: Iir) return Boolean
+ is
+ L1, R1 : Iir;
+ L_Kind, R_Kind : Iir_Kind;
+ El_L, El_R : Iir;
+ begin
+ L_Kind := Get_Kind (L);
+ if L_Kind = Iir_Kind_Non_Object_Alias_Declaration then
+ L1 := Get_Named_Entity (Get_Name (L));
+ L_Kind := Get_Kind (L1);
+ else
+ L1 := L;
+ end if;
+ R_Kind := Get_Kind (R);
+ if R_Kind = Iir_Kind_Non_Object_Alias_Declaration then
+ R1 := Get_Named_Entity (Get_Name (R));
+ R_Kind := Get_Kind (R1);
+ else
+ R1 := R;
+ end if;
+
+ -- Check L and R are both of the same 'kind'.
+ -- Also the return profile for functions.
+ if L_Kind in Iir_Kinds_Function_Declaration
+ and then R_Kind in Iir_Kinds_Function_Declaration
+ then
+ if Get_Base_Type (Get_Return_Type (L1)) /=
+ Get_Base_Type (Get_Return_Type (R1))
+ then
+ return False;
+ end if;
+ elsif L_Kind in Iir_Kinds_Procedure_Declaration
+ and then R_Kind in Iir_Kinds_Procedure_Declaration
+ then
+ null;
+ elsif L_Kind = Iir_Kind_Enumeration_Literal
+ and then R_Kind = Iir_Kind_Enumeration_Literal
+ then
+ return Get_Type (L1) = Get_Type (R1);
+ else
+ -- Kind mismatch.
+ return False;
+ end if;
+
+ -- Check parameters profile.
+ El_L := Get_Interface_Declaration_Chain (L1);
+ El_R := Get_Interface_Declaration_Chain (R1);
+ loop
+ exit when El_L = Null_Iir and El_R = Null_Iir;
+ if El_L = Null_Iir or El_R = Null_Iir then
+ return False;
+ end if;
+ if Get_Base_Type (Get_Type (El_L)) /= Get_Base_Type (Get_Type (El_R))
+ then
+ return False;
+ end if;
+ El_L := Get_Chain (El_L);
+ El_R := Get_Chain (El_R);
+ end loop;
+
+ return True;
+ end Is_Same_Profile;
+
+ -- From a block_specification, returns the block.
+ function Get_Block_From_Block_Specification (Block_Spec : Iir)
+ return Iir
+ is
+ Res : Iir;
+ begin
+ case Get_Kind (Block_Spec) is
+ when Iir_Kind_Design_Unit =>
+ Res := Get_Library_Unit (Block_Spec);
+ if Get_Kind (Res) /= Iir_Kind_Architecture_Body then
+ raise Internal_Error;
+ end if;
+ return Res;
+ when Iir_Kind_Block_Statement
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Generate_Statement =>
+ return Block_Spec;
+ when Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Slice_Name =>
+ return Get_Named_Entity (Get_Prefix (Block_Spec));
+ when Iir_Kind_Simple_Name =>
+ return Get_Named_Entity (Block_Spec);
+ when others =>
+ Error_Kind ("get_block_from_block_specification", Block_Spec);
+ return Null_Iir;
+ end case;
+ end Get_Block_From_Block_Specification;
+
+ function Get_Entity (Decl : Iir) return Iir
+ is
+ Name : constant Iir := Get_Entity_Name (Decl);
+ Res : constant Iir := Get_Named_Entity (Name);
+ begin
+ pragma Assert (Res = Null_Iir
+ or else Get_Kind (Res) = Iir_Kind_Entity_Declaration);
+ return Res;
+ end Get_Entity;
+
+ function Get_Configuration (Aspect : Iir) return Iir
+ is
+ Name : constant Iir := Get_Configuration_Name (Aspect);
+ Res : constant Iir := Get_Named_Entity (Name);
+ begin
+ pragma Assert (Get_Kind (Res) = Iir_Kind_Configuration_Declaration);
+ return Res;
+ end Get_Configuration;
+
+ function Get_Entity_Identifier_Of_Architecture (Arch : Iir) return Name_Id
+ is
+ Name : constant Iir := Get_Entity_Name (Arch);
+ begin
+ case Get_Kind (Name) is
+ when Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name =>
+ return Get_Identifier (Name);
+ when others =>
+ Error_Kind ("get_entity_identifier_of_architecture", Name);
+ end case;
+ end Get_Entity_Identifier_Of_Architecture;
+
+ function Is_Component_Instantiation
+ (Inst : Iir_Component_Instantiation_Statement)
+ return Boolean is
+ begin
+ case Get_Kind (Get_Instantiated_Unit (Inst)) is
+ when Iir_Kinds_Denoting_Name =>
+ return True;
+ when Iir_Kind_Entity_Aspect_Entity
+ | Iir_Kind_Entity_Aspect_Configuration =>
+ return False;
+ when others =>
+ Error_Kind ("is_component_instantiation", Inst);
+ end case;
+ end Is_Component_Instantiation;
+
+ function Is_Entity_Instantiation
+ (Inst : Iir_Component_Instantiation_Statement)
+ return Boolean is
+ begin
+ case Get_Kind (Get_Instantiated_Unit (Inst)) is
+ when Iir_Kinds_Denoting_Name =>
+ return False;
+ when Iir_Kind_Entity_Aspect_Entity
+ | Iir_Kind_Entity_Aspect_Configuration =>
+ return True;
+ when others =>
+ Error_Kind ("is_entity_instantiation", Inst);
+ end case;
+ end Is_Entity_Instantiation;
+
+ function Get_String_Type_Bound_Type (Sub_Type : Iir) return Iir is
+ begin
+ if Get_Kind (Sub_Type) /= Iir_Kind_Array_Subtype_Definition then
+ Error_Kind ("get_string_type_bound_type", Sub_Type);
+ end if;
+ return Get_First_Element (Get_Index_Subtype_List (Sub_Type));
+ end Get_String_Type_Bound_Type;
+
+ procedure Get_Low_High_Limit (Arange : Iir_Range_Expression;
+ Low, High : out Iir)
+ is
+ begin
+ case Get_Direction (Arange) is
+ when Iir_To =>
+ Low := Get_Left_Limit (Arange);
+ High := Get_Right_Limit (Arange);
+ when Iir_Downto =>
+ High := Get_Left_Limit (Arange);
+ Low := Get_Right_Limit (Arange);
+ end case;
+ end Get_Low_High_Limit;
+
+ function Get_Low_Limit (Arange : Iir_Range_Expression) return Iir is
+ begin
+ case Get_Direction (Arange) is
+ when Iir_To =>
+ return Get_Left_Limit (Arange);
+ when Iir_Downto =>
+ return Get_Right_Limit (Arange);
+ end case;
+ end Get_Low_Limit;
+
+ function Get_High_Limit (Arange : Iir_Range_Expression) return Iir is
+ begin
+ case Get_Direction (Arange) is
+ when Iir_To =>
+ return Get_Right_Limit (Arange);
+ when Iir_Downto =>
+ return Get_Left_Limit (Arange);
+ end case;
+ end Get_High_Limit;
+
+ function Is_One_Dimensional_Array_Type (A_Type : Iir) return Boolean
+ is
+ Base_Type : constant Iir := Get_Base_Type (A_Type);
+ begin
+ if Get_Kind (Base_Type) = Iir_Kind_Array_Type_Definition
+ and then Get_Nbr_Elements (Get_Index_Subtype_List (Base_Type)) = 1
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end Is_One_Dimensional_Array_Type;
+
+ function Is_Range_Attribute_Name (Expr : Iir) return Boolean
+ is
+ Attr : Iir;
+ Id : Name_Id;
+ begin
+ if Get_Kind (Expr) = Iir_Kind_Parenthesis_Name then
+ Attr := Get_Prefix (Expr);
+ else
+ Attr := Expr;
+ end if;
+ if Get_Kind (Attr) /= Iir_Kind_Attribute_Name then
+ return False;
+ end if;
+ Id := Get_Identifier (Attr);
+ return Id = Name_Range or Id = Name_Reverse_Range;
+ end Is_Range_Attribute_Name;
+
+ function Create_Array_Subtype (Arr_Type : Iir; Loc : Location_Type)
+ return Iir_Array_Subtype_Definition
+ is
+ Res : Iir_Array_Subtype_Definition;
+ Base_Type : Iir;
+ List : Iir_List;
+ begin
+ Res := Create_Iir (Iir_Kind_Array_Subtype_Definition);
+ Set_Location (Res, Loc);
+ Base_Type := Get_Base_Type (Arr_Type);
+ Set_Base_Type (Res, Base_Type);
+ Set_Element_Subtype (Res, Get_Element_Subtype (Base_Type));
+ if Get_Kind (Arr_Type) = Iir_Kind_Array_Subtype_Definition then
+ Set_Resolution_Indication (Res, Get_Resolution_Indication (Arr_Type));
+ end if;
+ Set_Resolved_Flag (Res, Get_Resolved_Flag (Arr_Type));
+ Set_Signal_Type_Flag (Res, Get_Signal_Type_Flag (Arr_Type));
+ Set_Type_Staticness (Res, Get_Type_Staticness (Base_Type));
+ List := Create_Iir_List;
+ Set_Index_Subtype_List (Res, List);
+ Set_Index_Constraint_List (Res, List);
+ return Res;
+ end Create_Array_Subtype;
+
+ function Is_Subprogram_Method (Spec : Iir) return Boolean is
+ begin
+ case Get_Kind (Get_Parent (Spec)) is
+ when Iir_Kind_Protected_Type_Declaration
+ | Iir_Kind_Protected_Type_Body =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Is_Subprogram_Method;
+
+ function Get_Method_Type (Spec : Iir) return Iir
+ is
+ Parent : Iir;
+ begin
+ Parent := Get_Parent (Spec);
+ case Get_Kind (Parent) is
+ when Iir_Kind_Protected_Type_Declaration =>
+ return Parent;
+ when Iir_Kind_Protected_Type_Body =>
+ return Get_Protected_Type_Declaration (Parent);
+ when others =>
+ return Null_Iir;
+ end case;
+ end Get_Method_Type;
+
+ function Create_Error_Expr (Orig : Iir; Atype : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Error);
+ Set_Expr_Staticness (Res, None);
+ Set_Type (Res, Atype);
+ Set_Error_Origin (Res, Orig);
+ Location_Copy (Res, Orig);
+ return Res;
+ end Create_Error_Expr;
+
+ function Create_Error_Type (Orig : Iir) return Iir
+ is
+ Res : Iir;
+ begin
+ Res := Create_Iir (Iir_Kind_Error);
+ --Set_Expr_Staticness (Res, Locally);
+ Set_Base_Type (Res, Res);
+ Set_Error_Origin (Res, Orig);
+ Location_Copy (Res, Orig);
+ Set_Type_Declarator (Res, Null_Iir);
+ Set_Resolved_Flag (Res, True);
+ Set_Signal_Type_Flag (Res, True);
+ return Res;
+ end Create_Error_Type;
+
+ -- Extract the entity from ASPECT.
+ -- Note: if ASPECT is a component declaration, returns ASPECT.
+ function Get_Entity_From_Entity_Aspect (Aspect : Iir) return Iir
+ is
+ Inst : Iir;
+ begin
+ case Get_Kind (Aspect) is
+ when Iir_Kinds_Denoting_Name =>
+ -- A component declaration.
+ Inst := Get_Named_Entity (Aspect);
+ pragma Assert (Get_Kind (Inst) = Iir_Kind_Component_Declaration);
+ return Inst;
+ when Iir_Kind_Component_Declaration =>
+ return Aspect;
+ when Iir_Kind_Entity_Aspect_Entity =>
+ return Get_Entity (Aspect);
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ Inst := Get_Configuration (Aspect);
+ return Get_Entity (Inst);
+ when Iir_Kind_Entity_Aspect_Open =>
+ return Null_Iir;
+ when others =>
+ Error_Kind ("get_entity_from_entity_aspect", Aspect);
+ end case;
+ end Get_Entity_From_Entity_Aspect;
+
+ function Is_Signal_Object (Name : Iir) return Boolean
+ is
+ Adecl: Iir;
+ begin
+ Adecl := Get_Object_Prefix (Name, True);
+ case Get_Kind (Adecl) is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kinds_Signal_Attribute =>
+ return True;
+ when Iir_Kind_Object_Alias_Declaration =>
+ raise Internal_Error;
+ when others =>
+ return False;
+ end case;
+ end Is_Signal_Object;
+
+ -- LRM08 4.7 Package declarations
+ -- If the package header is empty, the package declared by a package
+ -- declaration is called a simple package.
+ function Is_Simple_Package (Pkg : Iir) return Boolean is
+ begin
+ return Get_Package_Header (Pkg) = Null_Iir;
+ end Is_Simple_Package;
+
+ -- LRM08 4.7 Package declarations
+ -- If the package header contains a generic clause and no generic map
+ -- aspect, the package is called an uninstantiated package.
+ function Is_Uninstantiated_Package (Pkg : Iir) return Boolean
+ is
+ Header : constant Iir := Get_Package_Header (Pkg);
+ begin
+ return Header /= Null_Iir
+ and then Get_Generic_Map_Aspect_Chain (Header) = Null_Iir;
+ end Is_Uninstantiated_Package;
+
+ -- LRM08 4.7 Package declarations
+ -- If the package header contains both a generic clause and a generic
+ -- map aspect, the package is declared a generic-mapped package.
+ function Is_Generic_Mapped_Package (Pkg : Iir) return Boolean
+ is
+ Header : constant Iir := Get_Package_Header (Pkg);
+ begin
+ return Header /= Null_Iir
+ and then Get_Generic_Map_Aspect_Chain (Header) /= Null_Iir;
+ end Is_Generic_Mapped_Package;
+
+ function Kind_In (N : Iir; K1, K2 : Iir_Kind) return Boolean
+ is
+ K : constant Iir_Kind := Get_Kind (N);
+ begin
+ return K = K1 or K = K2;
+ end Kind_In;
+
+ function Get_HDL_Node (N : PSL_Node) return Iir is
+ begin
+ return Iir (PSL.Nodes.Get_HDL_Node (N));
+ end Get_HDL_Node;
+
+ procedure Set_HDL_Node (N : PSL_Node; Expr : Iir) is
+ begin
+ PSL.Nodes.Set_HDL_Node (N, PSL.Nodes.HDL_Node (Expr));
+ end Set_HDL_Node;
+end Iirs_Utils;
diff --git a/src/iirs_utils.ads b/src/iirs_utils.ads
new file mode 100644
index 000000000..a588ab870
--- /dev/null
+++ b/src/iirs_utils.ads
@@ -0,0 +1,250 @@
+-- Common operations on nodes.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with Iirs; use Iirs;
+
+package Iirs_Utils is
+ -- Transform the current token into an iir literal.
+ -- The current token must be either a character, a string or an identifier.
+ function Current_Text return Iir;
+
+ -- Get identifier of NODE as a string.
+ function Image_Identifier (Node : Iir) return String;
+ function Image_String_Lit (Str : Iir) return String;
+
+ -- Easier function for string literals.
+ function Get_String_Fat_Acc (Str : Iir) return String_Fat_Acc;
+ pragma Inline (Get_String_Fat_Acc);
+
+ -- Return True iff N is an error node.
+ function Is_Error (N : Iir) return Boolean;
+ pragma Inline (Is_Error);
+
+ -- Find LIT in the list of identifiers or characters LIST.
+ -- Return the literal (whose name is LIT) or null_iir if not found.
+ function Find_Name_In_Chain (Chain: Iir; Lit: Name_Id) return Iir;
+ function Find_Name_In_List (List : Iir_List; Lit: Name_Id) return Iir;
+
+ -- Return TRUE if EL in an element of chain CHAIN.
+ function Is_In_Chain (Chain : Iir; El : Iir) return Boolean;
+
+ -- Convert an operator node to a name.
+ function Get_Operator_Name (Op : Iir) return Name_Id;
+
+ -- Get the longuest static prefix of EXPR.
+ -- See LRM §8.1
+ function Get_Longuest_Static_Prefix (Expr: Iir) return Iir;
+
+ -- Get the prefix of NAME, ie the declaration at the base of NAME.
+ -- Return NAME itself if NAME is not an object or a subelement of
+ -- an object. If WITH_ALIAS is true, continue with the alias name when an
+ -- alias is found, else return the alias.
+ -- FIXME: clarify when NAME is returned.
+ function Get_Object_Prefix (Name: Iir; With_Alias : Boolean := True)
+ return Iir;
+
+
+ -- Get the interface associated by the association ASSOC. This is always
+ -- an interface, even if the formal is a name.
+ function Get_Association_Interface (Assoc : Iir) return Iir;
+
+ -- Duplicate enumeration literal LIT.
+ function Copy_Enumeration_Literal (Lit : Iir) return Iir;
+
+ -- Make TARGETS depends on UNIT.
+ -- UNIT must be either a design unit or a entity_aspect_entity.
+ procedure Add_Dependence (Target: Iir_Design_Unit; Unit: Iir);
+
+ -- Clear configuration field of all component instantiation of
+ -- the concurrent statements of PARENT.
+ procedure Clear_Instantiation_Configuration (Parent : Iir; Full : Boolean);
+
+ -- Free Node and its prefixes, if any.
+ procedure Free_Name (Node : Iir);
+
+ -- Free NODE and its sub-nodes.
+ procedure Free_Recursive (Node : Iir; Free_List : Boolean := False);
+
+ -- Name of FUNC.
+ function Get_Predefined_Function_Name (Func : Iir_Predefined_Functions)
+ return String;
+
+ -- Mark SUBPRG as used. If SUBPRG is an instance, its generic is also
+ -- marked.
+ procedure Mark_Subprogram_Used (Subprg : Iir);
+
+ -- Create the range_constraint node for an enumeration type.
+ procedure Create_Range_Constraint_For_Enumeration_Type
+ (Def : Iir_Enumeration_Type_Definition);
+
+ -- Return the node containing the Callees_List (ie the subprogram body if
+ -- SUBPRG is a subprogram spec, SUBPRG if SUBPRG is a process).
+ function Get_Callees_List_Holder (Subprg : Iir) return Iir;
+
+ -- Clear flag of TOP and all of its callees.
+ procedure Clear_Seen_Flag (Top : Iir);
+
+ -- Return TRUE iff DEF is an anonymous type (or subtype) definition.
+ -- Note: DEF is required to be a type (or subtype) definition.
+ -- Note: type (and not subtype) are never anonymous.
+ function Is_Anonymous_Type_Definition (Def : Iir) return Boolean;
+ pragma Inline (Is_Anonymous_Type_Definition);
+
+ -- Return TRUE iff DEF is a fully constrained type (or subtype) definition.
+ function Is_Fully_Constrained_Type (Def : Iir) return Boolean;
+
+ -- Return the type definition/subtype indication of NAME if NAME denotes
+ -- a type or subtype name. Otherwise, return Null_Iir;
+ function Is_Type_Name (Name : Iir) return Iir;
+
+ -- Return TRUE iff SPEC is the subprogram specification of a subprogram
+ -- body which was previously declared. In that case, the only use of SPEC
+ -- is to match the body with its declaration.
+ function Is_Second_Subprogram_Specification (Spec : Iir) return Boolean;
+
+ -- If NAME is a simple or an expanded name, return the denoted declaration.
+ -- Otherwise, return NAME.
+ function Strip_Denoting_Name (Name : Iir) return Iir;
+
+ -- Build a simple name node whose named entity is REF and location LOC.
+ function Build_Simple_Name (Ref : Iir; Loc : Location_Type) return Iir;
+ function Build_Simple_Name (Ref : Iir; Loc : Iir) return Iir;
+
+ -- If SUBTYP has a resolution indication that is a function name, returns
+ -- the function declaration (not the name).
+ function Has_Resolution_Function (Subtyp : Iir) return Iir;
+
+ -- Return a simple name for the primary unit of physical type PHYSICAL_DEF.
+ -- This is the artificial unit name for the value of the primary unit, thus
+ -- its location is the location of the primary unit. Used mainly to build
+ -- evaluated literals.
+ function Get_Primary_Unit_Name (Physical_Def : Iir) return Iir;
+
+ -- Get the type of any node representing a subtype indication. This simply
+ -- skip over denoting names.
+ function Get_Type_Of_Subtype_Indication (Ind : Iir) return Iir;
+
+ -- Get the type of an index_subtype_definition or of a discrete_range from
+ -- an index_constraint.
+ function Get_Index_Type (Index_Type : Iir) return Iir
+ renames Get_Type_Of_Subtype_Indication;
+
+ -- Return the IDX-th index type for index subtype definition list or
+ -- index_constraint INDEXES. Return Null_Iir if IDX is out of dimension
+ -- bounds, so that this function can be used to iterator over indexes of
+ -- a type (or subtype). Note that IDX starts at 0.
+ function Get_Index_Type (Indexes : Iir_List; Idx : Natural) return Iir;
+
+ -- Likewise but for array type or subtype ARRAY_TYPE.
+ function Get_Index_Type (Array_Type : Iir; Idx : Natural) return Iir;
+
+ -- Return the type or subtype definition of the SUBTYP type mark.
+ function Get_Denoted_Type_Mark (Subtyp : Iir) return Iir;
+
+ -- Return true iff L and R have the same profile.
+ -- L and R must be subprograms specification (or spec_body).
+ function Is_Same_Profile (L, R: Iir) return Boolean;
+
+ -- From a block_specification, returns the block.
+ -- Roughly speaking, this get prefix of indexed and sliced name.
+ function Get_Block_From_Block_Specification (Block_Spec : Iir)
+ return Iir;
+
+ -- Wrapper around Get_Entity_Name: return the entity declaration of the
+ -- entity name of DECL.
+ function Get_Entity (Decl : Iir) return Iir;
+
+ -- Wrapper around get_Configuration_Name: return the configuration
+ -- declaration of ASPECT.
+ function Get_Configuration (Aspect : Iir) return Iir;
+
+ -- Return the identifier of the entity for architecture ARCH.
+ function Get_Entity_Identifier_Of_Architecture (Arch : Iir) return Name_Id;
+
+ -- Return True is component instantiation statement INST instantiate a
+ -- component.
+ function Is_Component_Instantiation
+ (Inst : Iir_Component_Instantiation_Statement)
+ return Boolean;
+
+ -- Return True is component instantiation statement INST instantiate a
+ -- design entity.
+ function Is_Entity_Instantiation
+ (Inst : Iir_Component_Instantiation_Statement)
+ return Boolean;
+
+ -- Return the bound type of a string type, ie the type of the (first)
+ -- dimension of a one-dimensional array type.
+ function Get_String_Type_Bound_Type (Sub_Type : Iir) return Iir;
+
+ -- Return left or right limit according to the direction.
+ procedure Get_Low_High_Limit (Arange : Iir_Range_Expression;
+ Low, High : out Iir);
+ function Get_Low_Limit (Arange : Iir_Range_Expression) return Iir;
+ function Get_High_Limit (Arange : Iir_Range_Expression) return Iir;
+
+ -- Return TRUE iff type/subtype definition A_TYPE is an undim array.
+ function Is_One_Dimensional_Array_Type (A_Type : Iir) return Boolean;
+
+ -- Return TRUE iff unsemantized EXPR is a range attribute.
+ function Is_Range_Attribute_Name (Expr : Iir) return Boolean;
+
+ -- Create an array subtype from array_type or array_subtype ARR_TYPE.
+ -- All fields of the returned node are filled, except the index_list.
+ -- The type_staticness is set with the type staticness of the element
+ -- subtype and therefore must be updated.
+ -- The type_declarator field is set to null_iir.
+ function Create_Array_Subtype (Arr_Type : Iir; Loc : Location_Type)
+ return Iir_Array_Subtype_Definition;
+
+ -- Return TRUE iff SPEC is declared inside a protected type or a protected
+ -- body.
+ function Is_Subprogram_Method (Spec : Iir) return Boolean;
+
+ -- Return the protected type for method SPEC.
+ function Get_Method_Type (Spec : Iir) return Iir;
+
+ -- Create an error node for node ORIG, and set its type to ATYPE.
+ -- Set its staticness to locally.
+ function Create_Error_Expr (Orig : Iir; Atype : Iir) return Iir;
+
+ -- Create an error node for node ORIG, which is supposed to be a type.
+ function Create_Error_Type (Orig : Iir) return Iir;
+
+ -- Extract the entity from ASPECT.
+ -- Note: if ASPECT is a component declaration, returns ASPECT.
+ -- if ASPECT is open, return Null_Iir;
+ function Get_Entity_From_Entity_Aspect (Aspect : Iir) return Iir;
+
+ -- Definitions from LRM08 4.7 Package declarations.
+ -- PKG must denote a package declaration.
+ function Is_Simple_Package (Pkg : Iir) return Boolean;
+ function Is_Uninstantiated_Package (Pkg : Iir) return Boolean;
+ function Is_Generic_Mapped_Package (Pkg : Iir) return Boolean;
+
+ -- Return TRUE if the base name of NAME is a signal object.
+ function Is_Signal_Object (Name: Iir) return Boolean;
+
+ -- Return True IFF kind of N is K1 or K2.
+ function Kind_In (N : Iir; K1, K2 : Iir_Kind) return Boolean;
+ pragma Inline (Kind_In);
+
+ -- IIR wrapper around Get_HDL_Node/Set_HDL_Node.
+ function Get_HDL_Node (N : PSL_Node) return Iir;
+ procedure Set_HDL_Node (N : PSL_Node; Expr : Iir);
+end Iirs_Utils;
diff --git a/src/iirs_walk.adb b/src/iirs_walk.adb
new file mode 100644
index 000000000..399832907
--- /dev/null
+++ b/src/iirs_walk.adb
@@ -0,0 +1,115 @@
+-- Walk in iirs nodes.
+-- Copyright (C) 2009 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package body Iirs_Walk is
+ function Walk_Chain (Chain : Iir; Cb : Walk_Cb) return Walk_Status
+ is
+ El : Iir;
+ Status : Walk_Status := Walk_Continue;
+ begin
+ El := Chain;
+ while El /= Null_Iir loop
+ Status := Cb.all (El);
+ exit when Status /= Walk_Continue;
+ El := Get_Chain (El);
+ end loop;
+ return Status;
+ end Walk_Chain;
+
+ function Walk_Sequential_Stmt (Stmt : Iir; Cb : Walk_Cb) return Walk_Status;
+
+
+ function Walk_Sequential_Stmt_Chain (Chain : Iir; Cb : Walk_Cb)
+ return Walk_Status
+ is
+ El : Iir;
+ Status : Walk_Status := Walk_Continue;
+ begin
+ El := Chain;
+ while El /= Null_Iir loop
+ Status := Cb.all (El);
+ exit when Status /= Walk_Continue;
+ Status := Walk_Sequential_Stmt (El, Cb);
+ exit when Status /= Walk_Continue;
+ El := Get_Chain (El);
+ end loop;
+ return Status;
+ end Walk_Sequential_Stmt_Chain;
+
+ function Walk_Sequential_Stmt (Stmt : Iir; Cb : Walk_Cb) return Walk_Status
+ is
+ Status : Walk_Status := Walk_Continue;
+ Chain : Iir;
+ begin
+ case Iir_Kinds_Sequential_Statement (Get_Kind (Stmt)) is
+ when Iir_Kind_Signal_Assignment_Statement
+ | Iir_Kind_Null_Statement
+ | Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement
+ | Iir_Kind_Wait_Statement
+ | Iir_Kind_Return_Statement
+ | Iir_Kind_Procedure_Call_Statement
+ | Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement
+ | Iir_Kind_Variable_Assignment_Statement =>
+ null;
+ when Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement =>
+ Status := Walk_Sequential_Stmt_Chain
+ (Get_Sequential_Statement_Chain (Stmt), Cb);
+ when Iir_Kind_Case_Statement =>
+ Chain := Get_Case_Statement_Alternative_Chain (Stmt);
+ while Chain /= Null_Iir loop
+ Status := Walk_Sequential_Stmt_Chain
+ (Get_Associated_Chain (Chain), Cb);
+ exit when Status /= Walk_Continue;
+ Chain := Get_Chain (Chain);
+ end loop;
+ when Iir_Kind_If_Statement =>
+ Chain := Stmt;
+ while Chain /= Null_Iir loop
+ Status := Walk_Sequential_Stmt_Chain
+ (Get_Sequential_Statement_Chain (Chain), Cb);
+ exit when Status /= Walk_Continue;
+ Chain := Get_Else_Clause (Chain);
+ end loop;
+ end case;
+ return Status;
+ end Walk_Sequential_Stmt;
+
+ function Walk_Assignment_Target (Target : Iir; Cb : Walk_Cb)
+ return Walk_Status
+ is
+ Chain : Iir;
+ Status : Walk_Status := Walk_Continue;
+ begin
+ case Get_Kind (Target) is
+ when Iir_Kind_Aggregate =>
+ Chain := Get_Association_Choices_Chain (Target);
+ while Chain /= Null_Iir loop
+ Status :=
+ Walk_Assignment_Target (Get_Associated_Expr (Chain), Cb);
+ exit when Status /= Walk_Continue;
+ Chain := Get_Chain (Chain);
+ end loop;
+ when others =>
+ Status := Cb.all (Target);
+ end case;
+ return Status;
+ end Walk_Assignment_Target;
+end Iirs_Walk;
diff --git a/src/iirs_walk.ads b/src/iirs_walk.ads
new file mode 100644
index 000000000..4c098f7d5
--- /dev/null
+++ b/src/iirs_walk.ads
@@ -0,0 +1,45 @@
+-- Walk in iirs nodes.
+-- Copyright (C) 2009 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Iirs; use Iirs;
+
+package Iirs_Walk is
+ type Walk_Status is
+ (
+ -- Continue to walk.
+ Walk_Continue,
+
+ -- Stop walking in the subtree, continue in the parent tree.
+ Walk_Up,
+
+ -- Abort the walk.
+ Walk_Abort);
+
+ type Walk_Cb is access function (El : Iir) return Walk_Status;
+
+ -- Walk on all elements of CHAIN.
+ function Walk_Chain (Chain : Iir; Cb : Walk_Cb) return Walk_Status;
+
+
+ function Walk_Assignment_Target (Target : Iir; Cb : Walk_Cb)
+ return Walk_Status;
+
+ -- Walk on all stmts and sub-stmts of CHAIN.
+ function Walk_Sequential_Stmt_Chain (Chain : Iir; Cb : Walk_Cb)
+ return Walk_Status;
+end Iirs_Walk;
diff --git a/src/libraries.adb b/src/libraries.adb
new file mode 100644
index 000000000..7fd2b69ef
--- /dev/null
+++ b/src/libraries.adb
@@ -0,0 +1,1714 @@
+-- VHDL libraries handling.
+-- 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 GHDL; 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; use Ada.Text_IO;
+with GNAT.Table;
+with GNAT.OS_Lib;
+with Interfaces.C_Streams;
+with System;
+with Errorout; use Errorout;
+with Scanner;
+with Iirs_Utils; use Iirs_Utils;
+with Parse;
+with Back_End;
+with Name_Table; use Name_Table;
+with Str_Table;
+with Sem_Scopes;
+with Tokens;
+with Files_Map;
+with Flags;
+with Std_Package;
+
+package body Libraries is
+ -- Chain of known libraries. This is also the top node of all iir node.
+ Libraries_Chain : Iir_Library_Declaration := Null_Iir;
+ Libraries_Chain_Last : Iir_Library_Declaration := Null_Iir;
+
+ -- A location for any implicit declarations (such as library WORK).
+ Implicit_Location: Location_Type;
+
+ -- Table of library pathes.
+ package Pathes is new GNAT.Table
+ (Table_Index_Type => Integer,
+ Table_Component_Type => Name_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 4,
+ Table_Increment => 100);
+
+ -- Initialize pathes table.
+ -- Set the local path.
+ procedure Init_Pathes
+ is
+ begin
+ Name_Nil := Get_Identifier ("");
+ Pathes.Append (Name_Nil);
+ Local_Directory := Name_Nil;
+ Work_Directory := Name_Nil;
+ end Init_Pathes;
+
+ function Path_To_Id (Path : String) return Name_Id is
+ begin
+ if Path (Path'Last) /= GNAT.OS_Lib.Directory_Separator then
+ return Get_Identifier (Path & GNAT.OS_Lib.Directory_Separator);
+ else
+ return Get_Identifier (Path);
+ end if;
+ end Path_To_Id;
+
+ procedure Add_Library_Path (Path : String)
+ is
+ begin
+ if Path'Length = 0 then
+ return;
+ end if;
+ -- Nice message instead of constraint_error.
+ if Path'Length + 2 >= Name_Buffer'Length then
+ Error_Msg ("argument of -P is too long");
+ return;
+ end if;
+ Pathes.Append (Path_To_Id (Path));
+ end Add_Library_Path;
+
+ function Get_Nbr_Pathes return Natural is
+ begin
+ return Pathes.Last;
+ end Get_Nbr_Pathes;
+
+ function Get_Path (N : Natural) return Name_Id is
+ begin
+ if N > Pathes.Last or N < Pathes.First then
+ raise Constraint_Error;
+ end if;
+ return Pathes.Table (N);
+ end Get_Path;
+
+ -- Set PATH as the path of the work library.
+ procedure Set_Work_Library_Path (Path : String) is
+ begin
+ Work_Directory := Path_To_Id (Path);
+ if not GNAT.OS_Lib.Is_Directory (Get_Address (Work_Directory)) then
+ -- This is a warning, since 'clean' action should not fail in
+ -- this cases.
+ Warning_Msg
+ ("directory '" & Path & "' set by --workdir= does not exist");
+ -- raise Option_Error;
+ end if;
+ end Set_Work_Library_Path;
+
+ -- Open LIBRARY map file, return TRUE if successful.
+ function Set_Library_File_Name (Dir : Name_Id;
+ Library: Iir_Library_Declaration)
+ return Boolean
+ is
+ File_Name : constant String := Back_End.Library_To_File_Name (Library);
+ Fe : Source_File_Entry;
+ begin
+ Fe := Files_Map.Load_Source_File (Dir, Get_Identifier (File_Name));
+ if Fe = No_Source_File_Entry then
+ return False;
+ end if;
+ Scanner.Set_File (Fe);
+ return True;
+ end Set_Library_File_Name;
+
+ -- Every design unit is put in this hash table to be quickly found by
+ -- its (primary) identifier.
+ Unit_Hash_Length : constant Name_Id := 127;
+ subtype Hash_Id is Name_Id range 0 .. Unit_Hash_Length - 1;
+ Unit_Hash_Table : array (Hash_Id) of Iir := (others => Null_Iir);
+
+ -- Get the hash value for DESIGN_UNIT.
+ -- Architectures use the entity name.
+ function Get_Hash_Id_For_Unit (Design_Unit : Iir_Design_Unit)
+ return Hash_Id
+ is
+ Lib_Unit : Iir;
+ Id : Name_Id;
+ begin
+ Lib_Unit := Get_Library_Unit (Design_Unit);
+ case Get_Kind (Lib_Unit) is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Package_Instantiation_Declaration =>
+ Id := Get_Identifier (Lib_Unit);
+ when Iir_Kind_Architecture_Body =>
+ -- Architectures are put with the entity identifier.
+ Id := Get_Entity_Identifier_Of_Architecture (Lib_Unit);
+ when others =>
+ Error_Kind ("get_Hash_Id_For_Unit", Lib_Unit);
+ end case;
+ return Id mod Unit_Hash_Length;
+ end Get_Hash_Id_For_Unit;
+
+ -- Put DESIGN_UNIT into the unit hash table.
+ procedure Add_Unit_Hash (Design_Unit : Iir)
+ is
+ Id : Hash_Id;
+ begin
+ Id := Get_Hash_Id_For_Unit (Design_Unit);
+ Set_Hash_Chain (Design_Unit, Unit_Hash_Table (Id));
+ Unit_Hash_Table (Id) := Design_Unit;
+ end Add_Unit_Hash;
+
+ -- Remove DESIGN_UNIT from the unit hash table.
+ procedure Remove_Unit_Hash (Design_Unit : Iir)
+ is
+ Id : Hash_Id;
+ Unit, Prev, Next : Iir_Design_Unit;
+ begin
+ Id := Get_Hash_Id_For_Unit (Design_Unit);
+ Unit := Unit_Hash_Table (Id);
+ Prev := Null_Iir;
+ while Unit /= Null_Iir loop
+ Next := Get_Hash_Chain (Unit);
+ if Unit = Design_Unit then
+ if Prev = Null_Iir then
+ Unit_Hash_Table (Id) := Next;
+ else
+ Set_Hash_Chain (Prev, Next);
+ end if;
+ return;
+ end if;
+ Prev := Unit;
+ Unit := Next;
+ end loop;
+ -- Not found.
+ raise Internal_Error;
+ end Remove_Unit_Hash;
+
+ procedure Purge_Design_File (Design_File : Iir_Design_File)
+ is
+ Prev, File, Next : Iir_Design_File;
+ Unit : Iir_Design_Unit;
+
+ File_Name : Name_Id;
+ Dir_Name : Name_Id;
+ begin
+ File_Name := Get_Design_File_Filename (Design_File);
+ Dir_Name := Get_Design_File_Directory (Design_File);
+
+ File := Get_Design_File_Chain (Work_Library);
+ Prev := Null_Iir;
+ while File /= Null_Iir loop
+ Next := Get_Chain (File);
+ if Get_Design_File_Filename (File) = File_Name
+ and then Get_Design_File_Directory (File) = Dir_Name
+ then
+ -- Remove from library.
+ if Prev = Null_Iir then
+ Set_Design_File_Chain (Work_Library, Next);
+ else
+ Set_Chain (Prev, Next);
+ end if;
+
+ -- Remove all units from unit hash table.
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ Remove_Unit_Hash (Unit);
+ Unit := Get_Chain (Unit);
+ end loop;
+
+ return;
+ end if;
+ Prev := File;
+ File := Next;
+ end loop;
+ end Purge_Design_File;
+
+ -- Load the contents of a library from a map file.
+ -- The format of this file, used by save_library and load_library is
+ -- as follow:
+ --
+ -- file_format ::= header { design_file_format }
+ -- header ::= v 3
+ -- design_file_format ::=
+ -- filename_format { design_unit_format }
+ -- filename_format ::=
+ -- FILE directory "FILENAME" file_time_stamp analyze_time_stamp:
+ -- design_unit_format ::= entity_format
+ -- | architecture_format
+ -- | package_format
+ -- | package_body_format
+ -- | configuration_format
+ -- position_format ::= LINE(POS) + OFF on DATE
+ -- entity_format ::=
+ -- ENTITY identifier AT position_format ;
+ -- architecture_format ::=
+ -- ARCHITECTURE identifier of name AT position_format ;
+ -- package_format ::=
+ -- PACKAGE identifier AT position_format [BODY] ;
+ -- package_body_format ::=
+ -- PACKAGE BODY identifier AT position_format ;
+ -- configuration_format ::=
+ -- CONFIGURATION identifier AT position_format ;
+ --
+ -- The position_format meaning is:
+ -- LINE is the line number (first line is number 1),
+ -- POS is the offset of this line number, as a source_ptr value,
+ -- OFF is the offset in the line, starting with 0.
+ -- DATE is the symbolic date of analysis (order).
+ --
+ -- Return TRUE if the library was found.
+ function Load_Library (Library: Iir_Library_Declaration)
+ return Boolean
+ is
+ use Scanner;
+ use Tokens;
+
+ File : Source_File_Entry;
+
+ procedure Bad_Library_Format is
+ begin
+ Error_Msg (Image (Files_Map.Get_File_Name (File)) &
+ ": bad library format");
+ end Bad_Library_Format;
+
+ procedure Scan_Expect (Tok: Token_Type) is
+ begin
+ Scan;
+ if Current_Token /= Tok then
+ Bad_Library_Format;
+ raise Compilation_Error;
+ end if;
+ end Scan_Expect;
+
+ function Current_Time_Stamp return Time_Stamp_Id is
+ begin
+ if Current_String_Length /= Time_Stamp_String'Length then
+ Bad_Library_Format;
+ raise Compilation_Error;
+ end if;
+ return Time_Stamp_Id (Current_String_Id);
+ end Current_Time_Stamp;
+
+ function String_To_Name_Id return Name_Id
+ is
+ Len : Int32;
+ Ptr : String_Fat_Acc;
+ begin
+ Len := Current_String_Length;
+ Ptr := Str_Table.Get_String_Fat_Acc (Current_String_Id);
+ for I in 1 .. Len loop
+ Name_Table.Name_Buffer (Natural (I)) := Ptr (I);
+ end loop;
+ Name_Table.Name_Length := Natural (Len);
+ -- FIXME: should remove last string.
+ return Get_Identifier;
+ end String_To_Name_Id;
+
+ Design_Unit, Last_Design_Unit : Iir_Design_Unit;
+ Lib_Ident : Name_Id;
+
+ function Scan_Unit_List return Iir_List is
+ begin
+ if Current_Token = Tok_Left_Paren then
+ Scan_Expect (Tok_Identifier);
+ loop
+ Scan_Expect (Tok_Dot);
+ Scan_Expect (Tok_Identifier);
+ Scan;
+ if Current_Token = Tok_Left_Paren then
+ -- This is an architecture.
+ Scan_Expect (Tok_Identifier);
+ Scan_Expect (Tok_Right_Paren);
+ Scan;
+ end if;
+ exit when Current_Token /= Tok_Comma;
+ Scan;
+ end loop;
+ Scan;
+ end if;
+ return Null_Iir_List;
+ end Scan_Unit_List;
+
+ Design_File: Iir_Design_File;
+ Library_Unit: Iir;
+ Line, Col: Int32;
+ File_Dir : Name_Id;
+ Pos: Source_Ptr;
+ Date: Date_Type;
+ Max_Date: Date_Type := Date_Valid'First;
+ Dir : Name_Id;
+ begin
+ Lib_Ident := Get_Identifier (Library);
+
+ if False then
+ Ada.Text_IO.Put_Line ("Load library " & Image (Lib_Ident));
+ end if;
+
+ -- Check the library was not already loaded.
+ if Get_Design_File_Chain (Library) /= Null_Iir then
+ raise Internal_Error;
+ end if;
+
+ -- Try to open the library file map.
+ Dir := Get_Library_Directory (Library);
+ if Dir = Null_Identifier then
+ -- Search in the library path.
+ declare
+ File_Name : constant String :=
+ Back_End.Library_To_File_Name (Library);
+ L : Natural;
+ begin
+ for I in Pathes.First .. Pathes.Last loop
+ Image (Pathes.Table (I));
+ L := Name_Length + File_Name'Length;
+ Name_Buffer (Name_Length + 1 .. L) := File_Name;
+ Name_Buffer (L + 1) := Character'Val (0);
+ if GNAT.OS_Lib.Is_Regular_File (Name_Buffer'Address) then
+ Dir := Pathes.Table (I);
+ Set_Library_Directory (Library, Dir);
+ exit;
+ end if;
+ end loop;
+ end;
+ end if;
+ if Dir = Null_Identifier
+ or else not Set_Library_File_Name (Dir, Library)
+ then
+ -- Not found.
+ Set_Date (Library, Date_Valid'First);
+ return False;
+ end if;
+ File := Get_Current_Source_File;
+
+ -- Parse header.
+ Scan;
+ if Current_Token /= Tok_Identifier
+ or else Name_Length /= 1 or else Name_Buffer (1) /= 'v'
+ then
+ Bad_Library_Format;
+ raise Compilation_Error;
+ end if;
+ Scan_Expect (Tok_Integer);
+ if Current_Iir_Int64 not in 1 .. 3 then
+ Bad_Library_Format;
+ raise Compilation_Error;
+ end if;
+ Scan;
+
+ Last_Design_Unit := Null_Iir;
+ while Current_Token /= Tok_Eof loop
+ if Current_Token = Tok_File then
+ -- This is a new design file.
+ Design_File := Create_Iir (Iir_Kind_Design_File);
+
+ Scan;
+ if Current_Token = Tok_Dot then
+ -- The filename is local, use the directory of the library.
+ if Dir = Name_Nil then
+ File_Dir := Files_Map.Get_Home_Directory;
+ else
+ File_Dir := Dir;
+ end if;
+ elsif Current_Token = Tok_Slash then
+ -- The filename is an absolute file.
+ File_Dir := Null_Identifier;
+ elsif Current_Token = Tok_String then
+ -- Be compatible with version 1: an empty directory for
+ -- an absolute filename.
+ if Current_String_Length = 0 then
+ File_Dir := Null_Identifier;
+ else
+ File_Dir := String_To_Name_Id;
+ end if;
+ else
+ Bad_Library_Format;
+ raise Compilation_Error;
+ end if;
+
+ Set_Design_File_Directory (Design_File, File_Dir);
+
+ Scan_Expect (Tok_String);
+ Set_Design_File_Filename (Design_File, String_To_Name_Id);
+
+ -- FIXME: check the file name is uniq.
+
+ Set_Parent (Design_File, Library);
+
+ -- Prepend.
+ Set_Chain (Design_File, Get_Design_File_Chain (Library));
+ Set_Design_File_Chain (Library, Design_File);
+
+ Scan_Expect (Tok_String);
+ Set_File_Time_Stamp (Design_File, Current_Time_Stamp);
+
+ Scan_Expect (Tok_String);
+ Set_Analysis_Time_Stamp (Design_File, Current_Time_Stamp);
+
+ Scan_Expect (Tok_Colon);
+ Scan;
+ Last_Design_Unit := Null_Iir;
+ else
+ -- This is a new design unit.
+ Design_Unit := Create_Iir (Iir_Kind_Design_Unit);
+ Set_Design_File (Design_Unit, Design_File);
+ case Current_Token is
+ when Tok_Entity =>
+ Library_Unit := Create_Iir (Iir_Kind_Entity_Declaration);
+ Scan;
+ when Tok_Architecture =>
+ Library_Unit := Create_Iir (Iir_Kind_Architecture_Body);
+ Scan;
+ when Tok_Configuration =>
+ Library_Unit :=
+ Create_Iir (Iir_Kind_Configuration_Declaration);
+ Scan;
+ when Tok_Package =>
+ Scan;
+ if Current_Token = Tok_Body then
+ Library_Unit := Create_Iir (Iir_Kind_Package_Body);
+ Scan;
+ else
+ Library_Unit := Create_Iir (Iir_Kind_Package_Declaration);
+ end if;
+ when Tok_With =>
+ if Library_Unit = Null_Iir
+ or else
+ Get_Kind (Library_Unit) /= Iir_Kind_Architecture_Body
+ then
+ Put_Line ("load_library: invalid use of 'with'");
+ raise Internal_Error;
+ end if;
+ Scan_Expect (Tok_Configuration);
+ Scan_Expect (Tok_Colon);
+ Scan;
+ Set_Dependence_List (Design_Unit, Scan_Unit_List);
+ goto Next_Line;
+ when others =>
+ Put_Line
+ ("load_library: line must start with " &
+ "'architecture', 'entity', 'package' or 'configuration'");
+ raise Internal_Error;
+ end case;
+
+ if Current_Token /= Tok_Identifier then
+ raise Internal_Error;
+ end if;
+ Set_Identifier (Library_Unit, Current_Identifier);
+ Set_Identifier (Design_Unit, Current_Identifier);
+
+ if Get_Kind (Library_Unit) = Iir_Kind_Architecture_Body then
+ Scan_Expect (Tok_Of);
+ Scan_Expect (Tok_Identifier);
+ Set_Entity_Name (Library_Unit, Current_Text);
+ end if;
+
+ -- Scan position.
+ Scan_Expect (Tok_Identifier); -- at
+ Scan_Expect (Tok_Integer);
+ Line := Int32 (Current_Iir_Int64);
+ Scan_Expect (Tok_Left_Paren);
+ Scan_Expect (Tok_Integer);
+ Pos := Source_Ptr (Current_Iir_Int64);
+ Scan_Expect (Tok_Right_Paren);
+ Scan_Expect (Tok_Plus);
+ Scan_Expect (Tok_Integer);
+ Col := Int32 (Current_Iir_Int64);
+ Scan_Expect (Tok_On);
+ Scan_Expect (Tok_Integer);
+ Date := Date_Type (Current_Iir_Int64);
+
+ Scan;
+ if Get_Kind (Library_Unit) = Iir_Kind_Package_Declaration
+ and then Current_Token = Tok_Body
+ then
+ Set_Need_Body (Library_Unit, True);
+ Scan;
+ end if;
+ if Current_Token /= Tok_Semi_Colon then
+ raise Internal_Error;
+ end if;
+ Scan;
+
+ if False then
+ Put_Line ("line:" & Int32'Image (Line)
+ & ", pos:" & Source_Ptr'Image (Pos));
+ end if;
+
+ -- Scan dependence list.
+ Set_Dependence_List (Design_Unit, Scan_Unit_List);
+
+ -- Keep the position of the design unit.
+ --Set_Location (Design_Unit, Location_Type (File));
+ --Set_Location (Library_Unit, Location_Type (File));
+ Set_Design_Unit_Source_Pos (Design_Unit, Pos);
+ Set_Design_Unit_Source_Line (Design_Unit, Line);
+ Set_Design_Unit_Source_Col (Design_Unit, Col);
+ Set_Date (Design_Unit, Date);
+ if Date > Max_Date then
+ Max_Date := Date;
+ end if;
+ Set_Date_State (Design_Unit, Date_Disk);
+ Set_Library_Unit (Design_Unit, Library_Unit);
+ Set_Design_Unit (Library_Unit, Design_Unit);
+
+ -- Add in the unit hash table.
+ Add_Unit_Hash (Design_Unit);
+
+ if Last_Design_Unit = Null_Iir then
+ Set_First_Design_Unit (Design_File, Design_Unit);
+ else
+ Set_Chain (Last_Design_Unit, Design_Unit);
+ end if;
+ Last_Design_Unit := Design_Unit;
+ Set_Last_Design_Unit (Design_File, Design_Unit);
+ end if;
+ << Next_Line >> null;
+ end loop;
+ Set_Date (Library, Max_Date);
+ Close_File;
+ return True;
+ end Load_Library;
+
+ procedure Create_Virtual_Locations
+ is
+ use Files_Map;
+ Implicit_Source_File : Source_File_Entry;
+ Command_Source_File : Source_File_Entry;
+ begin
+ Implicit_Source_File := Create_Virtual_Source_File
+ (Get_Identifier ("*implicit*"));
+ Command_Source_File := Create_Virtual_Source_File
+ (Get_Identifier ("*command line*"));
+ Command_Line_Location := Source_File_To_Location (Command_Source_File);
+ Implicit_Location := Source_File_To_Location (Implicit_Source_File);
+ end Create_Virtual_Locations;
+
+ -- Note: the scanner shouldn't be in use, since this procedure uses it.
+ procedure Load_Std_Library (Build_Standard : Boolean := True)
+ is
+ use Std_Package;
+ Dir : Name_Id;
+ begin
+ if Libraries_Chain /= Null_Iir then
+ -- This procedure must not be called twice.
+ raise Internal_Error;
+ end if;
+
+ Flags.Create_Flag_String;
+ Create_Virtual_Locations;
+
+ Std_Package.Create_First_Nodes;
+
+ -- Create the library.
+ Std_Library := Create_Iir (Iir_Kind_Library_Declaration);
+ Set_Identifier (Std_Library, Std_Names.Name_Std);
+ Set_Location (Std_Library, Implicit_Location);
+ Libraries_Chain := Std_Library;
+ Libraries_Chain_Last := Std_Library;
+
+ if Build_Standard then
+ Create_Std_Standard_Package (Std_Library);
+ Add_Unit_Hash (Std_Standard_Unit);
+ end if;
+
+ if Flags.Bootstrap
+ and then Work_Library_Name = Std_Names.Name_Std
+ then
+ Dir := Work_Directory;
+ else
+ Dir := Null_Identifier;
+ end if;
+ Set_Library_Directory (Std_Library, Dir);
+ if Load_Library (Std_Library) = False
+ and then not Flags.Bootstrap
+ then
+ Error_Msg_Option ("cannot find ""std"" library");
+ end if;
+
+ if Build_Standard then
+ -- Add the standard_file into the library.
+ -- This is done after Load_Library, because it checks there is no
+ -- previous files in the library.
+ Set_Parent (Std_Standard_File, Std_Library);
+ Set_Chain (Std_Standard_File, Get_Design_File_Chain (Std_Library));
+ Set_Design_File_Chain (Std_Library, Std_Standard_File);
+ end if;
+
+ Set_Visible_Flag (Std_Library, True);
+ end Load_Std_Library;
+
+ procedure Load_Work_Library (Empty : Boolean := False)
+ is
+ use Std_Names;
+ begin
+ if Work_Library_Name = Name_Std then
+ if not Flags.Bootstrap then
+ Error_Msg_Option ("the WORK library cannot be STD");
+ return;
+ end if;
+ Work_Library := Std_Library;
+ else
+ Work_Library := Create_Iir (Iir_Kind_Library_Declaration);
+ Set_Location (Work_Library, Implicit_Location);
+ --Set_Visible_Flag (Work_Library, True);
+ Set_Library_Directory (Work_Library, Work_Directory);
+
+ Set_Identifier (Work_Library, Work_Library_Name);
+
+ if not Empty then
+ if Load_Library (Work_Library) = False then
+ null;
+ end if;
+ end if;
+
+ -- Add it to the list of libraries.
+ Set_Chain (Libraries_Chain_Last, Work_Library);
+ Libraries_Chain_Last := Work_Library;
+ end if;
+ Set_Visible_Flag (Work_Library, True);
+ end Load_Work_Library;
+
+ -- Get or create a library from an identifier.
+ function Get_Library (Ident: Name_Id; Loc : Location_Type)
+ return Iir_Library_Declaration
+ is
+ Library: Iir_Library_Declaration;
+ begin
+ -- library work is a little bit special.
+ if Ident = Std_Names.Name_Work or else Ident = Work_Library_Name then
+ if Work_Library = Null_Iir then
+ -- load_work_library must have been called before.
+ raise Internal_Error;
+ end if;
+ return Work_Library;
+ end if;
+
+ -- Check if the library has already been loaded.
+ Library := Iirs_Utils.Find_Name_In_Chain (Libraries_Chain, Ident);
+ if Library /= Null_Iir then
+ return Library;
+ end if;
+
+ -- This is a new library.
+ if Ident = Std_Names.Name_Std then
+ -- Load_std_library must have been called before.
+ raise Internal_Error;
+ end if;
+
+ Library := Create_Iir (Iir_Kind_Library_Declaration);
+ Set_Location (Library, Scanner.Get_Token_Location);
+ Set_Library_Directory (Library, Null_Identifier);
+ Set_Identifier (Library, Ident);
+ if Load_Library (Library) = False then
+ Error_Msg_Sem ("cannot find resource library """
+ & Name_Table.Image (Ident) & """", Loc);
+ end if;
+ Set_Visible_Flag (Library, True);
+
+ Set_Chain (Libraries_Chain_Last, Library);
+ Libraries_Chain_Last := Library;
+
+ return Library;
+ end Get_Library;
+
+ -- Return TRUE if LIBRARY_UNIT and UNIT have identifiers for the same
+ -- design unit identifier.
+ -- eg: 'entity A' and 'package A' returns TRUE.
+ function Is_Same_Library_Unit (Library_Unit, Unit: Iir) return Boolean
+ is
+ Entity_Name1, Entity_Name2: Name_Id;
+ Library_Unit_Kind, Unit_Kind : Iir_Kind;
+ begin
+ if Get_Identifier (Unit) /= Get_Identifier (Library_Unit) then
+ return False;
+ end if;
+
+ Library_Unit_Kind := Get_Kind (Library_Unit);
+ Unit_Kind := Get_Kind (Unit);
+
+ -- Package and package body are never the same library unit.
+ if Library_Unit_Kind = Iir_Kind_Package_Declaration
+ and then Unit_Kind = Iir_Kind_Package_Body
+ then
+ return False;
+ end if;
+ if Unit_Kind = Iir_Kind_Package_Declaration
+ and then Library_Unit_Kind = Iir_Kind_Package_Body
+ then
+ return False;
+ end if;
+
+ -- Two architecture declarations are identical only if they also have
+ -- the same entity name.
+ if Unit_Kind = Iir_Kind_Architecture_Body
+ and then Library_Unit_Kind = Iir_Kind_Architecture_Body
+ then
+ Entity_Name1 := Get_Entity_Identifier_Of_Architecture (Unit);
+ Entity_Name2 := Get_Entity_Identifier_Of_Architecture (Library_Unit);
+ if Entity_Name1 /= Entity_Name2 then
+ return False;
+ end if;
+ end if;
+
+ -- An architecture declaration never conflits with a library unit that
+ -- is not an architecture declaration.
+ if (Unit_Kind = Iir_Kind_Architecture_Body
+ and then Library_Unit_Kind /= Iir_Kind_Architecture_Body)
+ or else
+ (Unit_Kind /= Iir_Kind_Architecture_Body
+ and then Library_Unit_Kind = Iir_Kind_Architecture_Body)
+ then
+ return False;
+ end if;
+
+ return True;
+ end Is_Same_Library_Unit;
+
+ procedure Free_Dependence_List (Design : Iir_Design_Unit)
+ is
+ List : Iir_List;
+ El : Iir;
+ begin
+ List := Get_Dependence_List (Design);
+ if List /= Null_Iir_List then
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Iirs_Utils.Free_Recursive (El);
+ end loop;
+ Destroy_Iir_List (List);
+ end if;
+ end Free_Dependence_List;
+
+ -- This procedure is called when the DESIGN_UNIT (either the stub created
+ -- when a library is read or created from a previous unit in a source
+ -- file) has been replaced by a new unit. Free everything but DESIGN_UNIT,
+ -- has it may be referenced in other units (dependence...)
+ -- FIXME: Isn't the library unit also referenced too ?
+ procedure Free_Design_Unit (Design_Unit : Iir_Design_Unit)
+ is
+ Lib : Iir;
+ Unit : Iir_Design_Unit;
+ Dep_List : Iir_List;
+ begin
+ -- Free dependence list.
+ Dep_List := Get_Dependence_List (Design_Unit);
+ Destroy_Iir_List (Dep_List);
+ Set_Dependence_List (Design_Unit, Null_Iir_List);
+
+ -- Free default configuration of architecture (if any).
+ Lib := Get_Library_Unit (Design_Unit);
+ if Lib /= Null_Iir
+ and then Get_Kind (Lib) = Iir_Kind_Architecture_Body
+ then
+ Free_Iir (Get_Entity_Name (Lib));
+ Unit := Get_Default_Configuration_Declaration (Lib);
+ if Unit /= Null_Iir then
+ Free_Design_Unit (Unit);
+ end if;
+ end if;
+
+ -- Free library unit.
+ Free_Iir (Lib);
+ Set_Library_Unit (Design_Unit, Null_Iir);
+ end Free_Design_Unit;
+
+ procedure Remove_Unit_From_File
+ (Unit_Ref : Iir_Design_Unit; File : Iir_Design_File)
+ is
+ Prev : Iir_Design_Unit;
+ Unit, Next : Iir_Design_Unit;
+ begin
+ Prev := Null_Iir;
+ Unit := Get_First_Design_Unit (File);
+ while Unit /= Null_Iir loop
+ Next := Get_Chain (Unit);
+ if Unit = Unit_Ref then
+ if Prev = Null_Iir then
+ Set_First_Design_Unit (File, Next);
+ else
+ Set_Chain (Prev, Next);
+ end if;
+ if Next = Null_Iir then
+ Set_Last_Design_Unit (File, Prev);
+ end if;
+ return;
+ end if;
+ Prev := Unit;
+ Unit := Next;
+ end loop;
+ -- Not found.
+ raise Internal_Error;
+ end Remove_Unit_From_File;
+
+ -- Last design_file used. Kept to speed-up operations.
+ Last_Design_File : Iir_Design_File := Null_Iir;
+
+ -- Add or replace a design unit in the working library.
+ procedure Add_Design_Unit_Into_Library
+ (Unit : in Iir_Design_Unit; Keep_Obsolete : Boolean := False)
+ is
+ Design_File: Iir_Design_File;
+ Design_Unit, Prev_Design_Unit : Iir_Design_Unit;
+ Last_Unit : Iir_Design_Unit;
+ Library_Unit: Iir;
+ New_Library_Unit: Iir;
+ Unit_Id : Name_Id;
+ Date: Date_Type;
+ New_Lib_Time_Stamp : Time_Stamp_Id;
+ Id : Hash_Id;
+
+ -- File name and dir name of DECL.
+ File_Name : Name_Id;
+ Dir_Name : Name_Id;
+ begin
+ -- As specified, the Chain must be not set.
+ pragma Assert (Get_Chain (Unit) = Null_Iir);
+
+ -- The unit must not be in the library.
+ pragma Assert (Get_Date_State (Unit) = Date_Extern);
+
+ -- Mark this design unit as being loaded.
+ New_Library_Unit := Get_Library_Unit (Unit);
+ Unit_Id := Get_Identifier (New_Library_Unit);
+
+ -- Set the date of the design unit as the most recently analyzed
+ -- design unit.
+ case Get_Date (Unit) is
+ when Date_Parsed =>
+ Set_Date_State (Unit, Date_Parse);
+ when Date_Analyzed =>
+ Date := Get_Date (Work_Library) + 1;
+ Set_Date (Unit, Date);
+ Set_Date (Work_Library, Date);
+ Set_Date_State (Unit, Date_Analyze);
+ when Date_Valid =>
+ raise Internal_Error;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ -- Set file time stamp.
+ declare
+ File : Source_File_Entry;
+ Pos : Source_Ptr;
+ begin
+ Files_Map.Location_To_File_Pos (Get_Location (New_Library_Unit),
+ File, Pos);
+ New_Lib_Time_Stamp := Files_Map.Get_File_Time_Stamp (File);
+ File_Name := Files_Map.Get_File_Name (File);
+ Image (File_Name);
+ if GNAT.OS_Lib.Is_Absolute_Path (Name_Buffer (1 .. Name_Length)) then
+ Dir_Name := Null_Identifier;
+ else
+ Dir_Name := Files_Map.Get_Home_Directory;
+ end if;
+ end;
+
+ -- Try to find a design unit with the same name in the work library.
+ Id := Get_Hash_Id_For_Unit (Unit);
+ Design_Unit := Unit_Hash_Table (Id);
+ Prev_Design_Unit := Null_Iir;
+ while Design_Unit /= Null_Iir loop
+ Design_File := Get_Design_File (Design_Unit);
+ Library_Unit := Get_Library_Unit (Design_Unit);
+ if Get_Identifier (Design_Unit) = Unit_Id
+ and then Get_Library (Design_File) = Work_Library
+ and then Is_Same_Library_Unit (New_Library_Unit, Library_Unit)
+ then
+ -- LIBRARY_UNIT and UNIT designate the same design unit.
+ -- Remove the old one.
+ Set_Date (Design_Unit, Date_Obsolete);
+ declare
+ Next_Design : Iir;
+ begin
+ -- Remove DESIGN_UNIT from the unit_hash.
+ Next_Design := Get_Hash_Chain (Design_Unit);
+ if Prev_Design_Unit = Null_Iir then
+ Unit_Hash_Table (Id) := Next_Design;
+ else
+ Set_Hash_Chain (Prev_Design_Unit, Next_Design);
+ end if;
+
+ -- Remove DESIGN_UNIT from the design_file.
+ -- If KEEP_OBSOLETE is True, units that are obsoleted by units
+ -- in the same design file are kept. This allows to process
+ -- (pretty print, xrefs, ...) all units of a design file.
+ -- But still remove units that are replaced (if a file was
+ -- already in the library).
+ if not Keep_Obsolete
+ or else Get_Date_State (Design_Unit) = Date_Disk
+ then
+ Remove_Unit_From_File (Design_Unit, Design_File);
+
+ Set_Chain (Design_Unit, Obsoleted_Design_Units);
+ Obsoleted_Design_Units := Design_Unit;
+ end if;
+ end;
+
+ -- UNIT *must* replace library_unit if they don't belong
+ -- to the same file.
+ if Get_Design_File_Filename (Design_File) = File_Name
+ and then Get_Design_File_Directory (Design_File) = Dir_Name
+ then
+ -- In the same file.
+ if Get_Date_State (Design_Unit) = Date_Analyze then
+ -- Warns only if we are not re-analyzing the file.
+ if Flags.Warn_Library then
+ Warning_Msg_Sem
+ ("redefinition of a library unit in "
+ & "same design file:", Unit);
+ Warning_Msg_Sem
+ (Disp_Node (Library_Unit) & " defined at "
+ & Disp_Location (Library_Unit) & " is now "
+ & Disp_Node (New_Library_Unit), Unit);
+ end if;
+ else
+ -- Free the stub.
+ if not Keep_Obsolete then
+ Free_Design_Unit (Design_Unit);
+ end if;
+ end if;
+
+ -- Note: the current design unit should not be freed if
+ -- in use; unfortunatly, this is not obvious to check.
+ else
+ if Flags.Warn_Library then
+ if Get_Kind (Library_Unit) /= Get_Kind (New_Library_Unit)
+ then
+ Warning_Msg ("changing definition of a library unit:");
+ Warning_Msg (Disp_Node (Library_Unit) & " is now "
+ & Disp_Node (New_Library_Unit));
+ end if;
+ Warning_Msg
+ ("library unit '"
+ & Iirs_Utils.Image_Identifier (Library_Unit)
+ & "' was also defined in file '"
+ & Image (Get_Design_File_Filename (Design_File))
+ & ''');
+ end if;
+ end if;
+ exit;
+ else
+ Prev_Design_Unit := Design_Unit;
+ Design_Unit := Get_Hash_Chain (Design_Unit);
+ end if;
+ end loop;
+
+ -- Try to find the design file in the library.
+ -- First try the last one found.
+ if Last_Design_File /= Null_Iir
+ and then Get_Library (Last_Design_File) = Work_Library
+ and then Get_Design_File_Filename (Last_Design_File) = File_Name
+ and then Get_Design_File_Directory (Last_Design_File) = Dir_Name
+ then
+ Design_File := Last_Design_File;
+ else
+ -- Search.
+ Design_File := Get_Design_File_Chain (Work_Library);
+ while Design_File /= Null_Iir loop
+ if Get_Design_File_Filename (Design_File) = File_Name
+ and then Get_Design_File_Directory (Design_File) = Dir_Name
+ then
+ exit;
+ end if;
+ Design_File := Get_Chain (Design_File);
+ end loop;
+ Last_Design_File := Design_File;
+ end if;
+
+ if Design_File /= Null_Iir
+ and then not Files_Map.Is_Eq (New_Lib_Time_Stamp,
+ Get_File_Time_Stamp (Design_File))
+ then
+ -- FIXME: this test is not enough: what about reanalyzing
+ -- unmodified files (this works only because the order is not
+ -- changed).
+ -- Design file is updated.
+ -- Outdate all other units, overwrite the design_file.
+ Set_File_Time_Stamp (Design_File, New_Lib_Time_Stamp);
+ Design_Unit := Get_First_Design_Unit (Design_File);
+ while Design_Unit /= Null_Iir loop
+ if Design_Unit /= Unit then
+ -- Mark other design unit as obsolete.
+ Set_Date (Design_Unit, Date_Obsolete);
+ Remove_Unit_Hash (Design_Unit);
+ else
+ raise Internal_Error;
+ end if;
+ Prev_Design_Unit := Design_Unit;
+ Design_Unit := Get_Chain (Design_Unit);
+
+ Set_Chain (Prev_Design_Unit, Obsoleted_Design_Units);
+ Obsoleted_Design_Units := Prev_Design_Unit;
+ end loop;
+ Set_First_Design_Unit (Design_File, Null_Iir);
+ Set_Last_Design_Unit (Design_File, Null_Iir);
+ end if;
+
+ if Design_File = Null_Iir then
+ -- This is the first apparition of the design file.
+ Design_File := Create_Iir (Iir_Kind_Design_File);
+ Location_Copy (Design_File, Unit);
+
+ Set_Design_File_Filename (Design_File, File_Name);
+ Set_Design_File_Directory (Design_File, Dir_Name);
+
+ Set_File_Time_Stamp (Design_File, New_Lib_Time_Stamp);
+ Set_Parent (Design_File, Work_Library);
+ Set_Chain (Design_File, Get_Design_File_Chain (Work_Library));
+ Set_Design_File_Chain (Work_Library, Design_File);
+ end if;
+
+ -- Add DECL to DESIGN_FILE.
+ Last_Unit := Get_Last_Design_Unit (Design_File);
+ if Last_Unit = Null_Iir then
+ if Get_First_Design_Unit (Design_File) /= Null_Iir then
+ raise Internal_Error;
+ end if;
+ Set_First_Design_Unit (Design_File, Unit);
+ else
+ if Get_First_Design_Unit (Design_File) = Null_Iir then
+ raise Internal_Error;
+ end if;
+ Set_Chain (Last_Unit, Unit);
+ end if;
+ Set_Last_Design_Unit (Design_File, Unit);
+ Set_Design_File (Unit, Design_File);
+
+ -- Add DECL in unit hash table.
+ Set_Hash_Chain (Unit, Unit_Hash_Table (Id));
+ Unit_Hash_Table (Id) := Unit;
+
+ -- Update the analyzed time stamp.
+ Set_Analysis_Time_Stamp (Design_File, Files_Map.Get_Os_Time_Stamp);
+ end Add_Design_Unit_Into_Library;
+
+ procedure Add_Design_File_Into_Library (File : in out Iir_Design_File)
+ is
+ Unit : Iir_Design_Unit;
+ Next_Unit : Iir_Design_Unit;
+ First_Unit : Iir_Design_Unit;
+ begin
+ Unit := Get_First_Design_Unit (File);
+ First_Unit := Unit;
+ Set_First_Design_Unit (File, Null_Iir);
+ Set_Last_Design_Unit (File, Null_Iir);
+ while Unit /= Null_Iir loop
+ Next_Unit := Get_Chain (Unit);
+ Set_Chain (Unit, Null_Iir);
+ Libraries.Add_Design_Unit_Into_Library (Unit, True);
+ Unit := Next_Unit;
+ end loop;
+ if First_Unit /= Null_Iir then
+ File := Get_Design_File (First_Unit);
+ end if;
+ end Add_Design_File_Into_Library;
+
+ -- Save the file map of library LIBRARY.
+ procedure Save_Library (Library: Iir_Library_Declaration)
+ is
+ use System;
+ use Interfaces.C_Streams;
+ use GNAT.OS_Lib;
+ Temp_Name: constant String := Image (Work_Directory)
+ & '_' & Back_End.Library_To_File_Name (Library) & ASCII.NUL;
+ Mode : constant String := 'w' & ASCII.NUL;
+ Stream : FILEs;
+ Success : Boolean;
+
+ -- Write a string to the temporary file.
+ procedure WR (S : String)
+ is
+ Close_Res : int;
+ pragma Unreferenced (Close_Res);
+ begin
+ if Integer (fwrite (S'Address, S'Length, 1, Stream)) /= 1 then
+ Error_Msg
+ ("cannot write library file for " & Image_Identifier (Library));
+ Close_Res := fclose (Stream);
+ Delete_File (Temp_Name'Address, Success);
+ -- Ignore failure to delete the file.
+ raise Option_Error;
+ end if;
+ end WR;
+
+ -- Write a line terminator in the temporary file.
+ procedure WR_LF is
+ begin
+ WR (String'(1 => ASCII.LF));
+ end WR_LF;
+
+ Design_File: Iir_Design_File;
+ Design_Unit: Iir_Design_Unit;
+ Library_Unit: Iir;
+ Dir : Name_Id;
+
+ Off, Line: Natural;
+ Pos: Source_Ptr;
+ Source_File : Source_File_Entry;
+ begin
+ -- Create a temporary file so that the real library is atomically
+ -- updated, and won't be corrupted in case of Control-C, or concurrent
+ -- writes.
+ Stream := fopen (Temp_Name'Address, Mode'Address);
+
+ if Stream = NULL_Stream then
+ Error_Msg
+ ("cannot create library file for " & Image_Identifier (Library));
+ raise Option_Error;
+ end if;
+
+ -- Header: version.
+ WR ("v 3");
+ WR_LF;
+
+ Design_File := Get_Design_File_Chain (Library);
+ while Design_File /= Null_Iir loop
+ -- Ignore std.standard as there is no corresponding file.
+ if Design_File = Std_Package.Std_Standard_File then
+ goto Continue;
+ end if;
+ Design_Unit := Get_First_Design_Unit (Design_File);
+
+ if Design_Unit /= Null_Iir then
+ WR ("file ");
+ Dir := Get_Design_File_Directory (Design_File);
+ if Dir = Null_Identifier then
+ -- Absolute filenames.
+ WR ("/");
+ elsif Work_Directory = Name_Nil
+ and then Dir = Files_Map.Get_Home_Directory
+ then
+ -- If the library is in the current directory, do not write
+ -- it. This allows to move the library file.
+ WR (".");
+ else
+ Image (Dir);
+ WR ("""");
+ WR (Name_Buffer (1 .. Name_Length));
+ WR ("""");
+ end if;
+ WR (" """);
+ Image (Get_Design_File_Filename (Design_File));
+ WR (Name_Buffer (1 .. Name_Length));
+ WR (""" """);
+ WR (Files_Map.Get_Time_Stamp_String
+ (Get_File_Time_Stamp (Design_File)));
+ WR (""" """);
+ WR (Files_Map.Get_Time_Stamp_String
+ (Get_Analysis_Time_Stamp (Design_File)));
+ WR (""":");
+ WR_LF;
+ end if;
+
+ while Design_Unit /= Null_Iir loop
+ Library_Unit := Get_Library_Unit (Design_Unit);
+
+ WR (" ");
+ case Get_Kind (Library_Unit) is
+ when Iir_Kind_Entity_Declaration =>
+ WR ("entity ");
+ WR (Image_Identifier (Library_Unit));
+ when Iir_Kind_Architecture_Body =>
+ WR ("architecture ");
+ WR (Image_Identifier (Library_Unit));
+ WR (" of ");
+ WR (Image (Get_Entity_Identifier_Of_Architecture
+ (Library_Unit)));
+ when Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration =>
+ WR ("package ");
+ WR (Image_Identifier (Library_Unit));
+ when Iir_Kind_Package_Body =>
+ WR ("package body ");
+ WR (Image_Identifier (Library_Unit));
+ when Iir_Kind_Configuration_Declaration =>
+ WR ("configuration ");
+ WR (Image_Identifier (Library_Unit));
+ when others =>
+ Error_Kind ("save_library", Library_Unit);
+ end case;
+
+ if Get_Date_State (Design_Unit) = Date_Disk then
+ Pos := Get_Design_Unit_Source_Pos (Design_Unit);
+ Line := Natural (Get_Design_Unit_Source_Line (Design_Unit));
+ Off := Natural (Get_Design_Unit_Source_Col (Design_Unit));
+ else
+ Files_Map.Location_To_Coord (Get_Location (Design_Unit),
+ Source_File, Pos, Line, Off);
+ end if;
+
+ WR (" at");
+ WR (Natural'Image (Line));
+ WR ("(");
+ WR (Source_Ptr'Image (Pos));
+ WR (") +");
+ WR (Natural'Image (Off));
+ WR (" on");
+ case Get_Date (Design_Unit) is
+ when Date_Valid
+ | Date_Analyzed
+ | Date_Parsed =>
+ WR (Date_Type'Image (Get_Date (Design_Unit)));
+ when others =>
+ WR (Date_Type'Image (Get_Date (Design_Unit)));
+ raise Internal_Error;
+ end case;
+ if Get_Kind (Library_Unit) = Iir_Kind_Package_Declaration
+ and then Get_Need_Body (Library_Unit)
+ then
+ WR (" body");
+ end if;
+ WR (";");
+ WR_LF;
+
+ Design_Unit := Get_Chain (Design_Unit);
+ end loop;
+ << Continue >> null;
+ Design_File := Get_Chain (Design_File);
+ end loop;
+
+ declare
+ Fclose_Res : int;
+ pragma Unreferenced (Fclose_Res);
+ begin
+ Fclose_Res := fclose (Stream);
+ end;
+
+ -- Rename the temporary file to the library file.
+ -- FIXME: It may fail if they aren't on the same filesystem, but we
+ -- could assume it doesn't happen (humm...)
+ declare
+ use Files_Map;
+ File_Name: constant String := Image (Work_Directory)
+ & Back_End.Library_To_File_Name (Library) & ASCII.NUL;
+ Delete_Success : Boolean;
+ begin
+ -- For windows: renames doesn't overwrite destination; so first
+ -- delete it. This can create races condition on Unix: if the
+ -- program is killed between delete and rename, the library is lost.
+ Delete_File (File_Name'Address, Delete_Success);
+ Rename_File (Temp_Name'Address, File_Name'Address, Success);
+ if not Success then
+ -- Renaming may fail if the new filename is in a non-existant
+ -- directory.
+ Error_Msg ("cannot update library file """
+ & File_Name (File_Name'First .. File_Name'Last - 1)
+ & """");
+ Delete_File (Temp_Name'Address, Success);
+ raise Option_Error;
+ end if;
+ end;
+ end Save_Library;
+
+ -- Save the map of the work library.
+ procedure Save_Work_Library is
+ begin
+ Save_Library (Work_Library);
+ end Save_Work_Library;
+
+ -- Return the name of the latest architecture analysed for an entity.
+ function Get_Latest_Architecture (Entity: Iir_Entity_Declaration)
+ return Iir_Architecture_Body
+ is
+ Entity_Id : Name_Id;
+ Lib : Iir_Library_Declaration;
+ Design_File: Iir_Design_File;
+ Design_Unit: Iir_Design_Unit;
+ Library_Unit: Iir;
+ Res: Iir_Design_Unit;
+ begin
+ -- FIXME: use hash
+ Entity_Id := Get_Identifier (Entity);
+ Lib := Get_Library (Get_Design_File (Get_Design_Unit (Entity)));
+ Design_File := Get_Design_File_Chain (Lib);
+ Res := Null_Iir;
+ while Design_File /= Null_Iir loop
+ Design_Unit := Get_First_Design_Unit (Design_File);
+ while Design_Unit /= Null_Iir loop
+ Library_Unit := Get_Library_Unit (Design_Unit);
+
+ if Get_Kind (Library_Unit) = Iir_Kind_Architecture_Body
+ and then
+ Get_Entity_Identifier_Of_Architecture (Library_Unit) = Entity_Id
+ then
+ if Res = Null_Iir then
+ Res := Design_Unit;
+ elsif Get_Date (Design_Unit) > Get_Date (Res) then
+ Res := Design_Unit;
+ end if;
+ end if;
+ Design_Unit := Get_Chain (Design_Unit);
+ end loop;
+ Design_File := Get_Chain (Design_File);
+ end loop;
+ if Res = Null_Iir then
+ return Null_Iir;
+ else
+ return Get_Library_Unit (Res);
+ end if;
+ end Get_Latest_Architecture;
+
+ function Load_File (File : Source_File_Entry) return Iir_Design_File
+ is
+ Res : Iir_Design_File;
+ begin
+ Scanner.Set_File (File);
+ Res := Parse.Parse_Design_File;
+ Scanner.Close_File;
+ if Res /= Null_Iir then
+ Set_Parent (Res, Work_Library);
+ Set_Design_File_Filename (Res, Files_Map.Get_File_Name (File));
+ end if;
+ return Res;
+ end Load_File;
+
+ -- parse a file.
+ -- Return a design_file without putting it into the library
+ -- (because it was not semantized).
+ function Load_File (File_Name: Name_Id) return Iir_Design_File
+ is
+ Fe : Source_File_Entry;
+ begin
+ Fe := Files_Map.Load_Source_File (Local_Directory, File_Name);
+ if Fe = No_Source_File_Entry then
+ Error_Msg_Option ("cannot open " & Image (File_Name));
+ return Null_Iir;
+ end if;
+ return Load_File (Fe);
+ end Load_File;
+
+ function Find_Design_Unit (Unit : Iir) return Iir_Design_Unit is
+ begin
+ case Get_Kind (Unit) is
+ when Iir_Kind_Design_Unit =>
+ return Unit;
+ when Iir_Kind_Selected_Name =>
+ declare
+ Lib : Iir_Library_Declaration;
+ begin
+ Lib := Get_Library (Get_Identifier (Get_Prefix (Unit)),
+ Get_Location (Unit));
+ return Find_Primary_Unit (Lib, Get_Identifier (Unit));
+ end;
+ when Iir_Kind_Entity_Aspect_Entity =>
+ return Find_Secondary_Unit
+ (Get_Design_Unit (Get_Entity (Unit)),
+ Get_Identifier (Get_Architecture (Unit)));
+ when others =>
+ Error_Kind ("find_design_unit", Unit);
+ end case;
+ end Find_Design_Unit;
+
+ function Is_Obsolete (Design_Unit : Iir_Design_Unit; Loc : Iir)
+ return Boolean
+ is
+ procedure Error_Obsolete (Msg : String) is
+ begin
+ if not Flags.Flag_Elaborate_With_Outdated then
+ Error_Msg_Sem (Msg, Loc);
+ end if;
+ end Error_Obsolete;
+
+ List : Iir_List;
+ El : Iir;
+ Unit : Iir_Design_Unit;
+ U_Ts : Time_Stamp_Id;
+ Du_Ts : Time_Stamp_Id;
+ begin
+ if Get_Date (Design_Unit) = Date_Obsolete then
+ Error_Obsolete (Disp_Node (Design_Unit) & " is obsolete");
+ return True;
+ end if;
+ List := Get_Dependence_List (Design_Unit);
+ if List = Null_Iir_List then
+ return False;
+ end if;
+ Du_Ts := Get_Analysis_Time_Stamp (Get_Design_File (Design_Unit));
+ for I in Natural loop
+ El := Get_Nth_Element (List, I);
+ exit when El = Null_Iir;
+ Unit := Find_Design_Unit (El);
+ if Unit /= Null_Iir then
+ U_Ts := Get_Analysis_Time_Stamp (Get_Design_File (Unit));
+ if Files_Map.Is_Gt (U_Ts, Du_Ts) then
+ Error_Obsolete
+ (Disp_Node (Design_Unit) & " is obsoleted by " &
+ Disp_Node (Unit));
+ return True;
+ elsif Is_Obsolete (Unit, Loc) then
+ Error_Obsolete
+ (Disp_Node (Design_Unit) & " depends on obsolete unit");
+ return True;
+ end if;
+ end if;
+ end loop;
+ return False;
+ end Is_Obsolete;
+
+ procedure Load_Parse_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir)
+ is
+ use Scanner;
+ Line, Off: Natural;
+ Pos: Source_Ptr;
+ Res: Iir;
+ Design_File : Iir_Design_File;
+ Fe : Source_File_Entry;
+ begin
+ -- The unit must not be loaded.
+ pragma Assert (Get_Date_State (Design_Unit) = Date_Disk);
+
+ -- Load and parse the unit.
+ Design_File := Get_Design_File (Design_Unit);
+ Fe := Files_Map.Load_Source_File
+ (Get_Design_File_Directory (Design_File),
+ Get_Design_File_Filename (Design_File));
+ if Fe = No_Source_File_Entry then
+ Error_Msg
+ ("cannot load " & Disp_Node (Get_Library_Unit (Design_Unit)));
+ raise Compilation_Error;
+ end if;
+ Set_File (Fe);
+
+ if not Files_Map.Is_Eq
+ (Files_Map.Get_File_Time_Stamp (Get_Current_Source_File),
+ Get_File_Time_Stamp (Design_File))
+ then
+ Error_Msg_Sem
+ ("file " & Image (Get_Design_File_Filename (Design_File))
+ & " has changed and must be reanalysed", Loc);
+ raise Compilation_Error;
+ elsif Get_Date (Design_Unit) = Date_Obsolete then
+ Error_Msg_Sem
+ (''' & Disp_Node (Get_Library_Unit (Design_Unit))
+ & "' is not anymore in the file",
+ Design_Unit);
+ raise Compilation_Error;
+ end if;
+ Pos := Get_Design_Unit_Source_Pos (Design_Unit);
+ Line := Natural (Get_Design_Unit_Source_Line (Design_Unit));
+ Off := Natural (Get_Design_Unit_Source_Col (Design_Unit));
+ Files_Map.File_Add_Line_Number (Get_Current_Source_File, Line, Pos);
+ Set_Current_Position (Pos + Source_Ptr (Off));
+ Res := Parse.Parse_Design_Unit;
+ Close_File;
+ if Res = Null_Iir then
+ raise Compilation_Error;
+ end if;
+ Set_Date_State (Design_Unit, Date_Parse);
+ -- FIXME: check the library unit read is the one expected.
+ -- Copy node.
+ Iirs_Utils.Free_Recursive (Get_Library_Unit (Design_Unit));
+ Set_Library_Unit (Design_Unit, Get_Library_Unit (Res));
+ Set_Design_Unit (Get_Library_Unit (Res), Design_Unit);
+ Set_Parent (Get_Library_Unit (Res), Design_Unit);
+ Set_Context_Items (Design_Unit, Get_Context_Items (Res));
+ Location_Copy (Design_Unit, Res);
+ Free_Dependence_List (Design_Unit);
+ Set_Dependence_List (Design_Unit, Get_Dependence_List (Res));
+ Set_Dependence_List (Res, Null_Iir_List);
+ Free_Iir (Res);
+ end Load_Parse_Design_Unit;
+
+ -- Load, parse, semantize, back-end a design_unit if necessary.
+ procedure Load_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir) is
+ begin
+ if Get_Date_State (Design_Unit) = Date_Disk then
+ Load_Parse_Design_Unit (Design_Unit, Loc);
+ end if;
+
+ if Get_Date_State (Design_Unit) = Date_Parse then
+ -- Analyze the design unit.
+
+ if Get_Date (Design_Unit) = Date_Analyzed then
+ -- Work-around for an internal check in sem.
+ -- FIXME: to be removed ?
+ Set_Date (Design_Unit, Date_Parsed);
+ end if;
+
+ -- Avoid infinite recursion, if the unit is self-referenced.
+ Set_Date_State (Design_Unit, Date_Analyze);
+
+ Sem_Scopes.Push_Interpretations;
+ Back_End.Finish_Compilation (Design_Unit);
+ Sem_Scopes.Pop_Interpretations;
+
+ end if;
+
+ case Get_Date (Design_Unit) is
+ when Date_Parsed =>
+ raise Internal_Error;
+ when Date_Analyzing =>
+ -- Self-referenced unit.
+ return;
+ when Date_Analyzed =>
+ -- FIXME: Accept it silently ?
+ -- Note: this is used when Flag_Elaborate_With_Outdated is set.
+ -- This is also used by anonymous configuration declaration.
+ null;
+ when Date_Uptodate =>
+ return;
+ when Date_Valid =>
+ null;
+ when Date_Obsolete =>
+ if not Flags.Flag_Elaborate_With_Outdated then
+ Error_Msg_Sem (Disp_Node (Design_Unit) & " is obsolete", Loc);
+ return;
+ end if;
+ when others =>
+ raise Internal_Error;
+ end case;
+
+ if not Flags.Flag_Elaborate_With_Outdated
+ and then Is_Obsolete (Design_Unit, Loc)
+ then
+ Set_Date (Design_Unit, Date_Obsolete);
+ end if;
+ end Load_Design_Unit;
+
+ -- Return the declaration of primary unit NAME of LIBRARY.
+ function Find_Primary_Unit
+ (Library: Iir_Library_Declaration; Name: Name_Id)
+ return Iir_Design_Unit
+ is
+ Unit : Iir_Design_Unit;
+ begin
+ Unit := Unit_Hash_Table (Name mod Unit_Hash_Length);
+ while Unit /= Null_Iir loop
+ if Get_Identifier (Unit) = Name
+ and then Get_Library (Get_Design_File (Unit)) = Library
+ then
+ case Get_Kind (Get_Library_Unit (Unit)) is
+ when Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Configuration_Declaration =>
+ -- Only return a primary unit.
+ return Unit;
+ when Iir_Kind_Package_Body
+ | Iir_Kind_Architecture_Body =>
+ null;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end if;
+ Unit := Get_Hash_Chain (Unit);
+ end loop;
+
+ -- The primary unit is not in the library, return null.
+ return Null_Iir;
+ end Find_Primary_Unit;
+
+ function Load_Primary_Unit
+ (Library: Iir_Library_Declaration; Name: Name_Id; Loc : Iir)
+ return Iir_Design_Unit
+ is
+ Design_Unit: Iir_Design_Unit;
+ begin
+ Design_Unit := Find_Primary_Unit (Library, Name);
+ if Design_Unit /= Null_Iir then
+ Load_Design_Unit (Design_Unit, Loc);
+ end if;
+ return Design_Unit;
+ end Load_Primary_Unit;
+
+ -- Return the declaration of secondary unit NAME for PRIMARY, or null if
+ -- not found.
+ function Find_Secondary_Unit (Primary: Iir_Design_Unit; Name: Name_Id)
+ return Iir_Design_Unit
+ is
+ Design_Unit: Iir_Design_Unit;
+ Library_Unit: Iir;
+ Primary_Ident: Name_Id;
+ Lib_Prim : Iir;
+ begin
+ Lib_Prim := Get_Library (Get_Design_File (Primary));
+ Primary_Ident := Get_Identifier (Get_Library_Unit (Primary));
+ Design_Unit := Unit_Hash_Table (Primary_Ident mod Unit_Hash_Length);
+ while Design_Unit /= Null_Iir loop
+ Library_Unit := Get_Library_Unit (Design_Unit);
+
+ -- The secondary is always in the same library as the primary.
+ if Get_Library (Get_Design_File (Design_Unit)) = Lib_Prim then
+ -- Set design_unit to null iff this is not the correct
+ -- design unit.
+ case Get_Kind (Library_Unit) is
+ when Iir_Kind_Architecture_Body =>
+ -- The entity field can be either an identifier (if the
+ -- library unit was not loaded) or an access to the entity
+ -- unit.
+ if (Get_Entity_Identifier_Of_Architecture (Library_Unit)
+ = Primary_Ident)
+ and then Get_Identifier (Library_Unit) = Name
+ then
+ return Design_Unit;
+ end if;
+ when Iir_Kind_Package_Body =>
+ if Name = Null_Identifier
+ and then Get_Identifier (Library_Unit) = Primary_Ident
+ then
+ return Design_Unit;
+ end if;
+ when others =>
+ null;
+ end case;
+ end if;
+ Design_Unit := Get_Hash_Chain (Design_Unit);
+ end loop;
+
+ -- The architecture or the body is not in the library, return null.
+ return Null_Iir;
+ end Find_Secondary_Unit;
+
+ -- Load an secondary unit and analyse it.
+ function Load_Secondary_Unit
+ (Primary: Iir_Design_Unit; Name: Name_Id; Loc : Iir)
+ return Iir_Design_Unit
+ is
+ Design_Unit: Iir_Design_Unit;
+ begin
+ Design_Unit := Find_Secondary_Unit (Primary, Name);
+ if Design_Unit /= Null_Iir then
+ Load_Design_Unit (Design_Unit, Loc);
+ end if;
+ return Design_Unit;
+ end Load_Secondary_Unit;
+
+ function Find_Entity_For_Component (Name: Name_Id) return Iir_Design_Unit
+ is
+ Res : Iir_Design_Unit := Null_Iir;
+ Unit : Iir_Design_Unit;
+ begin
+ Unit := Unit_Hash_Table (Name mod Unit_Hash_Length);
+ while Unit /= Null_Iir loop
+ if Get_Identifier (Unit) = Name
+ and then (Get_Kind (Get_Library_Unit (Unit))
+ = Iir_Kind_Entity_Declaration)
+ then
+ if Res = Null_Iir then
+ Res := Unit;
+ else
+ -- Many entities.
+ return Null_Iir;
+ end if;
+ end if;
+ Unit := Get_Hash_Chain (Unit);
+ end loop;
+
+ return Res;
+ end Find_Entity_For_Component;
+
+ function Get_Libraries_Chain return Iir_Library_Declaration is
+ begin
+ return Libraries_Chain;
+ end Get_Libraries_Chain;
+end Libraries;
diff --git a/src/libraries.ads b/src/libraries.ads
new file mode 100644
index 000000000..ecb048c94
--- /dev/null
+++ b/src/libraries.ads
@@ -0,0 +1,188 @@
+-- VHDL libraries handling.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with Iirs; use Iirs;
+with Std_Names;
+
+package Libraries is
+ -- This package defines the library manager.
+ -- The purpose of the library manager is to associate library logical names
+ -- with host-dependent library.
+ --
+ -- In this implementation a host-dependent library is a file, whose name
+ -- is logical name of the library with the extension '.cf'. This file
+ -- contains the name and the position (filename, line, column and offset)
+ -- of all library unit of the library.
+ --
+ -- The working library WORK can be aliased with a ressource library,
+ -- they share the same host-dependenet library whose name is the name
+ -- of the ressource library. This is done by load_work_library.
+
+ -- Location for a command line.
+ Command_Line_Location : Location_Type;
+
+ -- Library declaration for the std library.
+ -- This is also the first library of the libraries chain.
+ Std_Library : Iir_Library_Declaration := Null_Iir;
+
+ -- Library declaration for the work library.
+ -- Note: the identifier of the work_library is work_library_name, which
+ -- may be different from 'WORK'.
+ Work_Library: Iir_Library_Declaration;
+
+ -- Name of the WORK library.
+ Work_Library_Name : Name_Id := Std_Names.Name_Work;
+
+ -- Directory of the work library.
+ -- Set by default by INIT_PATHES to the local directory.
+ Work_Directory : Name_Id;
+
+ -- Local (current) directory.
+ Local_Directory : Name_Id;
+
+ -- Correspond to "" (empty identifier). Used to denote current directory
+ -- for library directories.
+ Name_Nil : Name_Id;
+
+ -- Chain of obsoleted design units.
+ Obsoleted_Design_Units : Iir := Null_Iir;
+
+ -- Initialize library pathes table.
+ -- Set the local path.
+ procedure Init_Pathes;
+
+ -- Add PATH in the search path.
+ procedure Add_Library_Path (Path : String);
+
+ -- Get the number of path in the search pathes.
+ function Get_Nbr_Pathes return Natural;
+
+ -- Get path N.
+ function Get_Path (N : Natural) return Name_Id;
+
+ -- Set PATH as the path of the work library.
+ procedure Set_Work_Library_Path (Path : String);
+
+ -- Set the name of the work library, load the work library.
+ -- Note: the scanner shouldn't be in use, since this function uses it.
+ -- If EMPTY is set, the work library is just created and not loaded.
+ procedure Load_Work_Library (Empty : Boolean := False);
+
+ -- Initialize the library manager and load the STD library.
+ -- If BUILD_STANDARD is false, the std.standard library is not created.
+ procedure Load_Std_Library (Build_Standard : Boolean := True);
+
+ -- Save the work library as a host-dependent library.
+ procedure Save_Work_Library;
+
+ -- Start the analyse a file (ie load and parse it).
+ -- The file is read from the current directory (unless FILE_NAME is an
+ -- absolute path).
+ -- Emit an error if the file cannot be opened.
+ -- Return NULL_IIR in case of parse error.
+ function Load_File (File_Name: Name_Id) return Iir_Design_File;
+ function Load_File (File : Source_File_Entry) return Iir_Design_File;
+
+ -- Load, parse, semantize, back-end a design_unit if necessary.
+ -- Check Design_Unit is not obsolete.
+ -- LOC is the location where the design unit was needed, in case of error.
+ procedure Load_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir);
+
+ -- Load and parse DESIGN_UNIT.
+ -- Contrary to Load_Design_Unit, the design_unit is not analyzed.
+ -- Also, the design_unit must not have been already loaded.
+ -- Used almost only by Load_Design_Unit.
+ procedure Load_Parse_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir);
+
+ -- Remove the same file as DESIGN_FILE from work library and all of its
+ -- units.
+ procedure Purge_Design_File (Design_File : Iir_Design_File);
+
+ -- Just return the design_unit for NAME, or NULL if not found.
+ function Find_Primary_Unit
+ (Library: Iir_Library_Declaration; Name: Name_Id)
+ return Iir_Design_Unit;
+
+ -- Load an already analyzed primary unit NAME from library LIBRARY
+ -- and compile it.
+ -- Return NULL_IIR if not found (ie, NAME does not correspond to a
+ -- library unit identifier).
+ function Load_Primary_Unit
+ (Library: Iir_Library_Declaration; Name: Name_Id; Loc : Iir)
+ return Iir_Design_Unit;
+
+ -- Find the secondary unit of PRIMARY.
+ -- If PRIMARY is a package declaration, returns the package body,
+ -- If PRIMARY is an entity declaration, returns the architecture NAME.
+ -- Return NULL_IIR if not found.
+ function Find_Secondary_Unit (Primary: Iir_Design_Unit; Name: Name_Id)
+ return Iir_Design_Unit;
+
+ -- Load an secondary unit of primary unit PRIMARY and analyse it.
+ -- NAME must be set only for an architecture.
+ function Load_Secondary_Unit
+ (Primary: Iir_Design_Unit; Name: Name_Id; Loc : Iir)
+ return Iir_Design_Unit;
+
+ -- Get or create a library from an identifier.
+ -- LOC is used only to report errors.
+ function Get_Library (Ident : Name_Id; Loc : Location_Type)
+ return Iir_Library_Declaration;
+
+ -- Add or replace an design unit in the work library.
+ -- DECL must not have a chain (because it may be modified).
+ --
+ -- If the design_file of UNIT is not already in the library, a new one
+ -- is created.
+ --
+ -- Units are always appended to the design_file. Therefore, the order is
+ -- kept.
+ --
+ -- If KEEP_OBSOLETE is True, obsoleted units are kept in the library.
+ -- This is used when a whole design file has to be added in the library and
+ -- then processed (without that feature, redefined units would disappear).
+ procedure Add_Design_Unit_Into_Library
+ (Unit : in Iir_Design_Unit; Keep_Obsolete : Boolean := False);
+
+ -- Put all design_units of FILE into the work library, by calling
+ -- Add_Design_Unit_Into_Library.
+ -- FILE is updated since it may changed (FILE is never put in the library,
+ -- a new one is created).
+ procedure Add_Design_File_Into_Library (File : in out Iir_Design_File);
+
+ -- Return the latest architecture analysed for entity ENTITY.
+ function Get_Latest_Architecture (Entity: Iir_Entity_Declaration)
+ return Iir_Architecture_Body;
+
+ -- Return the design unit (stubed if not loaded) from UNIT.
+ -- UNIT may be either a design unit, in this case UNIT is returned,
+ -- or a selected name, in this case the prefix is a library name and
+ -- the suffix a primary design unit name,
+ -- or an entity_aspect_entity to designate an architectrure.
+ -- Return null_iir if the design unit is not found.
+ function Find_Design_Unit (Unit : Iir) return Iir_Design_Unit;
+
+ -- Find an entity whose name is NAME in any library.
+ -- If there is no such entity, return NULL_IIR.
+ -- If there are severals entities, return NULL_IIR;
+ function Find_Entity_For_Component (Name: Name_Id) return Iir_Design_Unit;
+
+ -- Get the chain of libraries. Can be used only to read (it musn't be
+ -- modified).
+ function Get_Libraries_Chain return Iir_Library_Declaration;
+end Libraries;
diff --git a/src/lists.adb b/src/lists.adb
new file mode 100644
index 000000000..38afea595
--- /dev/null
+++ b/src/lists.adb
@@ -0,0 +1,257 @@
+-- Lists data type.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+with GNAT.Table;
+
+package body Lists is
+ type Node_Array_Fat is array (Natural) of Node_Type;
+ type Node_Array_Fat_Acc is access Node_Array_Fat;
+
+ type List_Record is record
+ Max : Natural;
+ Nbr : Natural;
+ Next : List_Type;
+ Els : Node_Array_Fat_Acc;
+ end record;
+
+ package Listt is new GNAT.Table
+ (Table_Component_Type => List_Record,
+ Table_Index_Type => List_Type,
+ Table_Low_Bound => 4,
+ Table_Initial => 128,
+ Table_Increment => 100);
+
+ --function Get_Max_Nbr_Elements (List : List_Type) return Natural;
+ --pragma Inline (Get_Max_Nbr_Elements);
+
+ --procedure Set_Max_Nbr_Elements (List : List_Type; Max : Natural);
+ --pragma Inline (Set_Max_Nbr_Elements);
+
+ procedure List_Set_Nbr_Elements (List : List_Type; Nbr : Natural);
+ pragma Inline (List_Set_Nbr_Elements);
+
+ function Get_Nbr_Elements (List: List_Type) return Natural is
+ begin
+ return Listt.Table (List).Nbr;
+ end Get_Nbr_Elements;
+
+ procedure List_Set_Nbr_Elements (List : List_Type; Nbr : Natural) is
+ begin
+ Listt.Table (List).Nbr := Nbr;
+ end List_Set_Nbr_Elements;
+
+ --function Get_Max_Nbr_Elements (List : List_Type) return Natural is
+ --begin
+ -- return Listt.Table (List).Max;
+ --end Get_Max_Nbr_Elements;
+
+ --procedure Set_Max_Nbr_Elements (List : List_Type; Max : Natural) is
+ --begin
+ -- Listt.Table (List).Max := Max;
+ --end Set_Max_Nbr_Elements;
+
+ function Get_Nth_Element (List: List_Type; N: Natural)
+ return Node_Type
+ is
+ begin
+ if N >= Listt.Table (List).Nbr then
+ return Null_Node;
+ end if;
+ return Listt.Table (List).Els (N);
+ end Get_Nth_Element;
+
+ -- Replace an element selected by position.
+ procedure Replace_Nth_Element (List: List_Type; N: Natural; El: Node_Type)
+ is
+ begin
+ if N >= Listt.Table (List).Nbr then
+ raise Program_Error;
+ end if;
+ Listt.Table (List).Els (N) := El;
+ end Replace_Nth_Element;
+
+ -- Be sure an element can be added to LIST.
+ -- It doesn't change the number of elements.
+ procedure List_Grow (List: List_Type)
+ is
+ L : List_Record renames Listt.Table (List);
+
+ -- Be careful: size in bytes.
+ function Alloc (Size : Natural) return Node_Array_Fat_Acc;
+ pragma Import (C, Alloc, "malloc");
+
+ function Realloc (Ptr : Node_Array_Fat_Acc; Size : Natural)
+ return Node_Array_Fat_Acc;
+ pragma Import (C, Realloc, "realloc");
+
+ Tmp : Node_Array_Fat_Acc;
+ N : Natural;
+ begin
+ if L.Nbr < L.Max then
+ return;
+ end if;
+ if L.Max = 0 then
+ N := 8;
+ Tmp := Alloc (N * Node_Type'Size / System.Storage_Unit);
+ else
+ N := L.Max * 2;
+ Tmp := Realloc (L.Els, N * Node_Type'Size / System.Storage_Unit);
+ end if;
+ L.Els := Tmp;
+ L.Max := N;
+ end List_Grow;
+
+ procedure Append_Element (List: List_Type; Element: Node_Type)
+ is
+ L : List_Record renames Listt.Table (List);
+ begin
+ if L.Nbr >= L.Max then
+ List_Grow (List);
+ end if;
+ L.Els (L.Nbr) := Element;
+ L.Nbr := L.Nbr + 1;
+ end Append_Element;
+
+ -- Return the last element of the list, or null.
+ function Get_Last_Element (List: List_Type) return Node_Type
+ is
+ L : List_Record renames Listt.Table (List);
+ begin
+ if L.Nbr = 0 then
+ return Null_Node;
+ else
+ return L.Els (L.Nbr - 1);
+ end if;
+ end Get_Last_Element;
+
+ -- Return the first element of the list, or null.
+ function Get_First_Element (List: List_Type) return Node_Type is
+ begin
+ if Listt.Table (List).Nbr = 0 then
+ return Null_Node;
+ else
+ return Listt.Table (List).Els (0);
+ end if;
+ end Get_First_Element;
+
+ -- Add (append) an element only if it was not already present in the list.
+ procedure Add_Element (List: List_Type; El: Node_Type)
+ is
+ Nbr : constant Natural := Get_Nbr_Elements (List);
+ begin
+ for I in 0 .. Nbr - 1 loop
+ if Listt.Table (List).Els (I) = El then
+ return;
+ end if;
+ end loop;
+
+ Append_Element (List, El);
+ end Add_Element;
+
+ procedure Remove_Nth_Element (List: List_Type; N: Natural)
+ is
+ Nbr : constant Natural := Get_Nbr_Elements (List);
+ begin
+ if N >= Nbr then
+ raise Program_Error;
+ end if;
+ for I in N .. Nbr - 2 loop
+ Listt.Table (List).Els (I) := Listt.Table (List).Els (I + 1);
+ end loop;
+ Listt.Table (List).Nbr := Nbr - 1;
+ end Remove_Nth_Element;
+
+ procedure Set_Nbr_Elements (List: List_Type; N: Natural) is
+ begin
+ if N > Get_Nbr_Elements (List) then
+ raise Program_Error;
+ end if;
+ List_Set_Nbr_Elements (List, N);
+ end Set_Nbr_Elements;
+
+ -- Return the position of the last element.
+ -- Return -1 if the list is empty.
+ function Get_Last_Element_Position (List: List_Type) return Integer is
+ begin
+ return Get_Nbr_Elements (List) - 1;
+ end Get_Last_Element_Position;
+
+ function Get_Nbr_Elements_Safe (List: List_Type) return Natural is
+ begin
+ if List = Null_List then
+ return 0;
+ else
+ return Get_Nbr_Elements (List);
+ end if;
+ end Get_Nbr_Elements_Safe;
+
+ -- Empty the list
+ procedure Empty_List (List: List_Type) is
+ begin
+ Set_Nbr_Elements (List, 0);
+ end Empty_List;
+
+ -- Chain of unused lists.
+ Free_Chain : List_Type := Null_List;
+
+ function Create_List return List_Type
+ is
+ Res : List_Type;
+ begin
+ if Free_Chain = Null_List then
+ Listt.Increment_Last;
+ Res := Listt.Last;
+ else
+ Res := Free_Chain;
+ Free_Chain := Listt.Table (Res).Next;
+ end if;
+ Listt.Table (Res) := List_Record'(Max => 0, Nbr => 0,
+ Next => Null_List, Els => null);
+ return Res;
+ end Create_List;
+
+ procedure Free (Ptr : Node_Array_Fat_Acc);
+ pragma Import (C, Free, "free");
+
+ procedure Destroy_List (List : in out List_Type)
+ is
+ begin
+ if List = Null_List then
+ return;
+ end if;
+ if Listt.Table (List).Max > 0 then
+ Free (Listt.Table (List).Els);
+ Listt.Table (List).Els := null;
+ end if;
+ Listt.Table (List).Next := Free_Chain;
+ Free_Chain := List;
+ List := Null_List;
+ end Destroy_List;
+
+ procedure Initialize is
+ begin
+ for I in Listt.First .. Listt.Last loop
+ if Listt.Table (I).Els /= null then
+ Free (Listt.Table (I).Els);
+ end if;
+ end loop;
+ Listt.Free;
+ Listt.Init;
+ end Initialize;
+
+end Lists;
diff --git a/src/lists.ads b/src/lists.ads
new file mode 100644
index 000000000..7645e3403
--- /dev/null
+++ b/src/lists.ads
@@ -0,0 +1,123 @@
+-- Lists data type.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+with Nodes; use Nodes;
+
+package Lists is
+ type List_Type is new Nat32;
+ for List_Type'Size use 32;
+
+ Null_List : constant List_Type := 0;
+
+ List_Others : constant List_Type := 1;
+ List_All : constant List_Type := 2;
+
+ -----------
+ -- Lists --
+ -----------
+
+ -- Iir_Kinds_List
+ -- Lists of elements.
+ -- index is 0 .. nbr_elements - 1.
+ --
+ -- Append an element to (the end of) the list.
+ -- procedure Append_Element (List: in Iir; Element: Iir);
+ --
+ -- Get the N th element in list, starting from 0.
+ -- Return an access to the element or null_iir, if beyond bounds.
+ -- function Get_Nth_Element (List: in Iir; N: Natural) return Iir;
+ --
+ -- Return the last element of the list, or null_iir.
+ -- function Get_Last_Element (List: in Iir) return Iir;
+ --
+ -- Return the first element of the list, or null_iir.
+ -- function Get_First_Element (List: in Iir) return Iir;
+ --
+ -- Replace an element selected by position.
+ -- procedure Replace_Nth_Element (List: in Iir_List; N: Natural; El:Iir);
+ --
+ -- Add (append) an element only if it was not already present in the list.
+ -- Return its position.
+ -- procedure Add_Element (List: in Iir; El: Iir; Position: out integer);
+ -- procedure Add_Element (List: in Iir_List; El: Iir);
+ --
+ -- Return the number of elements in the list.
+ -- This is also 1 + the position of the last element.
+ -- function Get_Nbr_Elements (List: in Iir_List) return Natural;
+ --
+ -- Set the number of elements in the list.
+ -- Can be used only to shrink the list.
+ -- procedure Set_Nbr_Elements (List: in Iir_List; N: Natural);
+ --
+ -- Remove an element from the list.
+ -- procedure remove_Nth_Element (List: in Iir_List; N: Natural);
+ --
+ -- Return the position of the last element.
+ -- Return -1 if the list is empty.
+ -- function Get_Last_Element_Position (List: in Iir_List) return Integer;
+ --
+ -- Empty the list.
+ -- This is also set_nbr_elements (list, 0);
+ -- procedure Empty_List (List: in Iir_List);
+ --
+ -- Alias a list. TARGET must be empty.
+ -- procedure Alias_List (Target: in out Iir; Source: in Iir);
+
+ procedure Append_Element (List: List_Type; Element: Node_Type);
+
+ -- Get the N th element in list, starting from 0.
+ -- Return the element or null_iir, if beyond bounds.
+ function Get_Nth_Element (List: List_Type; N: Natural) return Node_Type;
+
+ function Get_Last_Element (List: List_Type) return Node_Type;
+
+ function Get_First_Element (List: List_Type) return Node_Type;
+
+ procedure Replace_Nth_Element (List: List_Type; N: Natural; El: Node_Type);
+
+ procedure Add_Element (List: List_Type; El: Node_Type);
+
+ -- Return the number of elements in the list.
+ -- This is also 1 + the position of the last element.
+ function Get_Nbr_Elements (List: List_Type) return Natural;
+ pragma Inline (Get_Nbr_Elements);
+
+ -- Same as get_nbr_elements but returns 0 if LIST is NULL_IIR.
+ function Get_Nbr_Elements_Safe (List : List_Type) return Natural;
+
+ -- Set the number of elements in the list.
+ -- Can be used only to shrink the list.
+ procedure Set_Nbr_Elements (List: List_Type; N: Natural);
+
+ procedure Remove_Nth_Element (List : List_Type; N: Natural);
+
+ function Get_Last_Element_Position (List: List_Type) return Integer;
+
+ -- Clear the list.
+ procedure Empty_List (List: List_Type);
+
+ -- Create a list.
+ function Create_List return List_Type;
+
+ -- Destroy a list.
+ procedure Destroy_List (List : in out List_Type);
+
+ -- Free all the lists and reset to initial state.
+ -- Must be used to free the memory used by the lists.
+ procedure Initialize;
+end Lists;
diff --git a/src/name_table.adb b/src/name_table.adb
new file mode 100644
index 000000000..af60ec0b7
--- /dev/null
+++ b/src/name_table.adb
@@ -0,0 +1,359 @@
+-- Name table.
+-- 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 GHDL; 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; use Ada.Text_IO;
+with GNAT.Table;
+
+package body Name_Table is
+ -- A flag that creates verbosity.
+ Debug_Name_Table: constant Boolean := False;
+
+ First_Character_Name_Id : constant Name_Id := 1;
+
+ type Hash_Value_Type is mod 2**32;
+
+ -- An entry in the name table.
+ type Identifier is record
+ Hash: Hash_Value_Type;
+ Next: Name_Id;
+
+ -- FIXME: to be removed (compute from name of next identifier).
+ Length: Natural;
+
+ -- Index in strings_table.
+ Name: Natural;
+
+ -- User infos.
+ Info: Int32;
+ end record;
+
+ -- Hash table.
+ -- Number of entry points.
+ Hash_Table_Size: constant Hash_Value_Type := 1024;
+ Hash_Table: array (0 .. Hash_Table_Size - 1) of Name_Id;
+
+ -- The table to store all the strings.
+ package Strings_Table is new GNAT.Table
+ (Table_Index_Type => Natural,
+ Table_Component_Type => Character,
+ Table_Low_Bound => Natural'First,
+ Table_Initial => 4096,
+ Table_Increment => 100);
+
+ -- A NUL character is stored after each word in the strings_table.
+ -- This is used for compatibility with C.
+ NUL: constant Character := Character'Val (0);
+
+ -- Allocate place in the strings_table, and store the name_buffer into it.
+ -- Also append a NUL.
+ function Store return Natural is
+ Res: Natural;
+ begin
+ Res := Strings_Table.Allocate (Name_Length + 1);
+ Strings_Table.Table (Res .. Res + Name_Length - 1) :=
+ Strings_Table.Table_Type (Name_Buffer (1 .. Name_Length));
+ Strings_Table.Table (Res + Name_Length) := NUL;
+ return Res;
+ end Store;
+
+ package Names_Table is new GNAT.Table
+ (Table_Index_Type => Name_Id,
+ Table_Component_Type => Identifier,
+ Table_Low_Bound => Name_Id'First,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ -- Initialize this package
+ -- This must be called once and only once before any use.
+ procedure Initialize is
+ Pos: Natural;
+ Id: Name_Id;
+ begin
+ Strings_Table.Init;
+ Names_Table.Init;
+ -- Reserve entry 0.
+ if Names_Table.Allocate /= Null_Identifier then
+ raise Program_Error;
+ end if;
+ Strings_Table.Set_Last (1);
+ Names_Table.Table (Null_Identifier) := (Length => 0,
+ Hash => 0,
+ Name => 1,
+ Next => Null_Identifier,
+ Info => 0);
+ -- Store characters.
+ for C in Character loop
+ Pos := Strings_Table.Allocate;
+ Strings_Table.Table (Pos) := C;
+ Id := Names_Table.Allocate;
+ Names_Table.Table (Id) := (Length => 1,
+ Hash => 0,
+ Name => Pos,
+ Next => Null_Identifier,
+ Info => 0);
+ end loop;
+ Hash_Table := (others => Null_Identifier);
+ end Initialize;
+
+ -- Compute the hash value of a string.
+ function Hash return Hash_Value_Type is
+ Res: Hash_Value_Type := 0;
+ begin
+ for I in 1 .. Name_Length loop
+ Res := Res * 7 + Character'Pos(Name_Buffer(I));
+ Res := Res + Res / 2**28;
+ end loop;
+ return Res;
+ end Hash;
+
+ -- Get the string associed to an identifier.
+ function Image (Id: Name_Id) return String is
+ Name_Entry: Identifier renames Names_Table.Table(Id);
+ subtype Result_Type is String (1 .. Name_Entry.Length);
+ begin
+ if Is_Character (Id) then
+ return ''' & Strings_Table.Table (Name_Entry.Name) & ''';
+ else
+ return Result_Type
+ (Strings_Table.Table
+ (Name_Entry.Name .. Name_Entry.Name + Name_Entry.Length - 1));
+ end if;
+ end Image;
+
+ procedure Image (Id : Name_Id)
+ is
+ Name_Entry: Identifier renames Names_Table.Table(Id);
+ begin
+ if Is_Character (Id) then
+ Name_Buffer (1) := Get_Character (Id);
+ Name_Length := 1;
+ else
+ Name_Length := Name_Entry.Length;
+ Name_Buffer (1 .. Name_Entry.Length) := String
+ (Strings_Table.Table
+ (Name_Entry.Name .. Name_Entry.Name + Name_Entry.Length - 1));
+ end if;
+ end Image;
+
+ -- Get the address of the first character of ID.
+ -- The string is NUL-terminated (this is done by get_identifier).
+ function Get_Address (Id: Name_Id) return System.Address is
+ Name_Entry: Identifier renames Names_Table.Table(Id);
+ begin
+ return Strings_Table.Table (Name_Entry.Name)'Address;
+ end Get_Address;
+
+ function Get_Name_Length (Id: Name_Id) return Natural is
+ begin
+ return Names_Table.Table(Id).Length;
+ end Get_Name_Length;
+
+ function Is_Character (Id: Name_Id) return Boolean is
+ begin
+ return Id >= First_Character_Name_Id and then
+ Id <= First_Character_Name_Id + Character'Pos (Character'Last);
+ end Is_Character;
+
+ -- Get the character associed to an identifier.
+ function Get_Character (Id: Name_Id) return Character is
+ begin
+ pragma Assert (Is_Character (Id));
+ return Character'Val (Id - First_Character_Name_Id);
+ end Get_Character;
+
+ -- Get and set the info field associated with each identifier.
+ -- Used to store interpretations of the name.
+ function Get_Info (Id: Name_Id) return Int32 is
+ begin
+ return Names_Table.Table (Id).Info;
+ end Get_Info;
+
+ procedure Set_Info (Id: Name_Id; Info: Int32) is
+ begin
+ Names_Table.Table (Id).Info := Info;
+ end Set_Info;
+
+ function Compare_Name_Buffer_With_Name (Id : Name_Id) return Boolean
+ is
+ Ne: Identifier renames Names_Table.Table(Id);
+ begin
+ return String (Strings_Table.Table (Ne.Name .. Ne.Name + Ne.Length - 1))
+ = Name_Buffer (1 .. Name_Length);
+ end Compare_Name_Buffer_With_Name;
+
+ -- Get or create an entry in the name table.
+ -- The string is taken from NAME_BUFFER and NAME_LENGTH.
+ function Get_Identifier return Name_Id
+ is
+ Hash_Value, Hash_Index: Hash_Value_Type;
+ Res: Name_Id;
+ begin
+ Hash_Value := Hash;
+ Hash_Index := Hash_Value mod Hash_Table_Size;
+
+ if Debug_Name_Table then
+ Put_Line ("get_identifier " & Name_Buffer (1 .. Name_Length));
+ end if;
+
+ Res := Hash_Table (Hash_Index);
+ while Res /= Null_Identifier loop
+ --Put_Line ("compare with " & Get_String (Res));
+ if Names_Table.Table (Res).Hash = Hash_Value
+ and then Names_Table.Table (Res).Length = Name_Length
+ and then Compare_Name_Buffer_With_Name (Res)
+ then
+ --Put_Line ("found");
+ return Res;
+ end if;
+ Res := Names_Table.Table (Res).Next;
+ end loop;
+ Res := Names_Table.Allocate;
+ Names_Table.Table (Res) := (Length => Name_Length,
+ Hash => Hash_Value,
+ Name => Store,
+ Next => Hash_Table (Hash_Index),
+ Info => 0);
+ Hash_Table (Hash_Index) := Res;
+ --Put_Line ("created");
+ return Res;
+ end Get_Identifier;
+
+ function Get_Identifier_No_Create return Name_Id
+ is
+ Hash_Value, Hash_Index: Hash_Value_Type;
+ Res: Name_Id;
+ begin
+ Hash_Value := Hash;
+ Hash_Index := Hash_Value mod Hash_Table_Size;
+
+ Res := Hash_Table (Hash_Index);
+ while Res /= Null_Identifier loop
+ if Names_Table.Table (Res).Hash = Hash_Value
+ and then Names_Table.Table (Res).Length = Name_Length
+ and then Compare_Name_Buffer_With_Name (Res)
+ then
+ return Res;
+ end if;
+ Res := Names_Table.Table (Res).Next;
+ end loop;
+ return Null_Identifier;
+ end Get_Identifier_No_Create;
+
+ -- Get or create an entry in the name table.
+ function Get_Identifier (Str: String) return Name_Id is
+ begin
+ Name_Length := Str'Length;
+ Name_Buffer (1 .. Name_Length) := Str;
+ return Get_Identifier;
+ end Get_Identifier;
+
+ function Get_Identifier (Char: Character) return Name_Id is
+ begin
+ return First_Character_Name_Id + Character'Pos (Char);
+ end Get_Identifier;
+
+ -- Be sure all info fields have their default value.
+ procedure Assert_No_Infos is
+ Err: Boolean := False;
+ begin
+ for I in Names_Table.First .. Names_Table.Last loop
+ if Get_Info (I) /= 0 then
+ Err := True;
+ Put_Line ("still infos in" & Name_Id'Image (I) & ", ie: "
+ & Image (I) & ", info ="
+ & Int32'Image (Names_Table.Table (I).Info));
+ end if;
+ end loop;
+ if Err then
+ raise Program_Error;
+ end if;
+ end Assert_No_Infos;
+
+ -- Return the latest name_id used.
+ -- kludge, use only for debugging.
+ function Last_Name_Id return Name_Id is
+ begin
+ return Names_Table.Last;
+ end Last_Name_Id;
+
+ -- Used to debug.
+ -- Disp the strings table, one word per line.
+ procedure Dump;
+ pragma Unreferenced (Dump);
+
+ procedure Dump
+ is
+ First: Natural;
+ begin
+ Put_Line ("strings_table:");
+ First := 0;
+ for I in 0 .. Strings_Table.Last loop
+ if Strings_Table.Table(I) = NUL then
+ Put_Line (Natural'Image (First) & ": "
+ & String (Strings_Table.Table (First .. I - 1)));
+ First := I + 1;
+ end if;
+ end loop;
+ end Dump;
+
+ function Get_Hash_Entry_Length (H : Hash_Value_Type) return Natural
+ is
+ Res : Natural := 0;
+ N : Name_Id;
+ begin
+ N := Hash_Table (H);
+ while N /= Null_Identifier loop
+ Res := Res + 1;
+ N := Names_Table.Table (N).Next;
+ end loop;
+ return Res;
+ end Get_Hash_Entry_Length;
+
+ procedure Disp_Stats
+ is
+ Min : Natural;
+ Max : Natural;
+ N : Natural;
+ begin
+ Put_Line ("Name table statistics:");
+ Put_Line (" number of identifiers: " & Name_Id'Image (Last_Name_Id));
+ Put_Line (" size of strings: " & Natural'Image (Strings_Table.Last));
+ Put_Line (" hash distribution (number of entries per length):");
+ Min := Natural'Last;
+ Max := Natural'First;
+ for I in Hash_Table'Range loop
+ N := Get_Hash_Entry_Length (I);
+ Min := Natural'Min (Min, N);
+ Max := Natural'Max (Max, N);
+ end loop;
+ declare
+ type Nat_Array is array (Min .. Max) of Natural;
+ S : Nat_Array := (others => 0);
+ begin
+ for I in Hash_Table'Range loop
+ N := Get_Hash_Entry_Length (I);
+ S (N) := S (N) + 1;
+ end loop;
+ for I in S'Range loop
+ if S (I) /= 0 then
+ Put_Line (" " & Natural'Image (I)
+ & ":" & Natural'Image (S (I)));
+ end if;
+ end loop;
+ end;
+ end Disp_Stats;
+end Name_Table;
diff --git a/src/name_table.ads b/src/name_table.ads
new file mode 100644
index 000000000..c3d3e72f1
--- /dev/null
+++ b/src/name_table.ads
@@ -0,0 +1,98 @@
+-- Name table.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System;
+with Types; use Types;
+
+-- A very simple name table.
+-- This is an hash table, such as id1=id2 <=> get_string(id1)=get_string(id2).
+
+package Name_Table is
+ -- Initialize the package, ie create tables.
+ procedure Initialize;
+
+ -- Get an entry in the name table.
+ -- (entries for characters are already built).
+ function Get_Identifier (Char: Character) return Name_Id;
+ pragma Inline (Get_Identifier);
+
+ -- Get or create an entry in the name table.
+ -- If an entry is created, its token value is tok_identifier.
+ -- Note:
+ -- an identifier is represented in all lower case letter,
+ -- an extended identifier is represented in backslashes, double internal
+ -- backslashes are simplified,
+ -- a string is represented by its contents (without the quotation
+ -- characters, and simplified),
+ -- a bit string is represented by its raw contents (no simplification).
+ function Get_Identifier (Str: String) return Name_Id;
+
+ -- Get the string associed to a name.
+ -- If the name is a character, then single quote are added.
+ function Image (Id: Name_Id) return String;
+
+ -- Get the address of the first character of ID.
+ -- The string is NUL-terminated (this is done by get_identifier).
+ function Get_Address (Id: Name_Id) return System.Address;
+
+ -- Get the length of ID.
+ function Get_Name_Length (Id: Name_Id) return Natural;
+ pragma Inline (Get_Name_Length);
+
+ -- Get the character associed to a name.
+ function Get_Character (Id: Name_Id) return Character;
+ pragma Inline (Get_Character);
+
+ -- Return TRUE iff ID is a character.
+ function Is_Character (Id: Name_Id) return Boolean;
+ pragma Inline (Is_Character);
+
+ -- Get or create an entry in the name table, use NAME_BUFFER/NAME_LENGTH.
+ function Get_Identifier return Name_Id;
+
+ -- Like GET_IDENTIFIER, but return NULL_IDENTIFIER if the identifier
+ -- is not found (and do not create an entry for it).
+ function Get_Identifier_No_Create return Name_Id;
+
+ -- Set NAME_BUFFER/NAME_LENGTH with the image of ID.
+ procedure Image (Id : Name_Id);
+
+ -- Get and set the info field associated with each identifier.
+ -- Used to store interpretations of the name.
+ function Get_Info (Id: Name_Id) return Int32;
+ pragma Inline (Get_Info);
+ procedure Set_Info (Id: Name_Id; Info: Int32);
+ pragma Inline (Set_Info);
+
+ -- Return the latest name_id used.
+ -- kludge, use only for debugging.
+ function Last_Name_Id return Name_Id;
+
+ -- Be sure all info fields have their default value.
+ procedure Assert_No_Infos;
+
+ -- This buffer is used by get_token to set the name.
+ -- This can be seen as a copy buffer but this is necessary for two reasons:
+ -- names case must be 'normalized', because VHDL is case insensitive.
+ Name_Buffer : String (1 .. 1024);
+ -- The length of the name string.
+ Name_Length: Natural;
+
+ -- Disp statistics.
+ -- Used for debugging.
+ procedure Disp_Stats;
+end Name_Table;
diff --git a/src/nodes.adb b/src/nodes.adb
new file mode 100644
index 000000000..2dc7736ce
--- /dev/null
+++ b/src/nodes.adb
@@ -0,0 +1,467 @@
+-- Internal node type and operations.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with GNAT.Table;
+
+package body Nodes is
+ -- Suppress the access check of the table base. This is really safe to
+ -- suppress this check because the table base cannot be null.
+ pragma Suppress (Access_Check);
+
+ -- Suppress the index check on the table.
+ -- Could be done during non-debug, since this may catch errors (reading
+ -- Null_Node or Error_Node).
+ --pragma Suppress (Index_Check);
+
+ -- Suppress discriminant checks on the table. Relatively safe, since
+ -- iirs do their own checks.
+ pragma Suppress (Discriminant_Check);
+
+ package Nodet is new GNAT.Table
+ (Table_Component_Type => Node_Record,
+ Table_Index_Type => Node_Type,
+ Table_Low_Bound => 2,
+ Table_Initial => 1024,
+ Table_Increment => 100);
+
+ function Get_Last_Node return Node_Type is
+ begin
+ return Nodet.Last;
+ end Get_Last_Node;
+
+ Free_Chain : Node_Type := Null_Node;
+
+ -- Just to have the default value.
+ pragma Warnings (Off);
+ Init_Short : Node_Record (Format_Short);
+ Init_Medium : Node_Record (Format_Medium);
+ Init_Fp : Node_Record (Format_Fp);
+ Init_Int : Node_Record (Format_Int);
+ pragma Warnings (On);
+
+ function Create_Node (Format : Format_Type) return Node_Type
+ is
+ Res : Node_Type;
+ begin
+ if Format = Format_Medium then
+ -- Allocate a first node.
+ Nodet.Increment_Last;
+ Res := Nodet.Last;
+ -- Check alignment.
+ if Res mod 2 = 1 then
+ Set_Field1 (Res, Free_Chain);
+ Free_Chain := Res;
+ Nodet.Increment_Last;
+ Res := Nodet.Last;
+ end if;
+ -- Allocate the second node.
+ Nodet.Increment_Last;
+ Nodet.Table (Res) := Init_Medium;
+ Nodet.Table (Res + 1) := Init_Medium;
+ else
+ -- Check from free pool
+ if Free_Chain = Null_Node then
+ Nodet.Increment_Last;
+ Res := Nodet.Last;
+ else
+ Res := Free_Chain;
+ Free_Chain := Get_Field1 (Res);
+ end if;
+ case Format is
+ when Format_Short =>
+ Nodet.Table (Res) := Init_Short;
+ when Format_Medium =>
+ raise Program_Error;
+ when Format_Fp =>
+ Nodet.Table (Res) := Init_Fp;
+ when Format_Int =>
+ Nodet.Table (Res) := Init_Int;
+ end case;
+ end if;
+ return Res;
+ end Create_Node;
+
+ procedure Free_Node (N : Node_Type)
+ is
+ begin
+ if N /= Null_Node then
+ Set_Nkind (N, 0);
+ Set_Field1 (N, Free_Chain);
+ Free_Chain := N;
+ if Nodet.Table (N).Format = Format_Medium then
+ Set_Field1 (N + 1, Free_Chain);
+ Free_Chain := N + 1;
+ end if;
+ end if;
+ end Free_Node;
+
+ function Next_Node (N : Node_Type) return Node_Type is
+ begin
+ case Nodet.Table (N).Format is
+ when Format_Medium =>
+ return N + 2;
+ when Format_Short
+ | Format_Int
+ | Format_Fp =>
+ return N + 1;
+ end case;
+ end Next_Node;
+
+ function Get_Nkind (N : Node_Type) return Kind_Type is
+ begin
+ return Nodet.Table (N).Kind;
+ end Get_Nkind;
+
+ procedure Set_Nkind (N : Node_Type; Kind : Kind_Type) is
+ begin
+ Nodet.Table (N).Kind := Kind;
+ end Set_Nkind;
+
+
+ procedure Set_Location (N : Node_Type; Location: Location_Type) is
+ begin
+ Nodet.Table (N).Location := Location;
+ end Set_Location;
+
+ function Get_Location (N: Node_Type) return Location_Type is
+ begin
+ return Nodet.Table (N).Location;
+ end Get_Location;
+
+
+ procedure Set_Field0 (N : Node_Type; V : Node_Type) is
+ begin
+ Nodet.Table (N).Field0 := V;
+ end Set_Field0;
+
+ function Get_Field0 (N : Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N).Field0;
+ end Get_Field0;
+
+
+ function Get_Field1 (N : Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N).Field1;
+ end Get_Field1;
+
+ procedure Set_Field1 (N : Node_Type; V : Node_Type) is
+ begin
+ Nodet.Table (N).Field1 := V;
+ end Set_Field1;
+
+ function Get_Field2 (N : Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N).Field2;
+ end Get_Field2;
+
+ procedure Set_Field2 (N : Node_Type; V : Node_Type) is
+ begin
+ Nodet.Table (N).Field2 := V;
+ end Set_Field2;
+
+ function Get_Field3 (N : Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N).Field3;
+ end Get_Field3;
+
+ procedure Set_Field3 (N : Node_Type; V : Node_Type) is
+ begin
+ Nodet.Table (N).Field3 := V;
+ end Set_Field3;
+
+ function Get_Field4 (N : Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N).Field4;
+ end Get_Field4;
+
+ procedure Set_Field4 (N : Node_Type; V : Node_Type) is
+ begin
+ Nodet.Table (N).Field4 := V;
+ end Set_Field4;
+
+ function Get_Field5 (N : Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N).Field5;
+ end Get_Field5;
+
+ procedure Set_Field5 (N : Node_Type; V : Node_Type) is
+ begin
+ Nodet.Table (N).Field5 := V;
+ end Set_Field5;
+
+ function Get_Field6 (N: Node_Type) return Node_Type is
+ begin
+ return Node_Type (Nodet.Table (N + 1).Location);
+ end Get_Field6;
+
+ procedure Set_Field6 (N: Node_Type; Val: Node_Type) is
+ begin
+ Nodet.Table (N + 1).Location := Location_Type (Val);
+ end Set_Field6;
+
+ function Get_Field7 (N: Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N + 1).Field0;
+ end Get_Field7;
+
+ procedure Set_Field7 (N: Node_Type; Val: Node_Type) is
+ begin
+ Nodet.Table (N + 1).Field0 := Val;
+ end Set_Field7;
+
+ function Get_Field8 (N: Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N + 1).Field1;
+ end Get_Field8;
+
+ procedure Set_Field8 (N: Node_Type; Val: Node_Type) is
+ begin
+ Nodet.Table (N + 1).Field1 := Val;
+ end Set_Field8;
+
+ function Get_Field9 (N: Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N + 1).Field2;
+ end Get_Field9;
+
+ procedure Set_Field9 (N: Node_Type; Val: Node_Type) is
+ begin
+ Nodet.Table (N + 1).Field2 := Val;
+ end Set_Field9;
+
+ function Get_Field10 (N: Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N + 1).Field3;
+ end Get_Field10;
+
+ procedure Set_Field10 (N: Node_Type; Val: Node_Type) is
+ begin
+ Nodet.Table (N + 1).Field3 := Val;
+ end Set_Field10;
+
+ function Get_Field11 (N: Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N + 1).Field4;
+ end Get_Field11;
+
+ procedure Set_Field11 (N: Node_Type; Val: Node_Type) is
+ begin
+ Nodet.Table (N + 1).Field4 := Val;
+ end Set_Field11;
+
+ function Get_Field12 (N: Node_Type) return Node_Type is
+ begin
+ return Nodet.Table (N + 1).Field5;
+ end Get_Field12;
+
+ procedure Set_Field12 (N: Node_Type; Val: Node_Type) is
+ begin
+ Nodet.Table (N + 1).Field5 := Val;
+ end Set_Field12;
+
+
+ function Get_Flag1 (N : Node_Type) return Boolean is
+ begin
+ return Nodet.Table (N).Flag1;
+ end Get_Flag1;
+
+ procedure Set_Flag1 (N : Node_Type; V : Boolean) is
+ begin
+ Nodet.Table (N).Flag1 := V;
+ end Set_Flag1;
+
+ function Get_Flag2 (N : Node_Type) return Boolean is
+ begin
+ return Nodet.Table (N).Flag2;
+ end Get_Flag2;
+
+ procedure Set_Flag2 (N : Node_Type; V : Boolean) is
+ begin
+ Nodet.Table (N).Flag2 := V;
+ end Set_Flag2;
+
+ function Get_Flag3 (N : Node_Type) return Boolean is
+ begin
+ return Nodet.Table (N).Flag3;
+ end Get_Flag3;
+
+ procedure Set_Flag3 (N : Node_Type; V : Boolean) is
+ begin
+ Nodet.Table (N).Flag3 := V;
+ end Set_Flag3;
+
+ function Get_Flag4 (N : Node_Type) return Boolean is
+ begin
+ return Nodet.Table (N).Flag4;
+ end Get_Flag4;
+
+ procedure Set_Flag4 (N : Node_Type; V : Boolean) is
+ begin
+ Nodet.Table (N).Flag4 := V;
+ end Set_Flag4;
+
+ function Get_Flag5 (N : Node_Type) return Boolean is
+ begin
+ return Nodet.Table (N).Flag5;
+ end Get_Flag5;
+
+ procedure Set_Flag5 (N : Node_Type; V : Boolean) is
+ begin
+ Nodet.Table (N).Flag5 := V;
+ end Set_Flag5;
+
+ function Get_Flag6 (N : Node_Type) return Boolean is
+ begin
+ return Nodet.Table (N).Flag6;
+ end Get_Flag6;
+
+ procedure Set_Flag6 (N : Node_Type; V : Boolean) is
+ begin
+ Nodet.Table (N).Flag6 := V;
+ end Set_Flag6;
+
+ function Get_Flag7 (N : Node_Type) return Boolean is
+ begin
+ return Nodet.Table (N).Flag7;
+ end Get_Flag7;
+
+ procedure Set_Flag7 (N : Node_Type; V : Boolean) is
+ begin
+ Nodet.Table (N).Flag7 := V;
+ end Set_Flag7;
+
+ function Get_Flag8 (N : Node_Type) return Boolean is
+ begin
+ return Nodet.Table (N).Flag8;
+ end Get_Flag8;
+
+ procedure Set_Flag8 (N : Node_Type; V : Boolean) is
+ begin
+ Nodet.Table (N).Flag8 := V;
+ end Set_Flag8;
+
+ function Get_Flag9 (N : Node_Type) return Boolean is
+ begin
+ return Nodet.Table (N).Flag9;
+ end Get_Flag9;
+
+ procedure Set_Flag9 (N : Node_Type; V : Boolean) is
+ begin
+ Nodet.Table (N).Flag9 := V;
+ end Set_Flag9;
+
+ function Get_Flag10 (N : Node_Type) return Boolean is
+ begin
+ return Nodet.Table (N).Flag10;
+ end Get_Flag10;
+
+ procedure Set_Flag10 (N : Node_Type; V : Boolean) is
+ begin
+ Nodet.Table (N).Flag10 := V;
+ end Set_Flag10;
+
+
+ function Get_State1 (N : Node_Type) return Bit2_Type is
+ begin
+ return Nodet.Table (N).State1;
+ end Get_State1;
+
+ procedure Set_State1 (N : Node_Type; V : Bit2_Type) is
+ begin
+ Nodet.Table (N).State1 := V;
+ end Set_State1;
+
+ function Get_State2 (N : Node_Type) return Bit2_Type is
+ begin
+ return Nodet.Table (N).State2;
+ end Get_State2;
+
+ procedure Set_State2 (N : Node_Type; V : Bit2_Type) is
+ begin
+ Nodet.Table (N).State2 := V;
+ end Set_State2;
+
+ function Get_State3 (N : Node_Type) return Bit2_Type is
+ begin
+ return Nodet.Table (N + 1).State1;
+ end Get_State3;
+
+ procedure Set_State3 (N : Node_Type; V : Bit2_Type) is
+ begin
+ Nodet.Table (N + 1).State1 := V;
+ end Set_State3;
+
+ function Get_State4 (N : Node_Type) return Bit2_Type is
+ begin
+ return Nodet.Table (N + 1).State2;
+ end Get_State4;
+
+ procedure Set_State4 (N : Node_Type; V : Bit2_Type) is
+ begin
+ Nodet.Table (N + 1).State2 := V;
+ end Set_State4;
+
+
+ function Get_Odigit1 (N : Node_Type) return Bit3_Type is
+ begin
+ return Nodet.Table (N).Odigit1;
+ end Get_Odigit1;
+
+ procedure Set_Odigit1 (N : Node_Type; V : Bit3_Type) is
+ begin
+ Nodet.Table (N).Odigit1 := V;
+ end Set_Odigit1;
+
+ function Get_Odigit2 (N : Node_Type) return Bit3_Type is
+ begin
+ return Nodet.Table (N + 1).Odigit1;
+ end Get_Odigit2;
+
+ procedure Set_Odigit2 (N : Node_Type; V : Bit3_Type) is
+ begin
+ Nodet.Table (N + 1).Odigit1 := V;
+ end Set_Odigit2;
+
+
+ function Get_Fp64 (N : Node_Type) return Iir_Fp64 is
+ begin
+ return Nodet.Table (N).Fp64;
+ end Get_Fp64;
+
+ procedure Set_Fp64 (N : Node_Type; V : Iir_Fp64) is
+ begin
+ Nodet.Table (N).Fp64 := V;
+ end Set_Fp64;
+
+
+ function Get_Int64 (N : Node_Type) return Iir_Int64 is
+ begin
+ return Nodet.Table (N).Int64;
+ end Get_Int64;
+
+ procedure Set_Int64 (N : Node_Type; V : Iir_Int64) is
+ begin
+ Nodet.Table (N).Int64 := V;
+ end Set_Int64;
+
+ procedure Initialize is
+ begin
+ Nodet.Free;
+ Nodet.Init;
+ end Initialize;
+end Nodes;
diff --git a/src/nodes.ads b/src/nodes.ads
new file mode 100644
index 000000000..adf6a5ee8
--- /dev/null
+++ b/src/nodes.ads
@@ -0,0 +1,335 @@
+-- Internal node type and operations.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Types; use Types;
+
+package Nodes is
+ type Node_Type is new Int32;
+ for Node_Type'Size use 32;
+
+ Null_Node : constant Node_Type := 0;
+ Error_Node : constant Node_Type := 1;
+
+ -- A simple type that needs only 2 bits.
+ type Bit2_Type is range 0 .. 2 ** 2 - 1;
+ type Bit3_Type is range 0 .. 2 ** 3 - 1;
+
+ type Kind_Type is range 0 .. 255;
+
+ -- Format of a node.
+ type Format_Type is
+ (
+ Format_Short,
+ Format_Medium,
+ Format_Fp,
+ Format_Int
+ );
+
+ -- Future layout: (rem)
+ -- Format: 0 bits 32
+ -- Nkind: 16 bits 16
+ -- Flags: 8*1 bits 8
+ -- State: 2*2 bits 4
+ -- Odigit is to be removed.
+
+ -- Future layout (2):(rem)
+ -- Format: 2 bits 30
+ -- Nkind: 8 bits 22 (vhdl: 216 nodes)
+ -- Flags: 8*1 bits 14
+ -- State: 2*2 bits 10
+ -- Lang: 2 bits 8
+ -- Odigit: 1*3 bits 5
+
+ -- Common fields are:
+ -- Flag1 : Boolean
+ -- Flag2 : Boolean
+ -- Flag3 : Boolean
+ -- Flag4 : Boolean
+ -- Flag5 : Boolean
+ -- Flag6 : Boolean
+ -- Flag7 : Boolean
+ -- Flag8 : Boolean
+ -- Flag9 : Boolean
+ -- Flag10 : Boolean
+ -- Nkind : Kind_Type
+ -- State1 : Bit2_Type
+ -- State2 : Bit2_Type
+ -- Location : Location_Type
+ -- Field0 : Iir
+ -- Field1 : Iir
+ -- Field2 : Iir
+ -- Field3 : Iir
+
+ -- Fields of Format_Fp:
+ -- Fp64 : Iir_Fp64
+
+ -- Fields of Format_Int:
+ -- Int64 : Iir_Int64
+
+ -- Fields of Format_Short:
+ -- Field4 : Iir
+ -- Field5 : Iir
+
+ -- Fields of Format_Medium:
+ -- Odigit1 : Bit3_Type
+ -- Odigit2 : Bit3_Type (odigit1)
+ -- State3 : Bit2_Type
+ -- State4 : Bit2_Type
+ -- Field4 : Iir
+ -- Field5 : Iir
+ -- Field6 : Iir (location)
+ -- Field7 : Iir (field0)
+ -- Field8 : Iir (field1)
+ -- Field9 : Iir (field2)
+ -- Field10 : Iir (field3)
+ -- Field11 : Iir (field4)
+ -- Field12 : Iir (field5)
+
+ function Create_Node (Format : Format_Type) return Node_Type;
+ procedure Free_Node (N : Node_Type);
+ function Next_Node (N : Node_Type) return Node_Type;
+
+ function Get_Nkind (N : Node_Type) return Kind_Type;
+ pragma Inline (Get_Nkind);
+ procedure Set_Nkind (N : Node_Type; Kind : Kind_Type);
+ pragma Inline (Set_Nkind);
+
+ function Get_Location (N: Node_Type) return Location_Type;
+ pragma Inline (Get_Location);
+ procedure Set_Location (N : Node_Type; Location: Location_Type);
+ pragma Inline (Set_Location);
+
+ function Get_Field0 (N : Node_Type) return Node_Type;
+ pragma Inline (Get_Field0);
+ procedure Set_Field0 (N : Node_Type; V : Node_Type);
+ pragma Inline (Set_Field0);
+
+ function Get_Field1 (N : Node_Type) return Node_Type;
+ pragma Inline (Get_Field1);
+ procedure Set_Field1 (N : Node_Type; V : Node_Type);
+ pragma Inline (Set_Field1);
+
+ function Get_Field2 (N : Node_Type) return Node_Type;
+ pragma Inline (Get_Field2);
+ procedure Set_Field2 (N : Node_Type; V : Node_Type);
+ pragma Inline (Set_Field2);
+
+ function Get_Field3 (N : Node_Type) return Node_Type;
+ pragma Inline (Get_Field3);
+ procedure Set_Field3 (N : Node_Type; V : Node_Type);
+ pragma Inline (Set_Field3);
+
+ function Get_Field4 (N : Node_Type) return Node_Type;
+ pragma Inline (Get_Field4);
+ procedure Set_Field4 (N : Node_Type; V : Node_Type);
+ pragma Inline (Set_Field4);
+
+
+ function Get_Field5 (N : Node_Type) return Node_Type;
+ pragma Inline (Get_Field5);
+ procedure Set_Field5 (N : Node_Type; V : Node_Type);
+ pragma Inline (Set_Field5);
+
+ function Get_Field6 (N: Node_Type) return Node_Type;
+ pragma Inline (Get_Field6);
+ procedure Set_Field6 (N: Node_Type; Val: Node_Type);
+ pragma Inline (Set_Field6);
+
+ function Get_Field7 (N: Node_Type) return Node_Type;
+ pragma Inline (Get_Field7);
+ procedure Set_Field7 (N: Node_Type; Val: Node_Type);
+ pragma Inline (Set_Field7);
+
+ function Get_Field8 (N: Node_Type) return Node_Type;
+ pragma Inline (Get_Field8);
+ procedure Set_Field8 (N: Node_Type; Val: Node_Type);
+ pragma Inline (Set_Field8);
+
+ function Get_Field9 (N: Node_Type) return Node_Type;
+ pragma Inline (Get_Field9);
+ procedure Set_Field9 (N: Node_Type; Val: Node_Type);
+ pragma Inline (Set_Field9);
+
+ function Get_Field10 (N: Node_Type) return Node_Type;
+ pragma Inline (Get_Field10);
+ procedure Set_Field10 (N: Node_Type; Val: Node_Type);
+ pragma Inline (Set_Field10);
+
+ function Get_Field11 (N: Node_Type) return Node_Type;
+ pragma Inline (Get_Field11);
+ procedure Set_Field11 (N: Node_Type; Val: Node_Type);
+ pragma Inline (Set_Field11);
+
+ function Get_Field12 (N: Node_Type) return Node_Type;
+ pragma Inline (Get_Field12);
+ procedure Set_Field12 (N: Node_Type; Val: Node_Type);
+ pragma Inline (Set_Field12);
+
+
+ function Get_Flag1 (N : Node_Type) return Boolean;
+ pragma Inline (Get_Flag1);
+ procedure Set_Flag1 (N : Node_Type; V : Boolean);
+ pragma Inline (Set_Flag1);
+
+ function Get_Flag2 (N : Node_Type) return Boolean;
+ pragma Inline (Get_Flag2);
+ procedure Set_Flag2 (N : Node_Type; V : Boolean);
+ pragma Inline (Set_Flag2);
+
+ function Get_Flag3 (N : Node_Type) return Boolean;
+ pragma Inline (Get_Flag3);
+ procedure Set_Flag3 (N : Node_Type; V : Boolean);
+ pragma Inline (Set_Flag3);
+
+ function Get_Flag4 (N : Node_Type) return Boolean;
+ pragma Inline (Get_Flag4);
+ procedure Set_Flag4 (N : Node_Type; V : Boolean);
+ pragma Inline (Set_Flag4);
+
+ function Get_Flag5 (N : Node_Type) return Boolean;
+ pragma Inline (Get_Flag5);
+ procedure Set_Flag5 (N : Node_Type; V : Boolean);
+ pragma Inline (Set_Flag5);
+
+ function Get_Flag6 (N : Node_Type) return Boolean;
+ pragma Inline (Get_Flag6);
+ procedure Set_Flag6 (N : Node_Type; V : Boolean);
+ pragma Inline (Set_Flag6);
+
+ function Get_Flag7 (N : Node_Type) return Boolean;
+ pragma Inline (Get_Flag7);
+ procedure Set_Flag7 (N : Node_Type; V : Boolean);
+ pragma Inline (Set_Flag7);
+
+ function Get_Flag8 (N : Node_Type) return Boolean;
+ pragma Inline (Get_Flag8);
+ procedure Set_Flag8 (N : Node_Type; V : Boolean);
+ pragma Inline (Set_Flag8);
+
+ function Get_Flag9 (N : Node_Type) return Boolean;
+ pragma Inline (Get_Flag9);
+ procedure Set_Flag9 (N : Node_Type; V : Boolean);
+ pragma Inline (Set_Flag9);
+
+ function Get_Flag10 (N : Node_Type) return Boolean;
+ pragma Inline (Get_Flag10);
+ procedure Set_Flag10 (N : Node_Type; V : Boolean);
+ pragma Inline (Set_Flag10);
+
+
+ function Get_State1 (N : Node_Type) return Bit2_Type;
+ pragma Inline (Get_State1);
+ procedure Set_State1 (N : Node_Type; V : Bit2_Type);
+ pragma Inline (Set_State1);
+
+ function Get_State2 (N : Node_Type) return Bit2_Type;
+ pragma Inline (Get_State2);
+ procedure Set_State2 (N : Node_Type; V : Bit2_Type);
+ pragma Inline (Set_State2);
+
+ function Get_State3 (N : Node_Type) return Bit2_Type;
+ pragma Inline (Get_State3);
+ procedure Set_State3 (N : Node_Type; V : Bit2_Type);
+ pragma Inline (Set_State3);
+
+ function Get_State4 (N : Node_Type) return Bit2_Type;
+ pragma Inline (Get_State4);
+ procedure Set_State4 (N : Node_Type; V : Bit2_Type);
+ pragma Inline (Set_State4);
+
+
+ function Get_Odigit1 (N : Node_Type) return Bit3_Type;
+ pragma Inline (Get_Odigit1);
+ procedure Set_Odigit1 (N : Node_Type; V : Bit3_Type);
+ pragma Inline (Set_Odigit1);
+
+ function Get_Odigit2 (N : Node_Type) return Bit3_Type;
+ pragma Inline (Get_Odigit2);
+ procedure Set_Odigit2 (N : Node_Type; V : Bit3_Type);
+ pragma Inline (Set_Odigit2);
+
+
+ function Get_Fp64 (N : Node_Type) return Iir_Fp64;
+ pragma Inline (Get_Fp64);
+ procedure Set_Fp64 (N : Node_Type; V : Iir_Fp64);
+ pragma Inline (Set_Fp64);
+
+ function Get_Int64 (N : Node_Type) return Iir_Int64;
+ pragma Inline (Get_Int64);
+ procedure Set_Int64 (N : Node_Type; V : Iir_Int64);
+ pragma Inline (Set_Int64);
+
+ -- Get the last node allocated.
+ function Get_Last_Node return Node_Type;
+ pragma Inline (Get_Last_Node);
+
+ -- Free all and reinit.
+ procedure Initialize;
+private
+ type Node_Record (Format : Format_Type := Format_Short) is record
+ Flag1 : Boolean := False;
+ Flag2 : Boolean := False;
+ Flag3 : Boolean := False;
+ Flag4 : Boolean := False;
+ Flag5 : Boolean := False;
+ Flag6 : Boolean := False;
+
+ -- Kind field use 8 bits.
+ -- So, on 32 bits systems, there are 24 bits left.
+ -- + 8 (8 * 1)
+ -- + 10 (5 * 2)
+ -- + 6 (2 * 3)
+ -- = 24
+
+ Kind : Kind_Type;
+
+ State1 : Bit2_Type := 0;
+ State2 : Bit2_Type := 0;
+ Flag7 : Boolean := False;
+ Flag8 : Boolean := False;
+ Flag9 : Boolean := False;
+ Flag10 : Boolean := False;
+
+ Flag11 : Boolean := False;
+ Flag12 : Boolean := False;
+ Odigit1 : Bit3_Type := 0;
+ Unused_Odigit2 : Bit3_Type := 0;
+
+ -- Location.
+ Location: Location_Type := Location_Nil;
+
+ Field0 : Node_Type := Null_Node;
+ Field1: Node_Type := Null_Node;
+ Field2: Node_Type := Null_Node;
+ Field3: Node_Type := Null_Node;
+
+ case Format is
+ when Format_Short
+ | Format_Medium =>
+ Field4: Node_Type := Null_Node;
+ Field5: Node_Type := Null_Node;
+ when Format_Fp =>
+ Fp64 : Iir_Fp64;
+ when Format_Int =>
+ Int64 : Iir_Int64;
+ end case;
+ end record;
+
+ pragma Pack (Node_Record);
+ for Node_Record'Size use 8*32;
+ for Node_Record'Alignment use 4;
+end Nodes;
diff --git a/src/nodes_gc.adb b/src/nodes_gc.adb
new file mode 100644
index 000000000..38966f27c
--- /dev/null
+++ b/src/nodes_gc.adb
@@ -0,0 +1,206 @@
+-- Node garbage collector (for debugging).
+-- 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 GHDL; 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 Types; use Types;
+with Nodes;
+with Nodes_Meta;
+with Iirs; use Iirs;
+with Libraries;
+with Disp_Tree;
+with Std_Package;
+
+package body Nodes_GC is
+
+ type Marker_Array is array (Iir range <>) of Boolean;
+ type Marker_Array_Acc is access Marker_Array;
+
+ Markers : Marker_Array_Acc;
+
+ procedure Mark_Iir (N : Iir);
+
+ procedure Mark_Iir_List (N : Iir_List)
+ is
+ El : Iir;
+ begin
+ case N is
+ when Null_Iir_List
+ | Iir_List_All
+ | Iir_List_Others =>
+ null;
+ when others =>
+ for I in Natural loop
+ El := Get_Nth_Element (N, I);
+ exit when El = Null_Iir;
+ Mark_Iir (El);
+ end loop;
+ end case;
+ end Mark_Iir_List;
+
+ procedure Mark_PSL_Node (N : PSL_Node) is
+ begin
+ null;
+ end Mark_PSL_Node;
+
+ procedure Mark_PSL_NFA (N : PSL_NFA) is
+ begin
+ null;
+ end Mark_PSL_NFA;
+
+ procedure Report_Already_Marked (N : Iir)
+ is
+ use Ada.Text_IO;
+ begin
+ Disp_Tree.Disp_Tree (N, True);
+ return;
+ end Report_Already_Marked;
+
+ procedure Already_Marked (N : Iir) is
+ begin
+ -- An unused node mustn't be referenced.
+ if Get_Kind (N) = Iir_Kind_Unused then
+ raise Internal_Error;
+ end if;
+
+ if not Flag_Disp_Multiref then
+ return;
+ end if;
+
+ case Get_Kind (N) is
+ when Iir_Kind_Interface_Constant_Declaration =>
+ if Get_Identifier (N) = Null_Identifier then
+ -- Anonymous interfaces are shared by predefined functions.
+ return;
+ end if;
+ when Iir_Kind_Enumeration_Literal =>
+ if Get_Enum_Pos (N) = 0
+ or else N = Get_Right_Limit (Get_Range_Constraint
+ (Get_Type (N)))
+ then
+ return;
+ end if;
+ when others =>
+ null;
+ end case;
+
+ Report_Already_Marked (N);
+ end Already_Marked;
+
+ procedure Mark_Chain (Head : Iir)
+ is
+ El : Iir;
+ begin
+ El := Head;
+ while El /= Null_Iir loop
+ Mark_Iir (El);
+ El := Get_Chain (El);
+ end loop;
+ end Mark_Chain;
+
+ procedure Report_Unreferenced_Node (N : Iir) is
+ begin
+ Disp_Tree.Disp_Tree (N, True);
+ end Report_Unreferenced_Node;
+
+ procedure Mark_Iir (N : Iir) is
+ begin
+ if N = Null_Iir then
+ return;
+ elsif Markers (N) then
+ Already_Marked (N);
+ return;
+ else
+ Markers (N) := True;
+ end if;
+
+ declare
+ use Nodes_Meta;
+ Fields : constant Fields_Array := Get_Fields (Get_Kind (N));
+ F : Fields_Enum;
+ begin
+ for I in Fields'Range loop
+ F := Fields (I);
+ case Get_Field_Attribute (F) is
+ when Attr_Ref
+ | Attr_Chain_Next =>
+ null;
+ when Attr_Maybe_Ref =>
+ if not Get_Is_Ref (N) then
+ Mark_Iir (Get_Iir (N, F));
+ end if;
+ when Attr_Chain =>
+ Mark_Chain (Get_Iir (N, F));
+ when Attr_None =>
+ case Get_Field_Type (F) is
+ when Type_Iir =>
+ Mark_Iir (Get_Iir (N, F));
+ when Type_Iir_List =>
+ Mark_Iir_List (Get_Iir_List (N, F));
+ when Type_PSL_Node =>
+ Mark_PSL_Node (Get_PSL_Node (N, F));
+ when Type_PSL_NFA =>
+ Mark_PSL_NFA (Get_PSL_NFA (N, F));
+ when others =>
+ null;
+ end case;
+ when Attr_Of_Ref =>
+ raise Internal_Error;
+ end case;
+ end loop;
+ end;
+ end Mark_Iir;
+
+ procedure Report_Unreferenced
+ is
+ use Ada.Text_IO;
+ use Std_Package;
+ El : Iir;
+ Nbr_Unreferenced : Natural;
+ begin
+ Markers := new Marker_Array'(Null_Iir .. Iirs.Get_Last_Node => False);
+
+ if Flag_Disp_Multiref then
+ Put_Line ("** nodes already marked:");
+ end if;
+
+ Mark_Chain (Libraries.Get_Libraries_Chain);
+ Mark_Chain (Libraries.Obsoleted_Design_Units);
+ Mark_Iir (Convertible_Integer_Type_Declaration);
+ Mark_Iir (Convertible_Integer_Subtype_Declaration);
+ Mark_Iir (Convertible_Real_Type_Declaration);
+ Mark_Iir (Universal_Integer_One);
+ Mark_Iir (Error_Mark);
+
+ El := Error_Mark;
+ Nbr_Unreferenced := 0;
+ while El in Markers'Range loop
+ if not Markers (El) and then Get_Kind (El) /= Iir_Kind_Unused then
+ if Nbr_Unreferenced = 0 then
+ Put_Line ("** unreferenced nodes:");
+ end if;
+ Nbr_Unreferenced := Nbr_Unreferenced + 1;
+ Report_Unreferenced_Node (El);
+ end if;
+ El := Iir (Nodes.Next_Node (Nodes.Node_Type (El)));
+ end loop;
+
+ if Nbr_Unreferenced /= 0 then
+ raise Internal_Error;
+ end if;
+ end Report_Unreferenced;
+end Nodes_GC;
diff --git a/src/nodes_gc.adb.in b/src/nodes_gc.adb.in
new file mode 100644
index 000000000..7c4303bc5
--- /dev/null
+++ b/src/nodes_gc.adb.in
@@ -0,0 +1,159 @@
+-- Node garbage collector (for debugging).
+-- 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 GHDL; 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 Types; use Types;
+with Nodes;
+with Iirs; use Iirs;
+with Libraries;
+with Disp_Tree;
+with Std_Package;
+
+package body Nodes_GC is
+
+ type Marker_Array is array (Iir range <>) of Boolean;
+ type Marker_Array_Acc is access Marker_Array;
+
+ Markers : Marker_Array_Acc;
+
+ procedure Mark_Iir (N : Iir);
+
+ procedure Mark_Iir_List (N : Iir_List)
+ is
+ El : Iir;
+ begin
+ case N is
+ when Null_Iir_List
+ | Iir_List_All
+ | Iir_List_Others =>
+ null;
+ when others =>
+ for I in Natural loop
+ El := Get_Nth_Element (N, I);
+ exit when El = Null_Iir;
+ Mark_Iir (El);
+ end loop;
+ end case;
+ end Mark_Iir_List;
+
+ procedure Mark_PSL_Node (N : PSL_Node) is
+ begin
+ null;
+ end Mark_PSL_Node;
+
+ procedure Mark_PSL_NFA (N : PSL_NFA) is
+ begin
+ null;
+ end Mark_PSL_NFA;
+
+ procedure Report_Already_Marked (N : Iir)
+ is
+ use Ada.Text_IO;
+ begin
+ Disp_Tree.Disp_Tree (N, True);
+ return;
+ end Report_Already_Marked;
+
+ procedure Already_Marked (N : Iir) is
+ begin
+ -- An unused node mustn't be referenced.
+ if Get_Kind (N) = Iir_Kind_Unused then
+ raise Internal_Error;
+ end if;
+
+ if not Flag_Disp_Multiref then
+ return;
+ end if;
+
+ case Get_Kind (N) is
+ when Iir_Kind_Constant_Interface_Declaration =>
+ if Get_Identifier (N) = Null_Identifier then
+ -- Anonymous interfaces are shared by predefined functions.
+ return;
+ end if;
+ when Iir_Kind_Enumeration_Literal =>
+ if Get_Enum_Pos (N) = 0
+ or else N = Get_Right_Limit (Get_Range_Constraint
+ (Get_Type (N)))
+ then
+ return;
+ end if;
+ when others =>
+ null;
+ end case;
+
+ Report_Already_Marked (N);
+ end Already_Marked;
+
+ procedure Mark_Chain (Head : Iir)
+ is
+ El : Iir;
+ begin
+ El := Head;
+ while El /= Null_Iir loop
+ Mark_Iir (El);
+ El := Get_Chain (El);
+ end loop;
+ end Mark_Chain;
+
+ procedure Report_Unreferenced_Node (N : Iir) is
+ begin
+ Disp_Tree.Disp_Tree (N, True);
+ end Report_Unreferenced_Node;
+
+ -- Subprograms
+
+ procedure Report_Unreferenced
+ is
+ use Ada.Text_IO;
+ use Std_Package;
+ El : Iir;
+ Nbr_Unreferenced : Natural;
+ begin
+ Markers := new Marker_Array'(Null_Iir .. Iirs.Get_Last_Node => False);
+
+ if Flag_Disp_Multiref then
+ Put_Line ("** nodes already marked:");
+ end if;
+
+ Mark_Chain (Libraries.Get_Libraries_Chain);
+ Mark_Chain (Libraries.Obsoleted_Design_Units);
+ Mark_Iir (Convertible_Integer_Type_Declaration);
+ Mark_Iir (Convertible_Integer_Subtype_Declaration);
+ Mark_Iir (Convertible_Real_Type_Declaration);
+ Mark_Iir (Universal_Integer_One);
+ Mark_Iir (Error_Mark);
+
+ El := Error_Mark;
+ Nbr_Unreferenced := 0;
+ while El in Markers'Range loop
+ if not Markers (El) and then Get_Kind (El) /= Iir_Kind_Unused then
+ if Nbr_Unreferenced = 0 then
+ Put_Line ("** unreferenced nodes:");
+ end if;
+ Nbr_Unreferenced := Nbr_Unreferenced + 1;
+ Report_Unreferenced_Node (El);
+ end if;
+ El := Iir (Nodes.Next_Node (Nodes.Node_Type (El)));
+ end loop;
+
+ if Nbr_Unreferenced /= 0 then
+ raise Internal_Error;
+ end if;
+ end Report_Unreferenced;
+end Nodes_GC;
diff --git a/src/nodes_gc.ads b/src/nodes_gc.ads
new file mode 100644
index 000000000..ef8e647c3
--- /dev/null
+++ b/src/nodes_gc.ads
@@ -0,0 +1,24 @@
+-- Node garbage collector (for debugging).
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package Nodes_GC is
+ Flag_Disp_Multiref : Boolean := False;
+
+ procedure Report_Unreferenced;
+ -- Display nodes that aren't referenced.
+end Nodes_GC;
diff --git a/src/nodes_meta.adb b/src/nodes_meta.adb
new file mode 100644
index 000000000..3e038f549
--- /dev/null
+++ b/src/nodes_meta.adb
@@ -0,0 +1,9409 @@
+-- Meta description of nodes.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package body Nodes_Meta is
+ Fields_Type : constant array (Fields_Enum) of Types_Enum :=
+ (
+ Field_First_Design_Unit => Type_Iir,
+ Field_Last_Design_Unit => Type_Iir,
+ Field_Library_Declaration => Type_Iir,
+ Field_File_Time_Stamp => Type_Time_Stamp_Id,
+ Field_Analysis_Time_Stamp => Type_Time_Stamp_Id,
+ Field_Library => Type_Iir,
+ Field_File_Dependence_List => Type_Iir_List,
+ Field_Design_File_Filename => Type_Name_Id,
+ Field_Design_File_Directory => Type_Name_Id,
+ Field_Design_File => Type_Iir,
+ Field_Design_File_Chain => Type_Iir,
+ Field_Library_Directory => Type_Name_Id,
+ Field_Date => Type_Date_Type,
+ Field_Context_Items => Type_Iir,
+ Field_Dependence_List => Type_Iir_List,
+ Field_Analysis_Checks_List => Type_Iir_List,
+ Field_Date_State => Type_Date_State_Type,
+ Field_Guarded_Target_State => Type_Tri_State_Type,
+ Field_Library_Unit => Type_Iir,
+ Field_Hash_Chain => Type_Iir,
+ Field_Design_Unit_Source_Pos => Type_Source_Ptr,
+ Field_Design_Unit_Source_Line => Type_Int32,
+ Field_Design_Unit_Source_Col => Type_Int32,
+ Field_Value => Type_Iir_Int64,
+ Field_Enum_Pos => Type_Iir_Int32,
+ Field_Physical_Literal => Type_Iir,
+ Field_Physical_Unit_Value => Type_Iir,
+ Field_Fp_Value => Type_Iir_Fp64,
+ Field_Enumeration_Decl => Type_Iir,
+ Field_Simple_Aggregate_List => Type_Iir_List,
+ Field_Bit_String_Base => Type_Base_Type,
+ Field_Bit_String_0 => Type_Iir,
+ Field_Bit_String_1 => Type_Iir,
+ Field_Literal_Origin => Type_Iir,
+ Field_Range_Origin => Type_Iir,
+ Field_Literal_Subtype => Type_Iir,
+ Field_Entity_Class => Type_Token_Type,
+ Field_Entity_Name_List => Type_Iir_List,
+ Field_Attribute_Designator => Type_Iir,
+ Field_Attribute_Specification_Chain => Type_Iir,
+ Field_Attribute_Specification => Type_Iir,
+ Field_Signal_List => Type_Iir_List,
+ Field_Designated_Entity => Type_Iir,
+ Field_Formal => Type_Iir,
+ Field_Actual => Type_Iir,
+ Field_In_Conversion => Type_Iir,
+ Field_Out_Conversion => Type_Iir,
+ Field_Whole_Association_Flag => Type_Boolean,
+ Field_Collapse_Signal_Flag => Type_Boolean,
+ Field_Artificial_Flag => Type_Boolean,
+ Field_Open_Flag => Type_Boolean,
+ Field_After_Drivers_Flag => Type_Boolean,
+ Field_We_Value => Type_Iir,
+ Field_Time => Type_Iir,
+ Field_Associated_Expr => Type_Iir,
+ Field_Associated_Chain => Type_Iir,
+ Field_Choice_Name => Type_Iir,
+ Field_Choice_Expression => Type_Iir,
+ Field_Choice_Range => Type_Iir,
+ Field_Same_Alternative_Flag => Type_Boolean,
+ Field_Architecture => Type_Iir,
+ Field_Block_Specification => Type_Iir,
+ Field_Prev_Block_Configuration => Type_Iir,
+ Field_Configuration_Item_Chain => Type_Iir,
+ Field_Attribute_Value_Chain => Type_Iir,
+ Field_Spec_Chain => Type_Iir,
+ Field_Attribute_Value_Spec_Chain => Type_Iir,
+ Field_Entity_Name => Type_Iir,
+ Field_Package => Type_Iir,
+ Field_Package_Body => Type_Iir,
+ Field_Need_Body => Type_Boolean,
+ Field_Block_Configuration => Type_Iir,
+ Field_Concurrent_Statement_Chain => Type_Iir,
+ Field_Chain => Type_Iir,
+ Field_Port_Chain => Type_Iir,
+ Field_Generic_Chain => Type_Iir,
+ Field_Type => Type_Iir,
+ Field_Subtype_Indication => Type_Iir,
+ Field_Discrete_Range => Type_Iir,
+ Field_Type_Definition => Type_Iir,
+ Field_Subtype_Definition => Type_Iir,
+ Field_Nature => Type_Iir,
+ Field_Mode => Type_Iir_Mode,
+ Field_Signal_Kind => Type_Iir_Signal_Kind,
+ Field_Base_Name => Type_Iir,
+ Field_Interface_Declaration_Chain => Type_Iir,
+ Field_Subprogram_Specification => Type_Iir,
+ Field_Sequential_Statement_Chain => Type_Iir,
+ Field_Subprogram_Body => Type_Iir,
+ Field_Overload_Number => Type_Iir_Int32,
+ Field_Subprogram_Depth => Type_Iir_Int32,
+ Field_Subprogram_Hash => Type_Iir_Int32,
+ Field_Impure_Depth => Type_Iir_Int32,
+ Field_Return_Type => Type_Iir,
+ Field_Implicit_Definition => Type_Iir_Predefined_Functions,
+ Field_Type_Reference => Type_Iir,
+ Field_Default_Value => Type_Iir,
+ Field_Deferred_Declaration => Type_Iir,
+ Field_Deferred_Declaration_Flag => Type_Boolean,
+ Field_Shared_Flag => Type_Boolean,
+ Field_Design_Unit => Type_Iir,
+ Field_Block_Statement => Type_Iir,
+ Field_Signal_Driver => Type_Iir,
+ Field_Declaration_Chain => Type_Iir,
+ Field_File_Logical_Name => Type_Iir,
+ Field_File_Open_Kind => Type_Iir,
+ Field_Element_Position => Type_Iir_Index32,
+ Field_Element_Declaration => Type_Iir,
+ Field_Selected_Element => Type_Iir,
+ Field_Use_Clause_Chain => Type_Iir,
+ Field_Selected_Name => Type_Iir,
+ Field_Type_Declarator => Type_Iir,
+ Field_Enumeration_Literal_List => Type_Iir_List,
+ Field_Entity_Class_Entry_Chain => Type_Iir,
+ Field_Group_Constituent_List => Type_Iir_List,
+ Field_Unit_Chain => Type_Iir,
+ Field_Primary_Unit => Type_Iir,
+ Field_Identifier => Type_Name_Id,
+ Field_Label => Type_Name_Id,
+ Field_Visible_Flag => Type_Boolean,
+ Field_Range_Constraint => Type_Iir,
+ Field_Direction => Type_Iir_Direction,
+ Field_Left_Limit => Type_Iir,
+ Field_Right_Limit => Type_Iir,
+ Field_Base_Type => Type_Iir,
+ Field_Resolution_Indication => Type_Iir,
+ Field_Record_Element_Resolution_Chain => Type_Iir,
+ Field_Tolerance => Type_Iir,
+ Field_Plus_Terminal => Type_Iir,
+ Field_Minus_Terminal => Type_Iir,
+ Field_Simultaneous_Left => Type_Iir,
+ Field_Simultaneous_Right => Type_Iir,
+ Field_Text_File_Flag => Type_Boolean,
+ Field_Only_Characters_Flag => Type_Boolean,
+ Field_Type_Staticness => Type_Iir_Staticness,
+ Field_Constraint_State => Type_Iir_Constraint,
+ Field_Index_Subtype_List => Type_Iir_List,
+ Field_Index_Subtype_Definition_List => Type_Iir_List,
+ Field_Element_Subtype_Indication => Type_Iir,
+ Field_Element_Subtype => Type_Iir,
+ Field_Index_Constraint_List => Type_Iir_List,
+ Field_Array_Element_Constraint => Type_Iir,
+ Field_Elements_Declaration_List => Type_Iir_List,
+ Field_Designated_Type => Type_Iir,
+ Field_Designated_Subtype_Indication => Type_Iir,
+ Field_Index_List => Type_Iir_List,
+ Field_Reference => Type_Iir,
+ Field_Nature_Declarator => Type_Iir,
+ Field_Across_Type => Type_Iir,
+ Field_Through_Type => Type_Iir,
+ Field_Target => Type_Iir,
+ Field_Waveform_Chain => Type_Iir,
+ Field_Guard => Type_Iir,
+ Field_Delay_Mechanism => Type_Iir_Delay_Mechanism,
+ Field_Reject_Time_Expression => Type_Iir,
+ Field_Sensitivity_List => Type_Iir_List,
+ Field_Process_Origin => Type_Iir,
+ Field_Condition_Clause => Type_Iir,
+ Field_Timeout_Clause => Type_Iir,
+ Field_Postponed_Flag => Type_Boolean,
+ Field_Callees_List => Type_Iir_List,
+ Field_Passive_Flag => Type_Boolean,
+ Field_Resolution_Function_Flag => Type_Boolean,
+ Field_Wait_State => Type_Tri_State_Type,
+ Field_All_Sensitized_State => Type_Iir_All_Sensitized,
+ Field_Seen_Flag => Type_Boolean,
+ Field_Pure_Flag => Type_Boolean,
+ Field_Foreign_Flag => Type_Boolean,
+ Field_Resolved_Flag => Type_Boolean,
+ Field_Signal_Type_Flag => Type_Boolean,
+ Field_Has_Signal_Flag => Type_Boolean,
+ Field_Purity_State => Type_Iir_Pure_State,
+ Field_Elab_Flag => Type_Boolean,
+ Field_Index_Constraint_Flag => Type_Boolean,
+ Field_Assertion_Condition => Type_Iir,
+ Field_Report_Expression => Type_Iir,
+ Field_Severity_Expression => Type_Iir,
+ Field_Instantiated_Unit => Type_Iir,
+ Field_Generic_Map_Aspect_Chain => Type_Iir,
+ Field_Port_Map_Aspect_Chain => Type_Iir,
+ Field_Configuration_Name => Type_Iir,
+ Field_Component_Configuration => Type_Iir,
+ Field_Configuration_Specification => Type_Iir,
+ Field_Default_Binding_Indication => Type_Iir,
+ Field_Default_Configuration_Declaration => Type_Iir,
+ Field_Expression => Type_Iir,
+ Field_Allocator_Designated_Type => Type_Iir,
+ Field_Selected_Waveform_Chain => Type_Iir,
+ Field_Conditional_Waveform_Chain => Type_Iir,
+ Field_Guard_Expression => Type_Iir,
+ Field_Guard_Decl => Type_Iir,
+ Field_Guard_Sensitivity_List => Type_Iir_List,
+ Field_Block_Block_Configuration => Type_Iir,
+ Field_Package_Header => Type_Iir,
+ Field_Block_Header => Type_Iir,
+ Field_Uninstantiated_Package_Name => Type_Iir,
+ Field_Generate_Block_Configuration => Type_Iir,
+ Field_Generation_Scheme => Type_Iir,
+ Field_Condition => Type_Iir,
+ Field_Else_Clause => Type_Iir,
+ Field_Parameter_Specification => Type_Iir,
+ Field_Parent => Type_Iir,
+ Field_Loop_Label => Type_Iir,
+ Field_Component_Name => Type_Iir,
+ Field_Instantiation_List => Type_Iir_List,
+ Field_Entity_Aspect => Type_Iir,
+ Field_Default_Entity_Aspect => Type_Iir,
+ Field_Default_Generic_Map_Aspect_Chain => Type_Iir,
+ Field_Default_Port_Map_Aspect_Chain => Type_Iir,
+ Field_Binding_Indication => Type_Iir,
+ Field_Named_Entity => Type_Iir,
+ Field_Alias_Declaration => Type_Iir,
+ Field_Expr_Staticness => Type_Iir_Staticness,
+ Field_Error_Origin => Type_Iir,
+ Field_Operand => Type_Iir,
+ Field_Left => Type_Iir,
+ Field_Right => Type_Iir,
+ Field_Unit_Name => Type_Iir,
+ Field_Name => Type_Iir,
+ Field_Group_Template_Name => Type_Iir,
+ Field_Name_Staticness => Type_Iir_Staticness,
+ Field_Prefix => Type_Iir,
+ Field_Signature_Prefix => Type_Iir,
+ Field_Slice_Subtype => Type_Iir,
+ Field_Suffix => Type_Iir,
+ Field_Index_Subtype => Type_Iir,
+ Field_Parameter => Type_Iir,
+ Field_Actual_Type => Type_Iir,
+ Field_Associated_Interface => Type_Iir,
+ Field_Association_Chain => Type_Iir,
+ Field_Individual_Association_Chain => Type_Iir,
+ Field_Aggregate_Info => Type_Iir,
+ Field_Sub_Aggregate_Info => Type_Iir,
+ Field_Aggr_Dynamic_Flag => Type_Boolean,
+ Field_Aggr_Min_Length => Type_Iir_Int32,
+ Field_Aggr_Low_Limit => Type_Iir,
+ Field_Aggr_High_Limit => Type_Iir,
+ Field_Aggr_Others_Flag => Type_Boolean,
+ Field_Aggr_Named_Flag => Type_Boolean,
+ Field_Value_Staticness => Type_Iir_Staticness,
+ Field_Association_Choices_Chain => Type_Iir,
+ Field_Case_Statement_Alternative_Chain => Type_Iir,
+ Field_Choice_Staticness => Type_Iir_Staticness,
+ Field_Procedure_Call => Type_Iir,
+ Field_Implementation => Type_Iir,
+ Field_Parameter_Association_Chain => Type_Iir,
+ Field_Method_Object => Type_Iir,
+ Field_Subtype_Type_Mark => Type_Iir,
+ Field_Type_Conversion_Subtype => Type_Iir,
+ Field_Type_Mark => Type_Iir,
+ Field_File_Type_Mark => Type_Iir,
+ Field_Return_Type_Mark => Type_Iir,
+ Field_Lexical_Layout => Type_Iir_Lexical_Layout_Type,
+ Field_Incomplete_Type_List => Type_Iir_List,
+ Field_Has_Disconnect_Flag => Type_Boolean,
+ Field_Has_Active_Flag => Type_Boolean,
+ Field_Is_Within_Flag => Type_Boolean,
+ Field_Type_Marks_List => Type_Iir_List,
+ Field_Implicit_Alias_Flag => Type_Boolean,
+ Field_Alias_Signature => Type_Iir,
+ Field_Attribute_Signature => Type_Iir,
+ Field_Overload_List => Type_Iir_List,
+ Field_Simple_Name_Identifier => Type_Name_Id,
+ Field_Simple_Name_Subtype => Type_Iir,
+ Field_Protected_Type_Body => Type_Iir,
+ Field_Protected_Type_Declaration => Type_Iir,
+ Field_End_Location => Type_Location_Type,
+ Field_String_Id => Type_String_Id,
+ Field_String_Length => Type_Int32,
+ Field_Use_Flag => Type_Boolean,
+ Field_End_Has_Reserved_Id => Type_Boolean,
+ Field_End_Has_Identifier => Type_Boolean,
+ Field_End_Has_Postponed => Type_Boolean,
+ Field_Has_Begin => Type_Boolean,
+ Field_Has_Is => Type_Boolean,
+ Field_Has_Pure => Type_Boolean,
+ Field_Has_Body => Type_Boolean,
+ Field_Has_Identifier_List => Type_Boolean,
+ Field_Has_Mode => Type_Boolean,
+ Field_Is_Ref => Type_Boolean,
+ Field_Psl_Property => Type_PSL_Node,
+ Field_Psl_Declaration => Type_PSL_Node,
+ Field_Psl_Expression => Type_PSL_Node,
+ Field_Psl_Boolean => Type_PSL_Node,
+ Field_PSL_Clock => Type_PSL_Node,
+ Field_PSL_NFA => Type_PSL_NFA
+ );
+
+ function Get_Field_Type (F : Fields_Enum) return Types_Enum is
+ begin
+ return Fields_Type (F);
+ end Get_Field_Type;
+
+ function Get_Field_Image (F : Fields_Enum) return String is
+ begin
+ case F is
+ when Field_First_Design_Unit =>
+ return "first_design_unit";
+ when Field_Last_Design_Unit =>
+ return "last_design_unit";
+ when Field_Library_Declaration =>
+ return "library_declaration";
+ when Field_File_Time_Stamp =>
+ return "file_time_stamp";
+ when Field_Analysis_Time_Stamp =>
+ return "analysis_time_stamp";
+ when Field_Library =>
+ return "library";
+ when Field_File_Dependence_List =>
+ return "file_dependence_list";
+ when Field_Design_File_Filename =>
+ return "design_file_filename";
+ when Field_Design_File_Directory =>
+ return "design_file_directory";
+ when Field_Design_File =>
+ return "design_file";
+ when Field_Design_File_Chain =>
+ return "design_file_chain";
+ when Field_Library_Directory =>
+ return "library_directory";
+ when Field_Date =>
+ return "date";
+ when Field_Context_Items =>
+ return "context_items";
+ when Field_Dependence_List =>
+ return "dependence_list";
+ when Field_Analysis_Checks_List =>
+ return "analysis_checks_list";
+ when Field_Date_State =>
+ return "date_state";
+ when Field_Guarded_Target_State =>
+ return "guarded_target_state";
+ when Field_Library_Unit =>
+ return "library_unit";
+ when Field_Hash_Chain =>
+ return "hash_chain";
+ when Field_Design_Unit_Source_Pos =>
+ return "design_unit_source_pos";
+ when Field_Design_Unit_Source_Line =>
+ return "design_unit_source_line";
+ when Field_Design_Unit_Source_Col =>
+ return "design_unit_source_col";
+ when Field_Value =>
+ return "value";
+ when Field_Enum_Pos =>
+ return "enum_pos";
+ when Field_Physical_Literal =>
+ return "physical_literal";
+ when Field_Physical_Unit_Value =>
+ return "physical_unit_value";
+ when Field_Fp_Value =>
+ return "fp_value";
+ when Field_Enumeration_Decl =>
+ return "enumeration_decl";
+ when Field_Simple_Aggregate_List =>
+ return "simple_aggregate_list";
+ when Field_Bit_String_Base =>
+ return "bit_string_base";
+ when Field_Bit_String_0 =>
+ return "bit_string_0";
+ when Field_Bit_String_1 =>
+ return "bit_string_1";
+ when Field_Literal_Origin =>
+ return "literal_origin";
+ when Field_Range_Origin =>
+ return "range_origin";
+ when Field_Literal_Subtype =>
+ return "literal_subtype";
+ when Field_Entity_Class =>
+ return "entity_class";
+ when Field_Entity_Name_List =>
+ return "entity_name_list";
+ when Field_Attribute_Designator =>
+ return "attribute_designator";
+ when Field_Attribute_Specification_Chain =>
+ return "attribute_specification_chain";
+ when Field_Attribute_Specification =>
+ return "attribute_specification";
+ when Field_Signal_List =>
+ return "signal_list";
+ when Field_Designated_Entity =>
+ return "designated_entity";
+ when Field_Formal =>
+ return "formal";
+ when Field_Actual =>
+ return "actual";
+ when Field_In_Conversion =>
+ return "in_conversion";
+ when Field_Out_Conversion =>
+ return "out_conversion";
+ when Field_Whole_Association_Flag =>
+ return "whole_association_flag";
+ when Field_Collapse_Signal_Flag =>
+ return "collapse_signal_flag";
+ when Field_Artificial_Flag =>
+ return "artificial_flag";
+ when Field_Open_Flag =>
+ return "open_flag";
+ when Field_After_Drivers_Flag =>
+ return "after_drivers_flag";
+ when Field_We_Value =>
+ return "we_value";
+ when Field_Time =>
+ return "time";
+ when Field_Associated_Expr =>
+ return "associated_expr";
+ when Field_Associated_Chain =>
+ return "associated_chain";
+ when Field_Choice_Name =>
+ return "choice_name";
+ when Field_Choice_Expression =>
+ return "choice_expression";
+ when Field_Choice_Range =>
+ return "choice_range";
+ when Field_Same_Alternative_Flag =>
+ return "same_alternative_flag";
+ when Field_Architecture =>
+ return "architecture";
+ when Field_Block_Specification =>
+ return "block_specification";
+ when Field_Prev_Block_Configuration =>
+ return "prev_block_configuration";
+ when Field_Configuration_Item_Chain =>
+ return "configuration_item_chain";
+ when Field_Attribute_Value_Chain =>
+ return "attribute_value_chain";
+ when Field_Spec_Chain =>
+ return "spec_chain";
+ when Field_Attribute_Value_Spec_Chain =>
+ return "attribute_value_spec_chain";
+ when Field_Entity_Name =>
+ return "entity_name";
+ when Field_Package =>
+ return "package";
+ when Field_Package_Body =>
+ return "package_body";
+ when Field_Need_Body =>
+ return "need_body";
+ when Field_Block_Configuration =>
+ return "block_configuration";
+ when Field_Concurrent_Statement_Chain =>
+ return "concurrent_statement_chain";
+ when Field_Chain =>
+ return "chain";
+ when Field_Port_Chain =>
+ return "port_chain";
+ when Field_Generic_Chain =>
+ return "generic_chain";
+ when Field_Type =>
+ return "type";
+ when Field_Subtype_Indication =>
+ return "subtype_indication";
+ when Field_Discrete_Range =>
+ return "discrete_range";
+ when Field_Type_Definition =>
+ return "type_definition";
+ when Field_Subtype_Definition =>
+ return "subtype_definition";
+ when Field_Nature =>
+ return "nature";
+ when Field_Mode =>
+ return "mode";
+ when Field_Signal_Kind =>
+ return "signal_kind";
+ when Field_Base_Name =>
+ return "base_name";
+ when Field_Interface_Declaration_Chain =>
+ return "interface_declaration_chain";
+ when Field_Subprogram_Specification =>
+ return "subprogram_specification";
+ when Field_Sequential_Statement_Chain =>
+ return "sequential_statement_chain";
+ when Field_Subprogram_Body =>
+ return "subprogram_body";
+ when Field_Overload_Number =>
+ return "overload_number";
+ when Field_Subprogram_Depth =>
+ return "subprogram_depth";
+ when Field_Subprogram_Hash =>
+ return "subprogram_hash";
+ when Field_Impure_Depth =>
+ return "impure_depth";
+ when Field_Return_Type =>
+ return "return_type";
+ when Field_Implicit_Definition =>
+ return "implicit_definition";
+ when Field_Type_Reference =>
+ return "type_reference";
+ when Field_Default_Value =>
+ return "default_value";
+ when Field_Deferred_Declaration =>
+ return "deferred_declaration";
+ when Field_Deferred_Declaration_Flag =>
+ return "deferred_declaration_flag";
+ when Field_Shared_Flag =>
+ return "shared_flag";
+ when Field_Design_Unit =>
+ return "design_unit";
+ when Field_Block_Statement =>
+ return "block_statement";
+ when Field_Signal_Driver =>
+ return "signal_driver";
+ when Field_Declaration_Chain =>
+ return "declaration_chain";
+ when Field_File_Logical_Name =>
+ return "file_logical_name";
+ when Field_File_Open_Kind =>
+ return "file_open_kind";
+ when Field_Element_Position =>
+ return "element_position";
+ when Field_Element_Declaration =>
+ return "element_declaration";
+ when Field_Selected_Element =>
+ return "selected_element";
+ when Field_Use_Clause_Chain =>
+ return "use_clause_chain";
+ when Field_Selected_Name =>
+ return "selected_name";
+ when Field_Type_Declarator =>
+ return "type_declarator";
+ when Field_Enumeration_Literal_List =>
+ return "enumeration_literal_list";
+ when Field_Entity_Class_Entry_Chain =>
+ return "entity_class_entry_chain";
+ when Field_Group_Constituent_List =>
+ return "group_constituent_list";
+ when Field_Unit_Chain =>
+ return "unit_chain";
+ when Field_Primary_Unit =>
+ return "primary_unit";
+ when Field_Identifier =>
+ return "identifier";
+ when Field_Label =>
+ return "label";
+ when Field_Visible_Flag =>
+ return "visible_flag";
+ when Field_Range_Constraint =>
+ return "range_constraint";
+ when Field_Direction =>
+ return "direction";
+ when Field_Left_Limit =>
+ return "left_limit";
+ when Field_Right_Limit =>
+ return "right_limit";
+ when Field_Base_Type =>
+ return "base_type";
+ when Field_Resolution_Indication =>
+ return "resolution_indication";
+ when Field_Record_Element_Resolution_Chain =>
+ return "record_element_resolution_chain";
+ when Field_Tolerance =>
+ return "tolerance";
+ when Field_Plus_Terminal =>
+ return "plus_terminal";
+ when Field_Minus_Terminal =>
+ return "minus_terminal";
+ when Field_Simultaneous_Left =>
+ return "simultaneous_left";
+ when Field_Simultaneous_Right =>
+ return "simultaneous_right";
+ when Field_Text_File_Flag =>
+ return "text_file_flag";
+ when Field_Only_Characters_Flag =>
+ return "only_characters_flag";
+ when Field_Type_Staticness =>
+ return "type_staticness";
+ when Field_Constraint_State =>
+ return "constraint_state";
+ when Field_Index_Subtype_List =>
+ return "index_subtype_list";
+ when Field_Index_Subtype_Definition_List =>
+ return "index_subtype_definition_list";
+ when Field_Element_Subtype_Indication =>
+ return "element_subtype_indication";
+ when Field_Element_Subtype =>
+ return "element_subtype";
+ when Field_Index_Constraint_List =>
+ return "index_constraint_list";
+ when Field_Array_Element_Constraint =>
+ return "array_element_constraint";
+ when Field_Elements_Declaration_List =>
+ return "elements_declaration_list";
+ when Field_Designated_Type =>
+ return "designated_type";
+ when Field_Designated_Subtype_Indication =>
+ return "designated_subtype_indication";
+ when Field_Index_List =>
+ return "index_list";
+ when Field_Reference =>
+ return "reference";
+ when Field_Nature_Declarator =>
+ return "nature_declarator";
+ when Field_Across_Type =>
+ return "across_type";
+ when Field_Through_Type =>
+ return "through_type";
+ when Field_Target =>
+ return "target";
+ when Field_Waveform_Chain =>
+ return "waveform_chain";
+ when Field_Guard =>
+ return "guard";
+ when Field_Delay_Mechanism =>
+ return "delay_mechanism";
+ when Field_Reject_Time_Expression =>
+ return "reject_time_expression";
+ when Field_Sensitivity_List =>
+ return "sensitivity_list";
+ when Field_Process_Origin =>
+ return "process_origin";
+ when Field_Condition_Clause =>
+ return "condition_clause";
+ when Field_Timeout_Clause =>
+ return "timeout_clause";
+ when Field_Postponed_Flag =>
+ return "postponed_flag";
+ when Field_Callees_List =>
+ return "callees_list";
+ when Field_Passive_Flag =>
+ return "passive_flag";
+ when Field_Resolution_Function_Flag =>
+ return "resolution_function_flag";
+ when Field_Wait_State =>
+ return "wait_state";
+ when Field_All_Sensitized_State =>
+ return "all_sensitized_state";
+ when Field_Seen_Flag =>
+ return "seen_flag";
+ when Field_Pure_Flag =>
+ return "pure_flag";
+ when Field_Foreign_Flag =>
+ return "foreign_flag";
+ when Field_Resolved_Flag =>
+ return "resolved_flag";
+ when Field_Signal_Type_Flag =>
+ return "signal_type_flag";
+ when Field_Has_Signal_Flag =>
+ return "has_signal_flag";
+ when Field_Purity_State =>
+ return "purity_state";
+ when Field_Elab_Flag =>
+ return "elab_flag";
+ when Field_Index_Constraint_Flag =>
+ return "index_constraint_flag";
+ when Field_Assertion_Condition =>
+ return "assertion_condition";
+ when Field_Report_Expression =>
+ return "report_expression";
+ when Field_Severity_Expression =>
+ return "severity_expression";
+ when Field_Instantiated_Unit =>
+ return "instantiated_unit";
+ when Field_Generic_Map_Aspect_Chain =>
+ return "generic_map_aspect_chain";
+ when Field_Port_Map_Aspect_Chain =>
+ return "port_map_aspect_chain";
+ when Field_Configuration_Name =>
+ return "configuration_name";
+ when Field_Component_Configuration =>
+ return "component_configuration";
+ when Field_Configuration_Specification =>
+ return "configuration_specification";
+ when Field_Default_Binding_Indication =>
+ return "default_binding_indication";
+ when Field_Default_Configuration_Declaration =>
+ return "default_configuration_declaration";
+ when Field_Expression =>
+ return "expression";
+ when Field_Allocator_Designated_Type =>
+ return "allocator_designated_type";
+ when Field_Selected_Waveform_Chain =>
+ return "selected_waveform_chain";
+ when Field_Conditional_Waveform_Chain =>
+ return "conditional_waveform_chain";
+ when Field_Guard_Expression =>
+ return "guard_expression";
+ when Field_Guard_Decl =>
+ return "guard_decl";
+ when Field_Guard_Sensitivity_List =>
+ return "guard_sensitivity_list";
+ when Field_Block_Block_Configuration =>
+ return "block_block_configuration";
+ when Field_Package_Header =>
+ return "package_header";
+ when Field_Block_Header =>
+ return "block_header";
+ when Field_Uninstantiated_Package_Name =>
+ return "uninstantiated_package_name";
+ when Field_Generate_Block_Configuration =>
+ return "generate_block_configuration";
+ when Field_Generation_Scheme =>
+ return "generation_scheme";
+ when Field_Condition =>
+ return "condition";
+ when Field_Else_Clause =>
+ return "else_clause";
+ when Field_Parameter_Specification =>
+ return "parameter_specification";
+ when Field_Parent =>
+ return "parent";
+ when Field_Loop_Label =>
+ return "loop_label";
+ when Field_Component_Name =>
+ return "component_name";
+ when Field_Instantiation_List =>
+ return "instantiation_list";
+ when Field_Entity_Aspect =>
+ return "entity_aspect";
+ when Field_Default_Entity_Aspect =>
+ return "default_entity_aspect";
+ when Field_Default_Generic_Map_Aspect_Chain =>
+ return "default_generic_map_aspect_chain";
+ when Field_Default_Port_Map_Aspect_Chain =>
+ return "default_port_map_aspect_chain";
+ when Field_Binding_Indication =>
+ return "binding_indication";
+ when Field_Named_Entity =>
+ return "named_entity";
+ when Field_Alias_Declaration =>
+ return "alias_declaration";
+ when Field_Expr_Staticness =>
+ return "expr_staticness";
+ when Field_Error_Origin =>
+ return "error_origin";
+ when Field_Operand =>
+ return "operand";
+ when Field_Left =>
+ return "left";
+ when Field_Right =>
+ return "right";
+ when Field_Unit_Name =>
+ return "unit_name";
+ when Field_Name =>
+ return "name";
+ when Field_Group_Template_Name =>
+ return "group_template_name";
+ when Field_Name_Staticness =>
+ return "name_staticness";
+ when Field_Prefix =>
+ return "prefix";
+ when Field_Signature_Prefix =>
+ return "signature_prefix";
+ when Field_Slice_Subtype =>
+ return "slice_subtype";
+ when Field_Suffix =>
+ return "suffix";
+ when Field_Index_Subtype =>
+ return "index_subtype";
+ when Field_Parameter =>
+ return "parameter";
+ when Field_Actual_Type =>
+ return "actual_type";
+ when Field_Associated_Interface =>
+ return "associated_interface";
+ when Field_Association_Chain =>
+ return "association_chain";
+ when Field_Individual_Association_Chain =>
+ return "individual_association_chain";
+ when Field_Aggregate_Info =>
+ return "aggregate_info";
+ when Field_Sub_Aggregate_Info =>
+ return "sub_aggregate_info";
+ when Field_Aggr_Dynamic_Flag =>
+ return "aggr_dynamic_flag";
+ when Field_Aggr_Min_Length =>
+ return "aggr_min_length";
+ when Field_Aggr_Low_Limit =>
+ return "aggr_low_limit";
+ when Field_Aggr_High_Limit =>
+ return "aggr_high_limit";
+ when Field_Aggr_Others_Flag =>
+ return "aggr_others_flag";
+ when Field_Aggr_Named_Flag =>
+ return "aggr_named_flag";
+ when Field_Value_Staticness =>
+ return "value_staticness";
+ when Field_Association_Choices_Chain =>
+ return "association_choices_chain";
+ when Field_Case_Statement_Alternative_Chain =>
+ return "case_statement_alternative_chain";
+ when Field_Choice_Staticness =>
+ return "choice_staticness";
+ when Field_Procedure_Call =>
+ return "procedure_call";
+ when Field_Implementation =>
+ return "implementation";
+ when Field_Parameter_Association_Chain =>
+ return "parameter_association_chain";
+ when Field_Method_Object =>
+ return "method_object";
+ when Field_Subtype_Type_Mark =>
+ return "subtype_type_mark";
+ when Field_Type_Conversion_Subtype =>
+ return "type_conversion_subtype";
+ when Field_Type_Mark =>
+ return "type_mark";
+ when Field_File_Type_Mark =>
+ return "file_type_mark";
+ when Field_Return_Type_Mark =>
+ return "return_type_mark";
+ when Field_Lexical_Layout =>
+ return "lexical_layout";
+ when Field_Incomplete_Type_List =>
+ return "incomplete_type_list";
+ when Field_Has_Disconnect_Flag =>
+ return "has_disconnect_flag";
+ when Field_Has_Active_Flag =>
+ return "has_active_flag";
+ when Field_Is_Within_Flag =>
+ return "is_within_flag";
+ when Field_Type_Marks_List =>
+ return "type_marks_list";
+ when Field_Implicit_Alias_Flag =>
+ return "implicit_alias_flag";
+ when Field_Alias_Signature =>
+ return "alias_signature";
+ when Field_Attribute_Signature =>
+ return "attribute_signature";
+ when Field_Overload_List =>
+ return "overload_list";
+ when Field_Simple_Name_Identifier =>
+ return "simple_name_identifier";
+ when Field_Simple_Name_Subtype =>
+ return "simple_name_subtype";
+ when Field_Protected_Type_Body =>
+ return "protected_type_body";
+ when Field_Protected_Type_Declaration =>
+ return "protected_type_declaration";
+ when Field_End_Location =>
+ return "end_location";
+ when Field_String_Id =>
+ return "string_id";
+ when Field_String_Length =>
+ return "string_length";
+ when Field_Use_Flag =>
+ return "use_flag";
+ when Field_End_Has_Reserved_Id =>
+ return "end_has_reserved_id";
+ when Field_End_Has_Identifier =>
+ return "end_has_identifier";
+ when Field_End_Has_Postponed =>
+ return "end_has_postponed";
+ when Field_Has_Begin =>
+ return "has_begin";
+ when Field_Has_Is =>
+ return "has_is";
+ when Field_Has_Pure =>
+ return "has_pure";
+ when Field_Has_Body =>
+ return "has_body";
+ when Field_Has_Identifier_List =>
+ return "has_identifier_list";
+ when Field_Has_Mode =>
+ return "has_mode";
+ when Field_Is_Ref =>
+ return "is_ref";
+ when Field_Psl_Property =>
+ return "psl_property";
+ when Field_Psl_Declaration =>
+ return "psl_declaration";
+ when Field_Psl_Expression =>
+ return "psl_expression";
+ when Field_Psl_Boolean =>
+ return "psl_boolean";
+ when Field_PSL_Clock =>
+ return "psl_clock";
+ when Field_PSL_NFA =>
+ return "psl_nfa";
+ end case;
+ end Get_Field_Image;
+
+ function Get_Iir_Image (K : Iir_Kind) return String is
+ begin
+ case K is
+ when Iir_Kind_Unused =>
+ return "unused";
+ when Iir_Kind_Error =>
+ return "error";
+ when Iir_Kind_Design_File =>
+ return "design_file";
+ when Iir_Kind_Design_Unit =>
+ return "design_unit";
+ when Iir_Kind_Library_Clause =>
+ return "library_clause";
+ when Iir_Kind_Use_Clause =>
+ return "use_clause";
+ when Iir_Kind_Integer_Literal =>
+ return "integer_literal";
+ when Iir_Kind_Floating_Point_Literal =>
+ return "floating_point_literal";
+ when Iir_Kind_Null_Literal =>
+ return "null_literal";
+ when Iir_Kind_String_Literal =>
+ return "string_literal";
+ when Iir_Kind_Physical_Int_Literal =>
+ return "physical_int_literal";
+ when Iir_Kind_Physical_Fp_Literal =>
+ return "physical_fp_literal";
+ when Iir_Kind_Bit_String_Literal =>
+ return "bit_string_literal";
+ when Iir_Kind_Simple_Aggregate =>
+ return "simple_aggregate";
+ when Iir_Kind_Overflow_Literal =>
+ return "overflow_literal";
+ when Iir_Kind_Waveform_Element =>
+ return "waveform_element";
+ when Iir_Kind_Conditional_Waveform =>
+ return "conditional_waveform";
+ when Iir_Kind_Association_Element_By_Expression =>
+ return "association_element_by_expression";
+ when Iir_Kind_Association_Element_By_Individual =>
+ return "association_element_by_individual";
+ when Iir_Kind_Association_Element_Open =>
+ return "association_element_open";
+ when Iir_Kind_Association_Element_Package =>
+ return "association_element_package";
+ when Iir_Kind_Choice_By_Others =>
+ return "choice_by_others";
+ when Iir_Kind_Choice_By_Expression =>
+ return "choice_by_expression";
+ when Iir_Kind_Choice_By_Range =>
+ return "choice_by_range";
+ when Iir_Kind_Choice_By_None =>
+ return "choice_by_none";
+ when Iir_Kind_Choice_By_Name =>
+ return "choice_by_name";
+ when Iir_Kind_Entity_Aspect_Entity =>
+ return "entity_aspect_entity";
+ when Iir_Kind_Entity_Aspect_Configuration =>
+ return "entity_aspect_configuration";
+ when Iir_Kind_Entity_Aspect_Open =>
+ return "entity_aspect_open";
+ when Iir_Kind_Block_Configuration =>
+ return "block_configuration";
+ when Iir_Kind_Block_Header =>
+ return "block_header";
+ when Iir_Kind_Component_Configuration =>
+ return "component_configuration";
+ when Iir_Kind_Binding_Indication =>
+ return "binding_indication";
+ when Iir_Kind_Entity_Class =>
+ return "entity_class";
+ when Iir_Kind_Attribute_Value =>
+ return "attribute_value";
+ when Iir_Kind_Signature =>
+ return "signature";
+ when Iir_Kind_Aggregate_Info =>
+ return "aggregate_info";
+ when Iir_Kind_Procedure_Call =>
+ return "procedure_call";
+ when Iir_Kind_Record_Element_Constraint =>
+ return "record_element_constraint";
+ when Iir_Kind_Array_Element_Resolution =>
+ return "array_element_resolution";
+ when Iir_Kind_Record_Resolution =>
+ return "record_resolution";
+ when Iir_Kind_Record_Element_Resolution =>
+ return "record_element_resolution";
+ when Iir_Kind_Attribute_Specification =>
+ return "attribute_specification";
+ when Iir_Kind_Disconnection_Specification =>
+ return "disconnection_specification";
+ when Iir_Kind_Configuration_Specification =>
+ return "configuration_specification";
+ when Iir_Kind_Access_Type_Definition =>
+ return "access_type_definition";
+ when Iir_Kind_Incomplete_Type_Definition =>
+ return "incomplete_type_definition";
+ when Iir_Kind_File_Type_Definition =>
+ return "file_type_definition";
+ when Iir_Kind_Protected_Type_Declaration =>
+ return "protected_type_declaration";
+ when Iir_Kind_Record_Type_Definition =>
+ return "record_type_definition";
+ when Iir_Kind_Array_Type_Definition =>
+ return "array_type_definition";
+ when Iir_Kind_Array_Subtype_Definition =>
+ return "array_subtype_definition";
+ when Iir_Kind_Record_Subtype_Definition =>
+ return "record_subtype_definition";
+ when Iir_Kind_Access_Subtype_Definition =>
+ return "access_subtype_definition";
+ when Iir_Kind_Physical_Subtype_Definition =>
+ return "physical_subtype_definition";
+ when Iir_Kind_Floating_Subtype_Definition =>
+ return "floating_subtype_definition";
+ when Iir_Kind_Integer_Subtype_Definition =>
+ return "integer_subtype_definition";
+ when Iir_Kind_Enumeration_Subtype_Definition =>
+ return "enumeration_subtype_definition";
+ when Iir_Kind_Enumeration_Type_Definition =>
+ return "enumeration_type_definition";
+ when Iir_Kind_Integer_Type_Definition =>
+ return "integer_type_definition";
+ when Iir_Kind_Floating_Type_Definition =>
+ return "floating_type_definition";
+ when Iir_Kind_Physical_Type_Definition =>
+ return "physical_type_definition";
+ when Iir_Kind_Range_Expression =>
+ return "range_expression";
+ when Iir_Kind_Protected_Type_Body =>
+ return "protected_type_body";
+ when Iir_Kind_Subtype_Definition =>
+ return "subtype_definition";
+ when Iir_Kind_Scalar_Nature_Definition =>
+ return "scalar_nature_definition";
+ when Iir_Kind_Overload_List =>
+ return "overload_list";
+ when Iir_Kind_Type_Declaration =>
+ return "type_declaration";
+ when Iir_Kind_Anonymous_Type_Declaration =>
+ return "anonymous_type_declaration";
+ when Iir_Kind_Subtype_Declaration =>
+ return "subtype_declaration";
+ when Iir_Kind_Nature_Declaration =>
+ return "nature_declaration";
+ when Iir_Kind_Subnature_Declaration =>
+ return "subnature_declaration";
+ when Iir_Kind_Package_Declaration =>
+ return "package_declaration";
+ when Iir_Kind_Package_Instantiation_Declaration =>
+ return "package_instantiation_declaration";
+ when Iir_Kind_Package_Body =>
+ return "package_body";
+ when Iir_Kind_Configuration_Declaration =>
+ return "configuration_declaration";
+ when Iir_Kind_Entity_Declaration =>
+ return "entity_declaration";
+ when Iir_Kind_Architecture_Body =>
+ return "architecture_body";
+ when Iir_Kind_Package_Header =>
+ return "package_header";
+ when Iir_Kind_Unit_Declaration =>
+ return "unit_declaration";
+ when Iir_Kind_Library_Declaration =>
+ return "library_declaration";
+ when Iir_Kind_Component_Declaration =>
+ return "component_declaration";
+ when Iir_Kind_Attribute_Declaration =>
+ return "attribute_declaration";
+ when Iir_Kind_Group_Template_Declaration =>
+ return "group_template_declaration";
+ when Iir_Kind_Group_Declaration =>
+ return "group_declaration";
+ when Iir_Kind_Element_Declaration =>
+ return "element_declaration";
+ when Iir_Kind_Non_Object_Alias_Declaration =>
+ return "non_object_alias_declaration";
+ when Iir_Kind_Psl_Declaration =>
+ return "psl_declaration";
+ when Iir_Kind_Terminal_Declaration =>
+ return "terminal_declaration";
+ when Iir_Kind_Free_Quantity_Declaration =>
+ return "free_quantity_declaration";
+ when Iir_Kind_Across_Quantity_Declaration =>
+ return "across_quantity_declaration";
+ when Iir_Kind_Through_Quantity_Declaration =>
+ return "through_quantity_declaration";
+ when Iir_Kind_Enumeration_Literal =>
+ return "enumeration_literal";
+ when Iir_Kind_Function_Declaration =>
+ return "function_declaration";
+ when Iir_Kind_Implicit_Function_Declaration =>
+ return "implicit_function_declaration";
+ when Iir_Kind_Implicit_Procedure_Declaration =>
+ return "implicit_procedure_declaration";
+ when Iir_Kind_Procedure_Declaration =>
+ return "procedure_declaration";
+ when Iir_Kind_Function_Body =>
+ return "function_body";
+ when Iir_Kind_Procedure_Body =>
+ return "procedure_body";
+ when Iir_Kind_Object_Alias_Declaration =>
+ return "object_alias_declaration";
+ when Iir_Kind_File_Declaration =>
+ return "file_declaration";
+ when Iir_Kind_Guard_Signal_Declaration =>
+ return "guard_signal_declaration";
+ when Iir_Kind_Signal_Declaration =>
+ return "signal_declaration";
+ when Iir_Kind_Variable_Declaration =>
+ return "variable_declaration";
+ when Iir_Kind_Constant_Declaration =>
+ return "constant_declaration";
+ when Iir_Kind_Iterator_Declaration =>
+ return "iterator_declaration";
+ when Iir_Kind_Interface_Constant_Declaration =>
+ return "interface_constant_declaration";
+ when Iir_Kind_Interface_Variable_Declaration =>
+ return "interface_variable_declaration";
+ when Iir_Kind_Interface_Signal_Declaration =>
+ return "interface_signal_declaration";
+ when Iir_Kind_Interface_File_Declaration =>
+ return "interface_file_declaration";
+ when Iir_Kind_Interface_Package_Declaration =>
+ return "interface_package_declaration";
+ when Iir_Kind_Identity_Operator =>
+ return "identity_operator";
+ when Iir_Kind_Negation_Operator =>
+ return "negation_operator";
+ when Iir_Kind_Absolute_Operator =>
+ return "absolute_operator";
+ when Iir_Kind_Not_Operator =>
+ return "not_operator";
+ when Iir_Kind_Condition_Operator =>
+ return "condition_operator";
+ when Iir_Kind_Reduction_And_Operator =>
+ return "reduction_and_operator";
+ when Iir_Kind_Reduction_Or_Operator =>
+ return "reduction_or_operator";
+ when Iir_Kind_Reduction_Nand_Operator =>
+ return "reduction_nand_operator";
+ when Iir_Kind_Reduction_Nor_Operator =>
+ return "reduction_nor_operator";
+ when Iir_Kind_Reduction_Xor_Operator =>
+ return "reduction_xor_operator";
+ when Iir_Kind_Reduction_Xnor_Operator =>
+ return "reduction_xnor_operator";
+ when Iir_Kind_And_Operator =>
+ return "and_operator";
+ when Iir_Kind_Or_Operator =>
+ return "or_operator";
+ when Iir_Kind_Nand_Operator =>
+ return "nand_operator";
+ when Iir_Kind_Nor_Operator =>
+ return "nor_operator";
+ when Iir_Kind_Xor_Operator =>
+ return "xor_operator";
+ when Iir_Kind_Xnor_Operator =>
+ return "xnor_operator";
+ when Iir_Kind_Equality_Operator =>
+ return "equality_operator";
+ when Iir_Kind_Inequality_Operator =>
+ return "inequality_operator";
+ when Iir_Kind_Less_Than_Operator =>
+ return "less_than_operator";
+ when Iir_Kind_Less_Than_Or_Equal_Operator =>
+ return "less_than_or_equal_operator";
+ when Iir_Kind_Greater_Than_Operator =>
+ return "greater_than_operator";
+ when Iir_Kind_Greater_Than_Or_Equal_Operator =>
+ return "greater_than_or_equal_operator";
+ when Iir_Kind_Match_Equality_Operator =>
+ return "match_equality_operator";
+ when Iir_Kind_Match_Inequality_Operator =>
+ return "match_inequality_operator";
+ when Iir_Kind_Match_Less_Than_Operator =>
+ return "match_less_than_operator";
+ when Iir_Kind_Match_Less_Than_Or_Equal_Operator =>
+ return "match_less_than_or_equal_operator";
+ when Iir_Kind_Match_Greater_Than_Operator =>
+ return "match_greater_than_operator";
+ when Iir_Kind_Match_Greater_Than_Or_Equal_Operator =>
+ return "match_greater_than_or_equal_operator";
+ when Iir_Kind_Sll_Operator =>
+ return "sll_operator";
+ when Iir_Kind_Sla_Operator =>
+ return "sla_operator";
+ when Iir_Kind_Srl_Operator =>
+ return "srl_operator";
+ when Iir_Kind_Sra_Operator =>
+ return "sra_operator";
+ when Iir_Kind_Rol_Operator =>
+ return "rol_operator";
+ when Iir_Kind_Ror_Operator =>
+ return "ror_operator";
+ when Iir_Kind_Addition_Operator =>
+ return "addition_operator";
+ when Iir_Kind_Substraction_Operator =>
+ return "substraction_operator";
+ when Iir_Kind_Concatenation_Operator =>
+ return "concatenation_operator";
+ when Iir_Kind_Multiplication_Operator =>
+ return "multiplication_operator";
+ when Iir_Kind_Division_Operator =>
+ return "division_operator";
+ when Iir_Kind_Modulus_Operator =>
+ return "modulus_operator";
+ when Iir_Kind_Remainder_Operator =>
+ return "remainder_operator";
+ when Iir_Kind_Exponentiation_Operator =>
+ return "exponentiation_operator";
+ when Iir_Kind_Function_Call =>
+ return "function_call";
+ when Iir_Kind_Aggregate =>
+ return "aggregate";
+ when Iir_Kind_Parenthesis_Expression =>
+ return "parenthesis_expression";
+ when Iir_Kind_Qualified_Expression =>
+ return "qualified_expression";
+ when Iir_Kind_Type_Conversion =>
+ return "type_conversion";
+ when Iir_Kind_Allocator_By_Expression =>
+ return "allocator_by_expression";
+ when Iir_Kind_Allocator_By_Subtype =>
+ return "allocator_by_subtype";
+ when Iir_Kind_Selected_Element =>
+ return "selected_element";
+ when Iir_Kind_Dereference =>
+ return "dereference";
+ when Iir_Kind_Implicit_Dereference =>
+ return "implicit_dereference";
+ when Iir_Kind_Slice_Name =>
+ return "slice_name";
+ when Iir_Kind_Indexed_Name =>
+ return "indexed_name";
+ when Iir_Kind_Psl_Expression =>
+ return "psl_expression";
+ when Iir_Kind_Sensitized_Process_Statement =>
+ return "sensitized_process_statement";
+ when Iir_Kind_Process_Statement =>
+ return "process_statement";
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment =>
+ return "concurrent_conditional_signal_assignment";
+ when Iir_Kind_Concurrent_Selected_Signal_Assignment =>
+ return "concurrent_selected_signal_assignment";
+ when Iir_Kind_Concurrent_Assertion_Statement =>
+ return "concurrent_assertion_statement";
+ when Iir_Kind_Psl_Default_Clock =>
+ return "psl_default_clock";
+ when Iir_Kind_Psl_Assert_Statement =>
+ return "psl_assert_statement";
+ when Iir_Kind_Psl_Cover_Statement =>
+ return "psl_cover_statement";
+ when Iir_Kind_Concurrent_Procedure_Call_Statement =>
+ return "concurrent_procedure_call_statement";
+ when Iir_Kind_Block_Statement =>
+ return "block_statement";
+ when Iir_Kind_Generate_Statement =>
+ return "generate_statement";
+ when Iir_Kind_Component_Instantiation_Statement =>
+ return "component_instantiation_statement";
+ when Iir_Kind_Simple_Simultaneous_Statement =>
+ return "simple_simultaneous_statement";
+ when Iir_Kind_Signal_Assignment_Statement =>
+ return "signal_assignment_statement";
+ when Iir_Kind_Null_Statement =>
+ return "null_statement";
+ when Iir_Kind_Assertion_Statement =>
+ return "assertion_statement";
+ when Iir_Kind_Report_Statement =>
+ return "report_statement";
+ when Iir_Kind_Wait_Statement =>
+ return "wait_statement";
+ when Iir_Kind_Variable_Assignment_Statement =>
+ return "variable_assignment_statement";
+ when Iir_Kind_Return_Statement =>
+ return "return_statement";
+ when Iir_Kind_For_Loop_Statement =>
+ return "for_loop_statement";
+ when Iir_Kind_While_Loop_Statement =>
+ return "while_loop_statement";
+ when Iir_Kind_Next_Statement =>
+ return "next_statement";
+ when Iir_Kind_Exit_Statement =>
+ return "exit_statement";
+ when Iir_Kind_Case_Statement =>
+ return "case_statement";
+ when Iir_Kind_Procedure_Call_Statement =>
+ return "procedure_call_statement";
+ when Iir_Kind_If_Statement =>
+ return "if_statement";
+ when Iir_Kind_Elsif =>
+ return "elsif";
+ when Iir_Kind_Character_Literal =>
+ return "character_literal";
+ when Iir_Kind_Simple_Name =>
+ return "simple_name";
+ when Iir_Kind_Selected_Name =>
+ return "selected_name";
+ when Iir_Kind_Operator_Symbol =>
+ return "operator_symbol";
+ when Iir_Kind_Selected_By_All_Name =>
+ return "selected_by_all_name";
+ when Iir_Kind_Parenthesis_Name =>
+ return "parenthesis_name";
+ when Iir_Kind_Base_Attribute =>
+ return "base_attribute";
+ when Iir_Kind_Left_Type_Attribute =>
+ return "left_type_attribute";
+ when Iir_Kind_Right_Type_Attribute =>
+ return "right_type_attribute";
+ when Iir_Kind_High_Type_Attribute =>
+ return "high_type_attribute";
+ when Iir_Kind_Low_Type_Attribute =>
+ return "low_type_attribute";
+ when Iir_Kind_Ascending_Type_Attribute =>
+ return "ascending_type_attribute";
+ when Iir_Kind_Image_Attribute =>
+ return "image_attribute";
+ when Iir_Kind_Value_Attribute =>
+ return "value_attribute";
+ when Iir_Kind_Pos_Attribute =>
+ return "pos_attribute";
+ when Iir_Kind_Val_Attribute =>
+ return "val_attribute";
+ when Iir_Kind_Succ_Attribute =>
+ return "succ_attribute";
+ when Iir_Kind_Pred_Attribute =>
+ return "pred_attribute";
+ when Iir_Kind_Leftof_Attribute =>
+ return "leftof_attribute";
+ when Iir_Kind_Rightof_Attribute =>
+ return "rightof_attribute";
+ when Iir_Kind_Delayed_Attribute =>
+ return "delayed_attribute";
+ when Iir_Kind_Stable_Attribute =>
+ return "stable_attribute";
+ when Iir_Kind_Quiet_Attribute =>
+ return "quiet_attribute";
+ when Iir_Kind_Transaction_Attribute =>
+ return "transaction_attribute";
+ when Iir_Kind_Event_Attribute =>
+ return "event_attribute";
+ when Iir_Kind_Active_Attribute =>
+ return "active_attribute";
+ when Iir_Kind_Last_Event_Attribute =>
+ return "last_event_attribute";
+ when Iir_Kind_Last_Active_Attribute =>
+ return "last_active_attribute";
+ when Iir_Kind_Last_Value_Attribute =>
+ return "last_value_attribute";
+ when Iir_Kind_Driving_Attribute =>
+ return "driving_attribute";
+ when Iir_Kind_Driving_Value_Attribute =>
+ return "driving_value_attribute";
+ when Iir_Kind_Behavior_Attribute =>
+ return "behavior_attribute";
+ when Iir_Kind_Structure_Attribute =>
+ return "structure_attribute";
+ when Iir_Kind_Simple_Name_Attribute =>
+ return "simple_name_attribute";
+ when Iir_Kind_Instance_Name_Attribute =>
+ return "instance_name_attribute";
+ when Iir_Kind_Path_Name_Attribute =>
+ return "path_name_attribute";
+ when Iir_Kind_Left_Array_Attribute =>
+ return "left_array_attribute";
+ when Iir_Kind_Right_Array_Attribute =>
+ return "right_array_attribute";
+ when Iir_Kind_High_Array_Attribute =>
+ return "high_array_attribute";
+ when Iir_Kind_Low_Array_Attribute =>
+ return "low_array_attribute";
+ when Iir_Kind_Length_Array_Attribute =>
+ return "length_array_attribute";
+ when Iir_Kind_Ascending_Array_Attribute =>
+ return "ascending_array_attribute";
+ when Iir_Kind_Range_Array_Attribute =>
+ return "range_array_attribute";
+ when Iir_Kind_Reverse_Range_Array_Attribute =>
+ return "reverse_range_array_attribute";
+ when Iir_Kind_Attribute_Name =>
+ return "attribute_name";
+ end case;
+ end Get_Iir_Image;
+
+ function Get_Field_Attribute (F : Fields_Enum) return Field_Attribute is
+ begin
+ case F is
+ when Field_First_Design_Unit =>
+ return Attr_Chain;
+ when Field_Last_Design_Unit =>
+ return Attr_Ref;
+ when Field_Library_Declaration =>
+ return Attr_None;
+ when Field_File_Time_Stamp =>
+ return Attr_None;
+ when Field_Analysis_Time_Stamp =>
+ return Attr_None;
+ when Field_Library =>
+ return Attr_Ref;
+ when Field_File_Dependence_List =>
+ return Attr_None;
+ when Field_Design_File_Filename =>
+ return Attr_None;
+ when Field_Design_File_Directory =>
+ return Attr_None;
+ when Field_Design_File =>
+ return Attr_Ref;
+ when Field_Design_File_Chain =>
+ return Attr_Chain;
+ when Field_Library_Directory =>
+ return Attr_None;
+ when Field_Date =>
+ return Attr_None;
+ when Field_Context_Items =>
+ return Attr_Chain;
+ when Field_Dependence_List =>
+ return Attr_Of_Ref;
+ when Field_Analysis_Checks_List =>
+ return Attr_None;
+ when Field_Date_State =>
+ return Attr_None;
+ when Field_Guarded_Target_State =>
+ return Attr_None;
+ when Field_Library_Unit =>
+ return Attr_None;
+ when Field_Hash_Chain =>
+ return Attr_Ref;
+ when Field_Design_Unit_Source_Pos =>
+ return Attr_None;
+ when Field_Design_Unit_Source_Line =>
+ return Attr_None;
+ when Field_Design_Unit_Source_Col =>
+ return Attr_None;
+ when Field_Value =>
+ return Attr_None;
+ when Field_Enum_Pos =>
+ return Attr_None;
+ when Field_Physical_Literal =>
+ return Attr_None;
+ when Field_Physical_Unit_Value =>
+ return Attr_None;
+ when Field_Fp_Value =>
+ return Attr_None;
+ when Field_Enumeration_Decl =>
+ return Attr_Ref;
+ when Field_Simple_Aggregate_List =>
+ return Attr_None;
+ when Field_Bit_String_Base =>
+ return Attr_None;
+ when Field_Bit_String_0 =>
+ return Attr_None;
+ when Field_Bit_String_1 =>
+ return Attr_None;
+ when Field_Literal_Origin =>
+ return Attr_None;
+ when Field_Range_Origin =>
+ return Attr_None;
+ when Field_Literal_Subtype =>
+ return Attr_None;
+ when Field_Entity_Class =>
+ return Attr_None;
+ when Field_Entity_Name_List =>
+ return Attr_None;
+ when Field_Attribute_Designator =>
+ return Attr_None;
+ when Field_Attribute_Specification_Chain =>
+ return Attr_None;
+ when Field_Attribute_Specification =>
+ return Attr_Ref;
+ when Field_Signal_List =>
+ return Attr_None;
+ when Field_Designated_Entity =>
+ return Attr_Ref;
+ when Field_Formal =>
+ return Attr_None;
+ when Field_Actual =>
+ return Attr_None;
+ when Field_In_Conversion =>
+ return Attr_None;
+ when Field_Out_Conversion =>
+ return Attr_None;
+ when Field_Whole_Association_Flag =>
+ return Attr_None;
+ when Field_Collapse_Signal_Flag =>
+ return Attr_None;
+ when Field_Artificial_Flag =>
+ return Attr_None;
+ when Field_Open_Flag =>
+ return Attr_None;
+ when Field_After_Drivers_Flag =>
+ return Attr_None;
+ when Field_We_Value =>
+ return Attr_None;
+ when Field_Time =>
+ return Attr_None;
+ when Field_Associated_Expr =>
+ return Attr_None;
+ when Field_Associated_Chain =>
+ return Attr_Chain;
+ when Field_Choice_Name =>
+ return Attr_None;
+ when Field_Choice_Expression =>
+ return Attr_None;
+ when Field_Choice_Range =>
+ return Attr_None;
+ when Field_Same_Alternative_Flag =>
+ return Attr_None;
+ when Field_Architecture =>
+ return Attr_None;
+ when Field_Block_Specification =>
+ return Attr_None;
+ when Field_Prev_Block_Configuration =>
+ return Attr_Ref;
+ when Field_Configuration_Item_Chain =>
+ return Attr_Chain;
+ when Field_Attribute_Value_Chain =>
+ return Attr_Chain;
+ when Field_Spec_Chain =>
+ return Attr_None;
+ when Field_Attribute_Value_Spec_Chain =>
+ return Attr_None;
+ when Field_Entity_Name =>
+ return Attr_None;
+ when Field_Package =>
+ return Attr_Ref;
+ when Field_Package_Body =>
+ return Attr_Ref;
+ when Field_Need_Body =>
+ return Attr_None;
+ when Field_Block_Configuration =>
+ return Attr_None;
+ when Field_Concurrent_Statement_Chain =>
+ return Attr_Chain;
+ when Field_Chain =>
+ return Attr_Chain_Next;
+ when Field_Port_Chain =>
+ return Attr_Chain;
+ when Field_Generic_Chain =>
+ return Attr_Chain;
+ when Field_Type =>
+ return Attr_Ref;
+ when Field_Subtype_Indication =>
+ return Attr_Maybe_Ref;
+ when Field_Discrete_Range =>
+ return Attr_None;
+ when Field_Type_Definition =>
+ return Attr_None;
+ when Field_Subtype_Definition =>
+ return Attr_None;
+ when Field_Nature =>
+ return Attr_None;
+ when Field_Mode =>
+ return Attr_None;
+ when Field_Signal_Kind =>
+ return Attr_None;
+ when Field_Base_Name =>
+ return Attr_Ref;
+ when Field_Interface_Declaration_Chain =>
+ return Attr_Chain;
+ when Field_Subprogram_Specification =>
+ return Attr_Ref;
+ when Field_Sequential_Statement_Chain =>
+ return Attr_Chain;
+ when Field_Subprogram_Body =>
+ return Attr_Ref;
+ when Field_Overload_Number =>
+ return Attr_None;
+ when Field_Subprogram_Depth =>
+ return Attr_None;
+ when Field_Subprogram_Hash =>
+ return Attr_None;
+ when Field_Impure_Depth =>
+ return Attr_None;
+ when Field_Return_Type =>
+ return Attr_Ref;
+ when Field_Implicit_Definition =>
+ return Attr_None;
+ when Field_Type_Reference =>
+ return Attr_Ref;
+ when Field_Default_Value =>
+ return Attr_Maybe_Ref;
+ when Field_Deferred_Declaration =>
+ return Attr_None;
+ when Field_Deferred_Declaration_Flag =>
+ return Attr_None;
+ when Field_Shared_Flag =>
+ return Attr_None;
+ when Field_Design_Unit =>
+ return Attr_None;
+ when Field_Block_Statement =>
+ return Attr_None;
+ when Field_Signal_Driver =>
+ return Attr_None;
+ when Field_Declaration_Chain =>
+ return Attr_Chain;
+ when Field_File_Logical_Name =>
+ return Attr_None;
+ when Field_File_Open_Kind =>
+ return Attr_None;
+ when Field_Element_Position =>
+ return Attr_None;
+ when Field_Element_Declaration =>
+ return Attr_None;
+ when Field_Selected_Element =>
+ return Attr_Ref;
+ when Field_Use_Clause_Chain =>
+ return Attr_None;
+ when Field_Selected_Name =>
+ return Attr_None;
+ when Field_Type_Declarator =>
+ return Attr_Ref;
+ when Field_Enumeration_Literal_List =>
+ return Attr_None;
+ when Field_Entity_Class_Entry_Chain =>
+ return Attr_Chain;
+ when Field_Group_Constituent_List =>
+ return Attr_None;
+ when Field_Unit_Chain =>
+ return Attr_Chain;
+ when Field_Primary_Unit =>
+ return Attr_Ref;
+ when Field_Identifier =>
+ return Attr_None;
+ when Field_Label =>
+ return Attr_None;
+ when Field_Visible_Flag =>
+ return Attr_None;
+ when Field_Range_Constraint =>
+ return Attr_None;
+ when Field_Direction =>
+ return Attr_None;
+ when Field_Left_Limit =>
+ return Attr_None;
+ when Field_Right_Limit =>
+ return Attr_None;
+ when Field_Base_Type =>
+ return Attr_Ref;
+ when Field_Resolution_Indication =>
+ return Attr_None;
+ when Field_Record_Element_Resolution_Chain =>
+ return Attr_Chain;
+ when Field_Tolerance =>
+ return Attr_None;
+ when Field_Plus_Terminal =>
+ return Attr_None;
+ when Field_Minus_Terminal =>
+ return Attr_None;
+ when Field_Simultaneous_Left =>
+ return Attr_None;
+ when Field_Simultaneous_Right =>
+ return Attr_None;
+ when Field_Text_File_Flag =>
+ return Attr_None;
+ when Field_Only_Characters_Flag =>
+ return Attr_None;
+ when Field_Type_Staticness =>
+ return Attr_None;
+ when Field_Constraint_State =>
+ return Attr_None;
+ when Field_Index_Subtype_List =>
+ return Attr_Ref;
+ when Field_Index_Subtype_Definition_List =>
+ return Attr_None;
+ when Field_Element_Subtype_Indication =>
+ return Attr_None;
+ when Field_Element_Subtype =>
+ return Attr_Ref;
+ when Field_Index_Constraint_List =>
+ return Attr_None;
+ when Field_Array_Element_Constraint =>
+ return Attr_None;
+ when Field_Elements_Declaration_List =>
+ return Attr_None;
+ when Field_Designated_Type =>
+ return Attr_Ref;
+ when Field_Designated_Subtype_Indication =>
+ return Attr_None;
+ when Field_Index_List =>
+ return Attr_None;
+ when Field_Reference =>
+ return Attr_None;
+ when Field_Nature_Declarator =>
+ return Attr_None;
+ when Field_Across_Type =>
+ return Attr_None;
+ when Field_Through_Type =>
+ return Attr_None;
+ when Field_Target =>
+ return Attr_None;
+ when Field_Waveform_Chain =>
+ return Attr_Chain;
+ when Field_Guard =>
+ return Attr_None;
+ when Field_Delay_Mechanism =>
+ return Attr_None;
+ when Field_Reject_Time_Expression =>
+ return Attr_None;
+ when Field_Sensitivity_List =>
+ return Attr_None;
+ when Field_Process_Origin =>
+ return Attr_None;
+ when Field_Condition_Clause =>
+ return Attr_None;
+ when Field_Timeout_Clause =>
+ return Attr_None;
+ when Field_Postponed_Flag =>
+ return Attr_None;
+ when Field_Callees_List =>
+ return Attr_Of_Ref;
+ when Field_Passive_Flag =>
+ return Attr_None;
+ when Field_Resolution_Function_Flag =>
+ return Attr_None;
+ when Field_Wait_State =>
+ return Attr_None;
+ when Field_All_Sensitized_State =>
+ return Attr_None;
+ when Field_Seen_Flag =>
+ return Attr_None;
+ when Field_Pure_Flag =>
+ return Attr_None;
+ when Field_Foreign_Flag =>
+ return Attr_None;
+ when Field_Resolved_Flag =>
+ return Attr_None;
+ when Field_Signal_Type_Flag =>
+ return Attr_None;
+ when Field_Has_Signal_Flag =>
+ return Attr_None;
+ when Field_Purity_State =>
+ return Attr_None;
+ when Field_Elab_Flag =>
+ return Attr_None;
+ when Field_Index_Constraint_Flag =>
+ return Attr_None;
+ when Field_Assertion_Condition =>
+ return Attr_None;
+ when Field_Report_Expression =>
+ return Attr_None;
+ when Field_Severity_Expression =>
+ return Attr_None;
+ when Field_Instantiated_Unit =>
+ return Attr_None;
+ when Field_Generic_Map_Aspect_Chain =>
+ return Attr_Chain;
+ when Field_Port_Map_Aspect_Chain =>
+ return Attr_Chain;
+ when Field_Configuration_Name =>
+ return Attr_None;
+ when Field_Component_Configuration =>
+ return Attr_None;
+ when Field_Configuration_Specification =>
+ return Attr_None;
+ when Field_Default_Binding_Indication =>
+ return Attr_None;
+ when Field_Default_Configuration_Declaration =>
+ return Attr_None;
+ when Field_Expression =>
+ return Attr_None;
+ when Field_Allocator_Designated_Type =>
+ return Attr_Ref;
+ when Field_Selected_Waveform_Chain =>
+ return Attr_Chain;
+ when Field_Conditional_Waveform_Chain =>
+ return Attr_Chain;
+ when Field_Guard_Expression =>
+ return Attr_None;
+ when Field_Guard_Decl =>
+ return Attr_None;
+ when Field_Guard_Sensitivity_List =>
+ return Attr_None;
+ when Field_Block_Block_Configuration =>
+ return Attr_None;
+ when Field_Package_Header =>
+ return Attr_None;
+ when Field_Block_Header =>
+ return Attr_None;
+ when Field_Uninstantiated_Package_Name =>
+ return Attr_None;
+ when Field_Generate_Block_Configuration =>
+ return Attr_None;
+ when Field_Generation_Scheme =>
+ return Attr_None;
+ when Field_Condition =>
+ return Attr_None;
+ when Field_Else_Clause =>
+ return Attr_None;
+ when Field_Parameter_Specification =>
+ return Attr_None;
+ when Field_Parent =>
+ return Attr_Ref;
+ when Field_Loop_Label =>
+ return Attr_None;
+ when Field_Component_Name =>
+ return Attr_None;
+ when Field_Instantiation_List =>
+ return Attr_None;
+ when Field_Entity_Aspect =>
+ return Attr_None;
+ when Field_Default_Entity_Aspect =>
+ return Attr_None;
+ when Field_Default_Generic_Map_Aspect_Chain =>
+ return Attr_Chain;
+ when Field_Default_Port_Map_Aspect_Chain =>
+ return Attr_Chain;
+ when Field_Binding_Indication =>
+ return Attr_None;
+ when Field_Named_Entity =>
+ return Attr_Ref;
+ when Field_Alias_Declaration =>
+ return Attr_None;
+ when Field_Expr_Staticness =>
+ return Attr_None;
+ when Field_Error_Origin =>
+ return Attr_None;
+ when Field_Operand =>
+ return Attr_None;
+ when Field_Left =>
+ return Attr_None;
+ when Field_Right =>
+ return Attr_None;
+ when Field_Unit_Name =>
+ return Attr_None;
+ when Field_Name =>
+ return Attr_None;
+ when Field_Group_Template_Name =>
+ return Attr_None;
+ when Field_Name_Staticness =>
+ return Attr_None;
+ when Field_Prefix =>
+ return Attr_None;
+ when Field_Signature_Prefix =>
+ return Attr_Ref;
+ when Field_Slice_Subtype =>
+ return Attr_None;
+ when Field_Suffix =>
+ return Attr_None;
+ when Field_Index_Subtype =>
+ return Attr_None;
+ when Field_Parameter =>
+ return Attr_None;
+ when Field_Actual_Type =>
+ return Attr_None;
+ when Field_Associated_Interface =>
+ return Attr_Ref;
+ when Field_Association_Chain =>
+ return Attr_Chain;
+ when Field_Individual_Association_Chain =>
+ return Attr_Chain;
+ when Field_Aggregate_Info =>
+ return Attr_None;
+ when Field_Sub_Aggregate_Info =>
+ return Attr_None;
+ when Field_Aggr_Dynamic_Flag =>
+ return Attr_None;
+ when Field_Aggr_Min_Length =>
+ return Attr_None;
+ when Field_Aggr_Low_Limit =>
+ return Attr_None;
+ when Field_Aggr_High_Limit =>
+ return Attr_None;
+ when Field_Aggr_Others_Flag =>
+ return Attr_None;
+ when Field_Aggr_Named_Flag =>
+ return Attr_None;
+ when Field_Value_Staticness =>
+ return Attr_None;
+ when Field_Association_Choices_Chain =>
+ return Attr_Chain;
+ when Field_Case_Statement_Alternative_Chain =>
+ return Attr_Chain;
+ when Field_Choice_Staticness =>
+ return Attr_None;
+ when Field_Procedure_Call =>
+ return Attr_None;
+ when Field_Implementation =>
+ return Attr_Ref;
+ when Field_Parameter_Association_Chain =>
+ return Attr_Chain;
+ when Field_Method_Object =>
+ return Attr_None;
+ when Field_Subtype_Type_Mark =>
+ return Attr_None;
+ when Field_Type_Conversion_Subtype =>
+ return Attr_None;
+ when Field_Type_Mark =>
+ return Attr_None;
+ when Field_File_Type_Mark =>
+ return Attr_None;
+ when Field_Return_Type_Mark =>
+ return Attr_None;
+ when Field_Lexical_Layout =>
+ return Attr_None;
+ when Field_Incomplete_Type_List =>
+ return Attr_None;
+ when Field_Has_Disconnect_Flag =>
+ return Attr_None;
+ when Field_Has_Active_Flag =>
+ return Attr_None;
+ when Field_Is_Within_Flag =>
+ return Attr_None;
+ when Field_Type_Marks_List =>
+ return Attr_None;
+ when Field_Implicit_Alias_Flag =>
+ return Attr_None;
+ when Field_Alias_Signature =>
+ return Attr_None;
+ when Field_Attribute_Signature =>
+ return Attr_None;
+ when Field_Overload_List =>
+ return Attr_Of_Ref;
+ when Field_Simple_Name_Identifier =>
+ return Attr_None;
+ when Field_Simple_Name_Subtype =>
+ return Attr_None;
+ when Field_Protected_Type_Body =>
+ return Attr_None;
+ when Field_Protected_Type_Declaration =>
+ return Attr_None;
+ when Field_End_Location =>
+ return Attr_None;
+ when Field_String_Id =>
+ return Attr_None;
+ when Field_String_Length =>
+ return Attr_None;
+ when Field_Use_Flag =>
+ return Attr_None;
+ when Field_End_Has_Reserved_Id =>
+ return Attr_None;
+ when Field_End_Has_Identifier =>
+ return Attr_None;
+ when Field_End_Has_Postponed =>
+ return Attr_None;
+ when Field_Has_Begin =>
+ return Attr_None;
+ when Field_Has_Is =>
+ return Attr_None;
+ when Field_Has_Pure =>
+ return Attr_None;
+ when Field_Has_Body =>
+ return Attr_None;
+ when Field_Has_Identifier_List =>
+ return Attr_None;
+ when Field_Has_Mode =>
+ return Attr_None;
+ when Field_Is_Ref =>
+ return Attr_None;
+ when Field_Psl_Property =>
+ return Attr_None;
+ when Field_Psl_Declaration =>
+ return Attr_None;
+ when Field_Psl_Expression =>
+ return Attr_None;
+ when Field_Psl_Boolean =>
+ return Attr_None;
+ when Field_PSL_Clock =>
+ return Attr_None;
+ when Field_PSL_NFA =>
+ return Attr_None;
+ end case;
+ end Get_Field_Attribute;
+
+ Fields_Of_Iir : constant Fields_Array :=
+ (
+ -- Iir_Kind_Unused
+ -- Iir_Kind_Error
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Expr_Staticness,
+ Field_Error_Origin,
+ Field_Type,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Design_File
+ Field_Design_File_Directory,
+ Field_Design_File_Filename,
+ Field_Analysis_Time_Stamp,
+ Field_File_Time_Stamp,
+ Field_Elab_Flag,
+ Field_File_Dependence_List,
+ Field_Chain,
+ Field_First_Design_Unit,
+ Field_Library,
+ Field_Last_Design_Unit,
+ -- Iir_Kind_Design_Unit
+ Field_Date,
+ Field_Design_Unit_Source_Line,
+ Field_Design_Unit_Source_Col,
+ Field_Identifier,
+ Field_Design_Unit_Source_Pos,
+ Field_End_Location,
+ Field_Elab_Flag,
+ Field_Date_State,
+ Field_Context_Items,
+ Field_Chain,
+ Field_Library_Unit,
+ Field_Analysis_Checks_List,
+ Field_Design_File,
+ Field_Hash_Chain,
+ Field_Dependence_List,
+ -- Iir_Kind_Library_Clause
+ Field_Identifier,
+ Field_Has_Identifier_List,
+ Field_Library_Declaration,
+ Field_Chain,
+ Field_Parent,
+ -- Iir_Kind_Use_Clause
+ Field_Selected_Name,
+ Field_Chain,
+ Field_Use_Clause_Chain,
+ Field_Parent,
+ -- Iir_Kind_Integer_Literal
+ Field_Value,
+ Field_Expr_Staticness,
+ Field_Literal_Origin,
+ Field_Type,
+ -- Iir_Kind_Floating_Point_Literal
+ Field_Fp_Value,
+ Field_Expr_Staticness,
+ Field_Literal_Origin,
+ Field_Type,
+ -- Iir_Kind_Null_Literal
+ Field_Expr_Staticness,
+ Field_Type,
+ -- Iir_Kind_String_Literal
+ Field_String_Id,
+ Field_String_Length,
+ Field_Expr_Staticness,
+ Field_Literal_Origin,
+ Field_Literal_Subtype,
+ Field_Type,
+ -- Iir_Kind_Physical_Int_Literal
+ Field_Value,
+ Field_Expr_Staticness,
+ Field_Literal_Origin,
+ Field_Unit_Name,
+ Field_Type,
+ -- Iir_Kind_Physical_Fp_Literal
+ Field_Fp_Value,
+ Field_Expr_Staticness,
+ Field_Literal_Origin,
+ Field_Unit_Name,
+ Field_Type,
+ -- Iir_Kind_Bit_String_Literal
+ Field_String_Id,
+ Field_String_Length,
+ Field_Bit_String_Base,
+ Field_Expr_Staticness,
+ Field_Literal_Origin,
+ Field_Literal_Subtype,
+ Field_Bit_String_0,
+ Field_Bit_String_1,
+ Field_Type,
+ -- Iir_Kind_Simple_Aggregate
+ Field_Expr_Staticness,
+ Field_Literal_Origin,
+ Field_Simple_Aggregate_List,
+ Field_Literal_Subtype,
+ Field_Type,
+ -- Iir_Kind_Overflow_Literal
+ Field_Expr_Staticness,
+ Field_Literal_Origin,
+ Field_Type,
+ -- Iir_Kind_Waveform_Element
+ Field_We_Value,
+ Field_Chain,
+ Field_Time,
+ -- Iir_Kind_Conditional_Waveform
+ Field_Condition,
+ Field_Chain,
+ Field_Waveform_Chain,
+ -- Iir_Kind_Association_Element_By_Expression
+ Field_Whole_Association_Flag,
+ Field_Collapse_Signal_Flag,
+ Field_Formal,
+ Field_Chain,
+ Field_Actual,
+ Field_In_Conversion,
+ Field_Out_Conversion,
+ -- Iir_Kind_Association_Element_By_Individual
+ Field_Whole_Association_Flag,
+ Field_Collapse_Signal_Flag,
+ Field_Formal,
+ Field_Chain,
+ Field_Actual_Type,
+ Field_Individual_Association_Chain,
+ -- Iir_Kind_Association_Element_Open
+ Field_Whole_Association_Flag,
+ Field_Collapse_Signal_Flag,
+ Field_Artificial_Flag,
+ Field_Formal,
+ Field_Chain,
+ -- Iir_Kind_Association_Element_Package
+ Field_Whole_Association_Flag,
+ Field_Collapse_Signal_Flag,
+ Field_Formal,
+ Field_Chain,
+ Field_Actual,
+ Field_Associated_Interface,
+ -- Iir_Kind_Choice_By_Others
+ Field_Same_Alternative_Flag,
+ Field_Chain,
+ Field_Associated_Expr,
+ Field_Associated_Chain,
+ Field_Parent,
+ -- Iir_Kind_Choice_By_Expression
+ Field_Same_Alternative_Flag,
+ Field_Choice_Staticness,
+ Field_Chain,
+ Field_Associated_Expr,
+ Field_Associated_Chain,
+ Field_Choice_Expression,
+ Field_Parent,
+ -- Iir_Kind_Choice_By_Range
+ Field_Same_Alternative_Flag,
+ Field_Choice_Staticness,
+ Field_Chain,
+ Field_Associated_Expr,
+ Field_Associated_Chain,
+ Field_Choice_Range,
+ Field_Parent,
+ -- Iir_Kind_Choice_By_None
+ Field_Same_Alternative_Flag,
+ Field_Chain,
+ Field_Associated_Expr,
+ Field_Associated_Chain,
+ Field_Parent,
+ -- Iir_Kind_Choice_By_Name
+ Field_Same_Alternative_Flag,
+ Field_Chain,
+ Field_Associated_Expr,
+ Field_Associated_Chain,
+ Field_Choice_Name,
+ Field_Parent,
+ -- Iir_Kind_Entity_Aspect_Entity
+ Field_Entity_Name,
+ Field_Architecture,
+ -- Iir_Kind_Entity_Aspect_Configuration
+ Field_Configuration_Name,
+ -- Iir_Kind_Entity_Aspect_Open
+ -- Iir_Kind_Block_Configuration
+ Field_Declaration_Chain,
+ Field_Chain,
+ Field_Configuration_Item_Chain,
+ Field_Block_Specification,
+ Field_Parent,
+ Field_Prev_Block_Configuration,
+ -- Iir_Kind_Block_Header
+ Field_Generic_Chain,
+ Field_Port_Chain,
+ Field_Generic_Map_Aspect_Chain,
+ Field_Port_Map_Aspect_Chain,
+ -- Iir_Kind_Component_Configuration
+ Field_Instantiation_List,
+ Field_Chain,
+ Field_Binding_Indication,
+ Field_Component_Name,
+ Field_Block_Configuration,
+ Field_Parent,
+ -- Iir_Kind_Binding_Indication
+ Field_Default_Entity_Aspect,
+ Field_Entity_Aspect,
+ Field_Default_Generic_Map_Aspect_Chain,
+ Field_Default_Port_Map_Aspect_Chain,
+ Field_Generic_Map_Aspect_Chain,
+ Field_Port_Map_Aspect_Chain,
+ -- Iir_Kind_Entity_Class
+ Field_Entity_Class,
+ Field_Chain,
+ -- Iir_Kind_Attribute_Value
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Spec_Chain,
+ Field_Chain,
+ Field_Type,
+ Field_Designated_Entity,
+ Field_Attribute_Specification,
+ Field_Base_Name,
+ -- Iir_Kind_Signature
+ Field_Type_Marks_List,
+ Field_Return_Type_Mark,
+ Field_Signature_Prefix,
+ -- Iir_Kind_Aggregate_Info
+ Field_Aggr_Min_Length,
+ Field_Aggr_Others_Flag,
+ Field_Aggr_Dynamic_Flag,
+ Field_Aggr_Named_Flag,
+ Field_Sub_Aggregate_Info,
+ Field_Aggr_Low_Limit,
+ Field_Aggr_High_Limit,
+ -- Iir_Kind_Procedure_Call
+ Field_Prefix,
+ Field_Parameter_Association_Chain,
+ Field_Method_Object,
+ Field_Implementation,
+ -- Iir_Kind_Record_Element_Constraint
+ Field_Identifier,
+ Field_Element_Position,
+ Field_Visible_Flag,
+ Field_Element_Declaration,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Array_Element_Resolution
+ Field_Resolution_Indication,
+ -- Iir_Kind_Record_Resolution
+ Field_Record_Element_Resolution_Chain,
+ -- Iir_Kind_Record_Element_Resolution
+ Field_Identifier,
+ Field_Chain,
+ Field_Resolution_Indication,
+ -- Iir_Kind_Attribute_Specification
+ Field_Entity_Class,
+ Field_Entity_Name_List,
+ Field_Chain,
+ Field_Attribute_Value_Spec_Chain,
+ Field_Expression,
+ Field_Attribute_Designator,
+ Field_Attribute_Specification_Chain,
+ Field_Parent,
+ -- Iir_Kind_Disconnection_Specification
+ Field_Chain,
+ Field_Signal_List,
+ Field_Type_Mark,
+ Field_Expression,
+ Field_Parent,
+ -- Iir_Kind_Configuration_Specification
+ Field_Instantiation_List,
+ Field_Chain,
+ Field_Binding_Indication,
+ Field_Component_Name,
+ Field_Parent,
+ -- Iir_Kind_Access_Type_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Type_Staticness,
+ Field_Designated_Subtype_Indication,
+ Field_Designated_Type,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Incomplete_Type_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Type_Staticness,
+ Field_Incomplete_Type_List,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_File_Type_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Text_File_Flag,
+ Field_Type_Staticness,
+ Field_File_Type_Mark,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Protected_Type_Declaration
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Type_Staticness,
+ Field_Declaration_Chain,
+ Field_Protected_Type_Body,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Record_Type_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Type_Staticness,
+ Field_Constraint_State,
+ Field_Elements_Declaration_List,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Array_Type_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Index_Constraint_Flag,
+ Field_Type_Staticness,
+ Field_Constraint_State,
+ Field_Element_Subtype_Indication,
+ Field_Index_Subtype_Definition_List,
+ Field_Element_Subtype,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ Field_Index_Subtype_List,
+ -- Iir_Kind_Array_Subtype_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Index_Constraint_Flag,
+ Field_Type_Staticness,
+ Field_Constraint_State,
+ Field_Subtype_Type_Mark,
+ Field_Resolution_Indication,
+ Field_Index_Constraint_List,
+ Field_Tolerance,
+ Field_Array_Element_Constraint,
+ Field_Element_Subtype,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ Field_Index_Subtype_List,
+ -- Iir_Kind_Record_Subtype_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Type_Staticness,
+ Field_Constraint_State,
+ Field_Elements_Declaration_List,
+ Field_Subtype_Type_Mark,
+ Field_Resolution_Indication,
+ Field_Tolerance,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Access_Subtype_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Type_Staticness,
+ Field_Subtype_Type_Mark,
+ Field_Designated_Subtype_Indication,
+ Field_Designated_Type,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Physical_Subtype_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Type_Staticness,
+ Field_Range_Constraint,
+ Field_Subtype_Type_Mark,
+ Field_Resolution_Indication,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Floating_Subtype_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Type_Staticness,
+ Field_Range_Constraint,
+ Field_Subtype_Type_Mark,
+ Field_Resolution_Indication,
+ Field_Tolerance,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Integer_Subtype_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Type_Staticness,
+ Field_Range_Constraint,
+ Field_Subtype_Type_Mark,
+ Field_Resolution_Indication,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Enumeration_Subtype_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Type_Staticness,
+ Field_Range_Constraint,
+ Field_Subtype_Type_Mark,
+ Field_Resolution_Indication,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Enumeration_Type_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Only_Characters_Flag,
+ Field_Type_Staticness,
+ Field_Range_Constraint,
+ Field_Enumeration_Literal_List,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Integer_Type_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Type_Staticness,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Floating_Type_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Type_Staticness,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Physical_Type_Definition
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Type_Staticness,
+ Field_Unit_Chain,
+ Field_Type_Declarator,
+ Field_Base_Type,
+ -- Iir_Kind_Range_Expression
+ Field_Expr_Staticness,
+ Field_Direction,
+ Field_Left_Limit,
+ Field_Right_Limit,
+ Field_Range_Origin,
+ Field_Type,
+ -- Iir_Kind_Protected_Type_Body
+ Field_Identifier,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Declaration_Chain,
+ Field_Chain,
+ Field_Protected_Type_Declaration,
+ Field_Parent,
+ -- Iir_Kind_Subtype_Definition
+ Field_Range_Constraint,
+ Field_Subtype_Type_Mark,
+ Field_Resolution_Indication,
+ Field_Tolerance,
+ -- Iir_Kind_Scalar_Nature_Definition
+ Field_Reference,
+ Field_Nature_Declarator,
+ Field_Across_Type,
+ Field_Through_Type,
+ -- Iir_Kind_Overload_List
+ Field_Overload_List,
+ -- Iir_Kind_Type_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Type_Definition,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Parent,
+ -- Iir_Kind_Anonymous_Type_Declaration
+ Field_Identifier,
+ Field_Type_Definition,
+ Field_Chain,
+ Field_Subtype_Definition,
+ Field_Parent,
+ -- Iir_Kind_Subtype_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Is_Ref,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Subtype_Indication,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Nature_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Nature,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Parent,
+ -- Iir_Kind_Subnature_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Nature,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Parent,
+ -- Iir_Kind_Package_Declaration
+ Field_Identifier,
+ Field_Need_Body,
+ Field_Visible_Flag,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Declaration_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Package_Header,
+ Field_Parent,
+ Field_Package_Body,
+ -- Iir_Kind_Package_Instantiation_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Declaration_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Uninstantiated_Package_Name,
+ Field_Generic_Chain,
+ Field_Generic_Map_Aspect_Chain,
+ Field_Parent,
+ Field_Package_Body,
+ -- Iir_Kind_Package_Body
+ Field_Identifier,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Declaration_Chain,
+ Field_Parent,
+ Field_Package,
+ -- Iir_Kind_Configuration_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Declaration_Chain,
+ Field_Entity_Name,
+ Field_Attribute_Value_Chain,
+ Field_Block_Configuration,
+ Field_Parent,
+ -- Iir_Kind_Entity_Declaration
+ Field_Identifier,
+ Field_Has_Begin,
+ Field_Visible_Flag,
+ Field_Is_Within_Flag,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Declaration_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Concurrent_Statement_Chain,
+ Field_Generic_Chain,
+ Field_Port_Chain,
+ Field_Parent,
+ -- Iir_Kind_Architecture_Body
+ Field_Identifier,
+ Field_Foreign_Flag,
+ Field_Visible_Flag,
+ Field_Is_Within_Flag,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Declaration_Chain,
+ Field_Entity_Name,
+ Field_Attribute_Value_Chain,
+ Field_Concurrent_Statement_Chain,
+ Field_Default_Configuration_Declaration,
+ Field_Parent,
+ -- Iir_Kind_Package_Header
+ Field_Generic_Chain,
+ Field_Generic_Map_Aspect_Chain,
+ -- Iir_Kind_Unit_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Physical_Literal,
+ Field_Physical_Unit_Value,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Library_Declaration
+ Field_Date,
+ Field_Library_Directory,
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Design_File_Chain,
+ Field_Chain,
+ -- Iir_Kind_Component_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Has_Is,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Generic_Chain,
+ Field_Port_Chain,
+ Field_Parent,
+ -- Iir_Kind_Attribute_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Chain,
+ Field_Type_Mark,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Group_Template_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Entity_Class_Entry_Chain,
+ Field_Chain,
+ Field_Parent,
+ -- Iir_Kind_Group_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Group_Constituent_List,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Group_Template_Name,
+ Field_Parent,
+ -- Iir_Kind_Element_Declaration
+ Field_Identifier,
+ Field_Element_Position,
+ Field_Has_Identifier_List,
+ Field_Visible_Flag,
+ Field_Is_Ref,
+ Field_Subtype_Indication,
+ Field_Type,
+ -- Iir_Kind_Non_Object_Alias_Declaration
+ Field_Identifier,
+ Field_Implicit_Alias_Flag,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Chain,
+ Field_Name,
+ Field_Alias_Signature,
+ Field_Parent,
+ -- Iir_Kind_Psl_Declaration
+ Field_Psl_Declaration,
+ Field_Identifier,
+ Field_PSL_Clock,
+ Field_PSL_NFA,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Chain,
+ Field_Parent,
+ -- Iir_Kind_Terminal_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Nature,
+ Field_Chain,
+ Field_Parent,
+ -- Iir_Kind_Free_Quantity_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Default_Value,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Across_Quantity_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Tolerance,
+ Field_Plus_Terminal,
+ Field_Minus_Terminal,
+ Field_Default_Value,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Through_Quantity_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Tolerance,
+ Field_Plus_Terminal,
+ Field_Minus_Terminal,
+ Field_Default_Value,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Enumeration_Literal
+ Field_Enum_Pos,
+ Field_Subprogram_Hash,
+ Field_Identifier,
+ Field_Seen_Flag,
+ Field_Visible_Flag,
+ Field_Is_Within_Flag,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Literal_Origin,
+ Field_Attribute_Value_Chain,
+ Field_Parent,
+ Field_Type,
+ Field_Enumeration_Decl,
+ -- Iir_Kind_Function_Declaration
+ Field_Subprogram_Depth,
+ Field_Subprogram_Hash,
+ Field_Overload_Number,
+ Field_Identifier,
+ Field_Seen_Flag,
+ Field_Pure_Flag,
+ Field_Foreign_Flag,
+ Field_Visible_Flag,
+ Field_Is_Within_Flag,
+ Field_Use_Flag,
+ Field_Resolution_Function_Flag,
+ Field_Has_Pure,
+ Field_Has_Body,
+ Field_Wait_State,
+ Field_All_Sensitized_State,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Interface_Declaration_Chain,
+ Field_Generic_Chain,
+ Field_Return_Type_Mark,
+ Field_Parent,
+ Field_Return_Type,
+ Field_Subprogram_Body,
+ -- Iir_Kind_Implicit_Function_Declaration
+ Field_Subprogram_Hash,
+ Field_Overload_Number,
+ Field_Identifier,
+ Field_Implicit_Definition,
+ Field_Seen_Flag,
+ Field_Pure_Flag,
+ Field_Visible_Flag,
+ Field_Is_Within_Flag,
+ Field_Use_Flag,
+ Field_Wait_State,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Interface_Declaration_Chain,
+ Field_Generic_Chain,
+ Field_Generic_Map_Aspect_Chain,
+ Field_Parent,
+ Field_Return_Type,
+ Field_Type_Reference,
+ -- Iir_Kind_Implicit_Procedure_Declaration
+ Field_Subprogram_Hash,
+ Field_Overload_Number,
+ Field_Identifier,
+ Field_Implicit_Definition,
+ Field_Seen_Flag,
+ Field_Visible_Flag,
+ Field_Is_Within_Flag,
+ Field_Use_Flag,
+ Field_Wait_State,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Interface_Declaration_Chain,
+ Field_Generic_Chain,
+ Field_Generic_Map_Aspect_Chain,
+ Field_Parent,
+ Field_Type_Reference,
+ -- Iir_Kind_Procedure_Declaration
+ Field_Subprogram_Depth,
+ Field_Subprogram_Hash,
+ Field_Overload_Number,
+ Field_Identifier,
+ Field_Seen_Flag,
+ Field_Passive_Flag,
+ Field_Foreign_Flag,
+ Field_Visible_Flag,
+ Field_Is_Within_Flag,
+ Field_Use_Flag,
+ Field_Has_Body,
+ Field_Wait_State,
+ Field_Purity_State,
+ Field_All_Sensitized_State,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Interface_Declaration_Chain,
+ Field_Generic_Chain,
+ Field_Return_Type_Mark,
+ Field_Parent,
+ Field_Subprogram_Body,
+ -- Iir_Kind_Function_Body
+ Field_Impure_Depth,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Declaration_Chain,
+ Field_Chain,
+ Field_Sequential_Statement_Chain,
+ Field_Parent,
+ Field_Subprogram_Specification,
+ Field_Callees_List,
+ -- Iir_Kind_Procedure_Body
+ Field_Impure_Depth,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Declaration_Chain,
+ Field_Chain,
+ Field_Sequential_Statement_Chain,
+ Field_Parent,
+ Field_Subprogram_Specification,
+ Field_Callees_List,
+ -- Iir_Kind_Object_Alias_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_After_Drivers_Flag,
+ Field_Use_Flag,
+ Field_Is_Ref,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Name,
+ Field_Subtype_Indication,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_File_Declaration
+ Field_Identifier,
+ Field_Has_Identifier_List,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Is_Ref,
+ Field_Has_Mode,
+ Field_Mode,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_File_Logical_Name,
+ Field_File_Open_Kind,
+ Field_Subtype_Indication,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Guard_Signal_Declaration
+ Field_Identifier,
+ Field_Has_Active_Flag,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Signal_Kind,
+ Field_Guard_Expression,
+ Field_Attribute_Value_Chain,
+ Field_Guard_Sensitivity_List,
+ Field_Block_Statement,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Signal_Declaration
+ Field_Identifier,
+ Field_Has_Disconnect_Flag,
+ Field_Has_Active_Flag,
+ Field_Has_Identifier_List,
+ Field_Visible_Flag,
+ Field_After_Drivers_Flag,
+ Field_Use_Flag,
+ Field_Is_Ref,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Signal_Kind,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Signal_Driver,
+ Field_Subtype_Indication,
+ Field_Default_Value,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Variable_Declaration
+ Field_Identifier,
+ Field_Shared_Flag,
+ Field_Has_Identifier_List,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Is_Ref,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Subtype_Indication,
+ Field_Default_Value,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Constant_Declaration
+ Field_Identifier,
+ Field_Deferred_Declaration_Flag,
+ Field_Has_Identifier_List,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Is_Ref,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Deferred_Declaration,
+ Field_Subtype_Indication,
+ Field_Default_Value,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Iterator_Declaration
+ Field_Identifier,
+ Field_Has_Identifier_List,
+ Field_Visible_Flag,
+ Field_Use_Flag,
+ Field_Is_Ref,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Discrete_Range,
+ Field_Subtype_Indication,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Interface_Constant_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_After_Drivers_Flag,
+ Field_Use_Flag,
+ Field_Is_Ref,
+ Field_Mode,
+ Field_Lexical_Layout,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Subtype_Indication,
+ Field_Default_Value,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Interface_Variable_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_After_Drivers_Flag,
+ Field_Use_Flag,
+ Field_Is_Ref,
+ Field_Mode,
+ Field_Lexical_Layout,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Subtype_Indication,
+ Field_Default_Value,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Interface_Signal_Declaration
+ Field_Identifier,
+ Field_Has_Disconnect_Flag,
+ Field_Has_Active_Flag,
+ Field_Open_Flag,
+ Field_Visible_Flag,
+ Field_After_Drivers_Flag,
+ Field_Use_Flag,
+ Field_Is_Ref,
+ Field_Mode,
+ Field_Lexical_Layout,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Signal_Kind,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Subtype_Indication,
+ Field_Default_Value,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Interface_File_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_After_Drivers_Flag,
+ Field_Use_Flag,
+ Field_Is_Ref,
+ Field_Mode,
+ Field_Lexical_Layout,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Subtype_Indication,
+ Field_Default_Value,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_Interface_Package_Declaration
+ Field_Identifier,
+ Field_Visible_Flag,
+ Field_Declaration_Chain,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Uninstantiated_Package_Name,
+ Field_Generic_Chain,
+ Field_Generic_Map_Aspect_Chain,
+ Field_Parent,
+ -- Iir_Kind_Identity_Operator
+ Field_Expr_Staticness,
+ Field_Operand,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Negation_Operator
+ Field_Expr_Staticness,
+ Field_Operand,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Absolute_Operator
+ Field_Expr_Staticness,
+ Field_Operand,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Not_Operator
+ Field_Expr_Staticness,
+ Field_Operand,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Condition_Operator
+ Field_Expr_Staticness,
+ Field_Operand,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Reduction_And_Operator
+ Field_Expr_Staticness,
+ Field_Operand,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Reduction_Or_Operator
+ Field_Expr_Staticness,
+ Field_Operand,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Reduction_Nand_Operator
+ Field_Expr_Staticness,
+ Field_Operand,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Reduction_Nor_Operator
+ Field_Expr_Staticness,
+ Field_Operand,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Reduction_Xor_Operator
+ Field_Expr_Staticness,
+ Field_Operand,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Reduction_Xnor_Operator
+ Field_Expr_Staticness,
+ Field_Operand,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_And_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Or_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Nand_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Nor_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Xor_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Xnor_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Equality_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Inequality_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Less_Than_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Less_Than_Or_Equal_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Greater_Than_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Greater_Than_Or_Equal_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Match_Equality_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Match_Inequality_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Match_Less_Than_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Match_Less_Than_Or_Equal_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Match_Greater_Than_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Match_Greater_Than_Or_Equal_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Sll_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Sla_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Srl_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Sra_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Rol_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Ror_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Addition_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Substraction_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Concatenation_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Multiplication_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Division_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Modulus_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Remainder_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Exponentiation_Operator
+ Field_Expr_Staticness,
+ Field_Left,
+ Field_Right,
+ Field_Type,
+ Field_Implementation,
+ -- Iir_Kind_Function_Call
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Parameter_Association_Chain,
+ Field_Method_Object,
+ Field_Type,
+ Field_Implementation,
+ Field_Base_Name,
+ -- Iir_Kind_Aggregate
+ Field_Expr_Staticness,
+ Field_Value_Staticness,
+ Field_Aggregate_Info,
+ Field_Association_Choices_Chain,
+ Field_Literal_Subtype,
+ Field_Type,
+ -- Iir_Kind_Parenthesis_Expression
+ Field_Expr_Staticness,
+ Field_Expression,
+ Field_Type,
+ -- Iir_Kind_Qualified_Expression
+ Field_Expr_Staticness,
+ Field_Type_Mark,
+ Field_Expression,
+ Field_Type,
+ -- Iir_Kind_Type_Conversion
+ Field_Expr_Staticness,
+ Field_Type_Conversion_Subtype,
+ Field_Type_Mark,
+ Field_Expression,
+ Field_Type,
+ -- Iir_Kind_Allocator_By_Expression
+ Field_Expr_Staticness,
+ Field_Expression,
+ Field_Type,
+ Field_Allocator_Designated_Type,
+ -- Iir_Kind_Allocator_By_Subtype
+ Field_Expr_Staticness,
+ Field_Subtype_Indication,
+ Field_Type,
+ Field_Allocator_Designated_Type,
+ -- Iir_Kind_Selected_Element
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ Field_Selected_Element,
+ Field_Base_Name,
+ -- Iir_Kind_Dereference
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Implicit_Dereference
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Slice_Name
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Suffix,
+ Field_Slice_Subtype,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Indexed_Name
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Index_List,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Psl_Expression
+ Field_Psl_Expression,
+ Field_Type,
+ -- Iir_Kind_Sensitized_Process_Statement
+ Field_Label,
+ Field_Seen_Flag,
+ Field_End_Has_Postponed,
+ Field_Passive_Flag,
+ Field_Postponed_Flag,
+ Field_Visible_Flag,
+ Field_Is_Within_Flag,
+ Field_Has_Is,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Wait_State,
+ Field_Declaration_Chain,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Sequential_Statement_Chain,
+ Field_Sensitivity_List,
+ Field_Process_Origin,
+ Field_Parent,
+ Field_Callees_List,
+ -- Iir_Kind_Process_Statement
+ Field_Label,
+ Field_Seen_Flag,
+ Field_End_Has_Postponed,
+ Field_Passive_Flag,
+ Field_Postponed_Flag,
+ Field_Visible_Flag,
+ Field_Is_Within_Flag,
+ Field_Has_Is,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Wait_State,
+ Field_Declaration_Chain,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Sequential_Statement_Chain,
+ Field_Process_Origin,
+ Field_Parent,
+ Field_Callees_List,
+ -- Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ Field_Delay_Mechanism,
+ Field_Label,
+ Field_Postponed_Flag,
+ Field_Visible_Flag,
+ Field_Guarded_Target_State,
+ Field_Target,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Reject_Time_Expression,
+ Field_Conditional_Waveform_Chain,
+ Field_Guard,
+ Field_Parent,
+ -- Iir_Kind_Concurrent_Selected_Signal_Assignment
+ Field_Delay_Mechanism,
+ Field_Label,
+ Field_Postponed_Flag,
+ Field_Visible_Flag,
+ Field_Guarded_Target_State,
+ Field_Target,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Expression,
+ Field_Reject_Time_Expression,
+ Field_Selected_Waveform_Chain,
+ Field_Guard,
+ Field_Parent,
+ -- Iir_Kind_Concurrent_Assertion_Statement
+ Field_Label,
+ Field_Postponed_Flag,
+ Field_Visible_Flag,
+ Field_Assertion_Condition,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Severity_Expression,
+ Field_Report_Expression,
+ Field_Parent,
+ -- Iir_Kind_Psl_Default_Clock
+ Field_Psl_Boolean,
+ Field_Label,
+ Field_Chain,
+ Field_Parent,
+ -- Iir_Kind_Psl_Assert_Statement
+ Field_Psl_Property,
+ Field_Label,
+ Field_PSL_Clock,
+ Field_PSL_NFA,
+ Field_Visible_Flag,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Severity_Expression,
+ Field_Report_Expression,
+ Field_Parent,
+ -- Iir_Kind_Psl_Cover_Statement
+ Field_Psl_Property,
+ Field_Label,
+ Field_PSL_Clock,
+ Field_PSL_NFA,
+ Field_Visible_Flag,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Severity_Expression,
+ Field_Report_Expression,
+ Field_Parent,
+ -- Iir_Kind_Concurrent_Procedure_Call_Statement
+ Field_Label,
+ Field_Postponed_Flag,
+ Field_Visible_Flag,
+ Field_Procedure_Call,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Parent,
+ -- Iir_Kind_Block_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Is_Within_Flag,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Declaration_Chain,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Concurrent_Statement_Chain,
+ Field_Block_Block_Configuration,
+ Field_Block_Header,
+ Field_Guard_Decl,
+ Field_Parent,
+ -- Iir_Kind_Generate_Statement
+ Field_Label,
+ Field_Has_Begin,
+ Field_Visible_Flag,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_Declaration_Chain,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Concurrent_Statement_Chain,
+ Field_Generation_Scheme,
+ Field_Generate_Block_Configuration,
+ Field_Parent,
+ -- Iir_Kind_Component_Instantiation_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Instantiated_Unit,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Default_Binding_Indication,
+ Field_Component_Configuration,
+ Field_Configuration_Specification,
+ Field_Generic_Map_Aspect_Chain,
+ Field_Port_Map_Aspect_Chain,
+ Field_Parent,
+ -- Iir_Kind_Simple_Simultaneous_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Simultaneous_Left,
+ Field_Simultaneous_Right,
+ Field_Tolerance,
+ Field_Parent,
+ -- Iir_Kind_Signal_Assignment_Statement
+ Field_Delay_Mechanism,
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Guarded_Target_State,
+ Field_Target,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Waveform_Chain,
+ Field_Reject_Time_Expression,
+ Field_Parent,
+ -- Iir_Kind_Null_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Parent,
+ -- Iir_Kind_Assertion_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Assertion_Condition,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Severity_Expression,
+ Field_Report_Expression,
+ Field_Parent,
+ -- Iir_Kind_Report_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Severity_Expression,
+ Field_Report_Expression,
+ Field_Parent,
+ -- Iir_Kind_Wait_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Timeout_Clause,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Condition_Clause,
+ Field_Sensitivity_List,
+ Field_Parent,
+ -- Iir_Kind_Variable_Assignment_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Target,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Expression,
+ Field_Parent,
+ -- Iir_Kind_Return_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Expression,
+ Field_Parent,
+ Field_Type,
+ -- Iir_Kind_For_Loop_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Is_Within_Flag,
+ Field_End_Has_Identifier,
+ Field_Parameter_Specification,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Sequential_Statement_Chain,
+ Field_Parent,
+ -- Iir_Kind_While_Loop_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_End_Has_Identifier,
+ Field_Condition,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Sequential_Statement_Chain,
+ Field_Parent,
+ -- Iir_Kind_Next_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Condition,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Loop_Label,
+ Field_Parent,
+ -- Iir_Kind_Exit_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Condition,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Loop_Label,
+ Field_Parent,
+ -- Iir_Kind_Case_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_End_Has_Identifier,
+ Field_Case_Statement_Alternative_Chain,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Expression,
+ Field_Parent,
+ -- Iir_Kind_Procedure_Call_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Procedure_Call,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Parent,
+ -- Iir_Kind_If_Statement
+ Field_Label,
+ Field_Visible_Flag,
+ Field_End_Has_Identifier,
+ Field_Condition,
+ Field_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Sequential_Statement_Chain,
+ Field_Else_Clause,
+ Field_Parent,
+ -- Iir_Kind_Elsif
+ Field_End_Has_Identifier,
+ Field_Condition,
+ Field_Sequential_Statement_Chain,
+ Field_Else_Clause,
+ Field_Parent,
+ -- Iir_Kind_Character_Literal
+ Field_Identifier,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Alias_Declaration,
+ Field_Type,
+ Field_Named_Entity,
+ Field_Base_Name,
+ -- Iir_Kind_Simple_Name
+ Field_Identifier,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Alias_Declaration,
+ Field_Type,
+ Field_Named_Entity,
+ Field_Base_Name,
+ -- Iir_Kind_Selected_Name
+ Field_Identifier,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Alias_Declaration,
+ Field_Type,
+ Field_Named_Entity,
+ Field_Base_Name,
+ -- Iir_Kind_Operator_Symbol
+ Field_Identifier,
+ Field_Alias_Declaration,
+ Field_Type,
+ Field_Named_Entity,
+ Field_Base_Name,
+ -- Iir_Kind_Selected_By_All_Name
+ Field_Expr_Staticness,
+ Field_Prefix,
+ Field_Type,
+ Field_Named_Entity,
+ Field_Base_Name,
+ -- Iir_Kind_Parenthesis_Name
+ Field_Prefix,
+ Field_Association_Chain,
+ Field_Type,
+ Field_Named_Entity,
+ -- Iir_Kind_Base_Attribute
+ Field_Prefix,
+ Field_Type,
+ -- Iir_Kind_Left_Type_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Right_Type_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_High_Type_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Low_Type_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Ascending_Type_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Image_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Value_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Pos_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Val_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Succ_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Pred_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Leftof_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Rightof_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Delayed_Attribute
+ Field_Has_Active_Flag,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Chain,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Stable_Attribute
+ Field_Has_Active_Flag,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Chain,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Quiet_Attribute
+ Field_Has_Active_Flag,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Chain,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Transaction_Attribute
+ Field_Has_Active_Flag,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Chain,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Event_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ -- Iir_Kind_Active_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ -- Iir_Kind_Last_Event_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ -- Iir_Kind_Last_Active_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ -- Iir_Kind_Last_Value_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ -- Iir_Kind_Driving_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ -- Iir_Kind_Driving_Value_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ -- Iir_Kind_Behavior_Attribute
+ -- Iir_Kind_Structure_Attribute
+ -- Iir_Kind_Simple_Name_Attribute
+ Field_Simple_Name_Identifier,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Simple_Name_Subtype,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Instance_Name_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Path_Name_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Left_Array_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Index_Subtype,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Right_Array_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Index_Subtype,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_High_Array_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Index_Subtype,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Low_Array_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Index_Subtype,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Length_Array_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Index_Subtype,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Ascending_Array_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Index_Subtype,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Range_Array_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Index_Subtype,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Reverse_Range_Array_Attribute
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Index_Subtype,
+ Field_Parameter,
+ Field_Type,
+ Field_Base_Name,
+ -- Iir_Kind_Attribute_Name
+ Field_Identifier,
+ Field_Expr_Staticness,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Attribute_Signature,
+ Field_Type,
+ Field_Named_Entity,
+ Field_Base_Name
+ );
+
+ Fields_Of_Iir_Last : constant array (Iir_Kind) of Integer :=
+ (
+ Iir_Kind_Unused => -1,
+ Iir_Kind_Error => 7,
+ Iir_Kind_Design_File => 17,
+ Iir_Kind_Design_Unit => 32,
+ Iir_Kind_Library_Clause => 37,
+ Iir_Kind_Use_Clause => 41,
+ Iir_Kind_Integer_Literal => 45,
+ Iir_Kind_Floating_Point_Literal => 49,
+ Iir_Kind_Null_Literal => 51,
+ Iir_Kind_String_Literal => 57,
+ Iir_Kind_Physical_Int_Literal => 62,
+ Iir_Kind_Physical_Fp_Literal => 67,
+ Iir_Kind_Bit_String_Literal => 76,
+ Iir_Kind_Simple_Aggregate => 81,
+ Iir_Kind_Overflow_Literal => 84,
+ Iir_Kind_Waveform_Element => 87,
+ Iir_Kind_Conditional_Waveform => 90,
+ Iir_Kind_Association_Element_By_Expression => 97,
+ Iir_Kind_Association_Element_By_Individual => 103,
+ Iir_Kind_Association_Element_Open => 108,
+ Iir_Kind_Association_Element_Package => 114,
+ Iir_Kind_Choice_By_Others => 119,
+ Iir_Kind_Choice_By_Expression => 126,
+ Iir_Kind_Choice_By_Range => 133,
+ Iir_Kind_Choice_By_None => 138,
+ Iir_Kind_Choice_By_Name => 144,
+ Iir_Kind_Entity_Aspect_Entity => 146,
+ Iir_Kind_Entity_Aspect_Configuration => 147,
+ Iir_Kind_Entity_Aspect_Open => 147,
+ Iir_Kind_Block_Configuration => 153,
+ Iir_Kind_Block_Header => 157,
+ Iir_Kind_Component_Configuration => 163,
+ Iir_Kind_Binding_Indication => 169,
+ Iir_Kind_Entity_Class => 171,
+ Iir_Kind_Attribute_Value => 179,
+ Iir_Kind_Signature => 182,
+ Iir_Kind_Aggregate_Info => 189,
+ Iir_Kind_Procedure_Call => 193,
+ Iir_Kind_Record_Element_Constraint => 199,
+ Iir_Kind_Array_Element_Resolution => 200,
+ Iir_Kind_Record_Resolution => 201,
+ Iir_Kind_Record_Element_Resolution => 204,
+ Iir_Kind_Attribute_Specification => 212,
+ Iir_Kind_Disconnection_Specification => 217,
+ Iir_Kind_Configuration_Specification => 222,
+ Iir_Kind_Access_Type_Definition => 229,
+ Iir_Kind_Incomplete_Type_Definition => 236,
+ Iir_Kind_File_Type_Definition => 243,
+ Iir_Kind_Protected_Type_Declaration => 252,
+ Iir_Kind_Record_Type_Definition => 262,
+ Iir_Kind_Array_Type_Definition => 274,
+ Iir_Kind_Array_Subtype_Definition => 289,
+ Iir_Kind_Record_Subtype_Definition => 300,
+ Iir_Kind_Access_Subtype_Definition => 308,
+ Iir_Kind_Physical_Subtype_Definition => 317,
+ Iir_Kind_Floating_Subtype_Definition => 327,
+ Iir_Kind_Integer_Subtype_Definition => 336,
+ Iir_Kind_Enumeration_Subtype_Definition => 345,
+ Iir_Kind_Enumeration_Type_Definition => 354,
+ Iir_Kind_Integer_Type_Definition => 360,
+ Iir_Kind_Floating_Type_Definition => 366,
+ Iir_Kind_Physical_Type_Definition => 375,
+ Iir_Kind_Range_Expression => 381,
+ Iir_Kind_Protected_Type_Body => 388,
+ Iir_Kind_Subtype_Definition => 392,
+ Iir_Kind_Scalar_Nature_Definition => 396,
+ Iir_Kind_Overload_List => 397,
+ Iir_Kind_Type_Declaration => 404,
+ Iir_Kind_Anonymous_Type_Declaration => 409,
+ Iir_Kind_Subtype_Declaration => 418,
+ Iir_Kind_Nature_Declaration => 425,
+ Iir_Kind_Subnature_Declaration => 432,
+ Iir_Kind_Package_Declaration => 442,
+ Iir_Kind_Package_Instantiation_Declaration => 453,
+ Iir_Kind_Package_Body => 459,
+ Iir_Kind_Configuration_Declaration => 468,
+ Iir_Kind_Entity_Declaration => 480,
+ Iir_Kind_Architecture_Body => 492,
+ Iir_Kind_Package_Header => 494,
+ Iir_Kind_Unit_Declaration => 504,
+ Iir_Kind_Library_Declaration => 510,
+ Iir_Kind_Component_Declaration => 521,
+ Iir_Kind_Attribute_Declaration => 528,
+ Iir_Kind_Group_Template_Declaration => 534,
+ Iir_Kind_Group_Declaration => 542,
+ Iir_Kind_Element_Declaration => 549,
+ Iir_Kind_Non_Object_Alias_Declaration => 557,
+ Iir_Kind_Psl_Declaration => 565,
+ Iir_Kind_Terminal_Declaration => 571,
+ Iir_Kind_Free_Quantity_Declaration => 581,
+ Iir_Kind_Across_Quantity_Declaration => 594,
+ Iir_Kind_Through_Quantity_Declaration => 607,
+ Iir_Kind_Enumeration_Literal => 620,
+ Iir_Kind_Function_Declaration => 643,
+ Iir_Kind_Implicit_Function_Declaration => 661,
+ Iir_Kind_Implicit_Procedure_Declaration => 677,
+ Iir_Kind_Procedure_Declaration => 698,
+ Iir_Kind_Function_Body => 707,
+ Iir_Kind_Procedure_Body => 716,
+ Iir_Kind_Object_Alias_Declaration => 728,
+ Iir_Kind_File_Declaration => 744,
+ Iir_Kind_Guard_Signal_Declaration => 757,
+ Iir_Kind_Signal_Declaration => 775,
+ Iir_Kind_Variable_Declaration => 789,
+ Iir_Kind_Constant_Declaration => 804,
+ Iir_Kind_Iterator_Declaration => 817,
+ Iir_Kind_Interface_Constant_Declaration => 832,
+ Iir_Kind_Interface_Variable_Declaration => 847,
+ Iir_Kind_Interface_Signal_Declaration => 866,
+ Iir_Kind_Interface_File_Declaration => 881,
+ Iir_Kind_Interface_Package_Declaration => 890,
+ Iir_Kind_Identity_Operator => 894,
+ Iir_Kind_Negation_Operator => 898,
+ Iir_Kind_Absolute_Operator => 902,
+ Iir_Kind_Not_Operator => 906,
+ Iir_Kind_Condition_Operator => 910,
+ Iir_Kind_Reduction_And_Operator => 914,
+ Iir_Kind_Reduction_Or_Operator => 918,
+ Iir_Kind_Reduction_Nand_Operator => 922,
+ Iir_Kind_Reduction_Nor_Operator => 926,
+ Iir_Kind_Reduction_Xor_Operator => 930,
+ Iir_Kind_Reduction_Xnor_Operator => 934,
+ Iir_Kind_And_Operator => 939,
+ Iir_Kind_Or_Operator => 944,
+ Iir_Kind_Nand_Operator => 949,
+ Iir_Kind_Nor_Operator => 954,
+ Iir_Kind_Xor_Operator => 959,
+ Iir_Kind_Xnor_Operator => 964,
+ Iir_Kind_Equality_Operator => 969,
+ Iir_Kind_Inequality_Operator => 974,
+ Iir_Kind_Less_Than_Operator => 979,
+ Iir_Kind_Less_Than_Or_Equal_Operator => 984,
+ Iir_Kind_Greater_Than_Operator => 989,
+ Iir_Kind_Greater_Than_Or_Equal_Operator => 994,
+ Iir_Kind_Match_Equality_Operator => 999,
+ Iir_Kind_Match_Inequality_Operator => 1004,
+ Iir_Kind_Match_Less_Than_Operator => 1009,
+ Iir_Kind_Match_Less_Than_Or_Equal_Operator => 1014,
+ Iir_Kind_Match_Greater_Than_Operator => 1019,
+ Iir_Kind_Match_Greater_Than_Or_Equal_Operator => 1024,
+ Iir_Kind_Sll_Operator => 1029,
+ Iir_Kind_Sla_Operator => 1034,
+ Iir_Kind_Srl_Operator => 1039,
+ Iir_Kind_Sra_Operator => 1044,
+ Iir_Kind_Rol_Operator => 1049,
+ Iir_Kind_Ror_Operator => 1054,
+ Iir_Kind_Addition_Operator => 1059,
+ Iir_Kind_Substraction_Operator => 1064,
+ Iir_Kind_Concatenation_Operator => 1069,
+ Iir_Kind_Multiplication_Operator => 1074,
+ Iir_Kind_Division_Operator => 1079,
+ Iir_Kind_Modulus_Operator => 1084,
+ Iir_Kind_Remainder_Operator => 1089,
+ Iir_Kind_Exponentiation_Operator => 1094,
+ Iir_Kind_Function_Call => 1102,
+ Iir_Kind_Aggregate => 1108,
+ Iir_Kind_Parenthesis_Expression => 1111,
+ Iir_Kind_Qualified_Expression => 1115,
+ Iir_Kind_Type_Conversion => 1120,
+ Iir_Kind_Allocator_By_Expression => 1124,
+ Iir_Kind_Allocator_By_Subtype => 1128,
+ Iir_Kind_Selected_Element => 1134,
+ Iir_Kind_Dereference => 1139,
+ Iir_Kind_Implicit_Dereference => 1144,
+ Iir_Kind_Slice_Name => 1151,
+ Iir_Kind_Indexed_Name => 1157,
+ Iir_Kind_Psl_Expression => 1159,
+ Iir_Kind_Sensitized_Process_Statement => 1178,
+ Iir_Kind_Process_Statement => 1196,
+ Iir_Kind_Concurrent_Conditional_Signal_Assignment => 1208,
+ Iir_Kind_Concurrent_Selected_Signal_Assignment => 1221,
+ Iir_Kind_Concurrent_Assertion_Statement => 1230,
+ Iir_Kind_Psl_Default_Clock => 1234,
+ Iir_Kind_Psl_Assert_Statement => 1244,
+ Iir_Kind_Psl_Cover_Statement => 1254,
+ Iir_Kind_Concurrent_Procedure_Call_Statement => 1261,
+ Iir_Kind_Block_Statement => 1274,
+ Iir_Kind_Generate_Statement => 1286,
+ Iir_Kind_Component_Instantiation_Statement => 1297,
+ Iir_Kind_Simple_Simultaneous_Statement => 1305,
+ Iir_Kind_Signal_Assignment_Statement => 1315,
+ Iir_Kind_Null_Statement => 1320,
+ Iir_Kind_Assertion_Statement => 1328,
+ Iir_Kind_Report_Statement => 1335,
+ Iir_Kind_Wait_Statement => 1343,
+ Iir_Kind_Variable_Assignment_Statement => 1350,
+ Iir_Kind_Return_Statement => 1357,
+ Iir_Kind_For_Loop_Statement => 1366,
+ Iir_Kind_While_Loop_Statement => 1374,
+ Iir_Kind_Next_Statement => 1381,
+ Iir_Kind_Exit_Statement => 1388,
+ Iir_Kind_Case_Statement => 1396,
+ Iir_Kind_Procedure_Call_Statement => 1402,
+ Iir_Kind_If_Statement => 1411,
+ Iir_Kind_Elsif => 1416,
+ Iir_Kind_Character_Literal => 1423,
+ Iir_Kind_Simple_Name => 1430,
+ Iir_Kind_Selected_Name => 1438,
+ Iir_Kind_Operator_Symbol => 1443,
+ Iir_Kind_Selected_By_All_Name => 1448,
+ Iir_Kind_Parenthesis_Name => 1452,
+ Iir_Kind_Base_Attribute => 1454,
+ Iir_Kind_Left_Type_Attribute => 1459,
+ Iir_Kind_Right_Type_Attribute => 1464,
+ Iir_Kind_High_Type_Attribute => 1469,
+ Iir_Kind_Low_Type_Attribute => 1474,
+ Iir_Kind_Ascending_Type_Attribute => 1479,
+ Iir_Kind_Image_Attribute => 1485,
+ Iir_Kind_Value_Attribute => 1491,
+ Iir_Kind_Pos_Attribute => 1497,
+ Iir_Kind_Val_Attribute => 1503,
+ Iir_Kind_Succ_Attribute => 1509,
+ Iir_Kind_Pred_Attribute => 1515,
+ Iir_Kind_Leftof_Attribute => 1521,
+ Iir_Kind_Rightof_Attribute => 1527,
+ Iir_Kind_Delayed_Attribute => 1535,
+ Iir_Kind_Stable_Attribute => 1543,
+ Iir_Kind_Quiet_Attribute => 1551,
+ Iir_Kind_Transaction_Attribute => 1559,
+ Iir_Kind_Event_Attribute => 1563,
+ Iir_Kind_Active_Attribute => 1567,
+ Iir_Kind_Last_Event_Attribute => 1571,
+ Iir_Kind_Last_Active_Attribute => 1575,
+ Iir_Kind_Last_Value_Attribute => 1579,
+ Iir_Kind_Driving_Attribute => 1583,
+ Iir_Kind_Driving_Value_Attribute => 1587,
+ Iir_Kind_Behavior_Attribute => 1587,
+ Iir_Kind_Structure_Attribute => 1587,
+ Iir_Kind_Simple_Name_Attribute => 1594,
+ Iir_Kind_Instance_Name_Attribute => 1599,
+ Iir_Kind_Path_Name_Attribute => 1604,
+ Iir_Kind_Left_Array_Attribute => 1611,
+ Iir_Kind_Right_Array_Attribute => 1618,
+ Iir_Kind_High_Array_Attribute => 1625,
+ Iir_Kind_Low_Array_Attribute => 1632,
+ Iir_Kind_Length_Array_Attribute => 1639,
+ Iir_Kind_Ascending_Array_Attribute => 1646,
+ Iir_Kind_Range_Array_Attribute => 1653,
+ Iir_Kind_Reverse_Range_Array_Attribute => 1660,
+ Iir_Kind_Attribute_Name => 1668
+ );
+
+ function Get_Fields (K : Iir_Kind) return Fields_Array
+ is
+ First : Natural;
+ Last : Integer;
+ begin
+ if K = Iir_Kind'First then
+ First := Fields_Of_Iir'First;
+ else
+ First := Fields_Of_Iir_Last (Iir_Kind'Pred (K)) + 1;
+ end if;
+ Last := Fields_Of_Iir_Last (K);
+ return Fields_Of_Iir (First .. Last);
+ end Get_Fields;
+
+ function Get_Base_Type
+ (N : Iir; F : Fields_Enum) return Base_Type is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Base_Type);
+ case F is
+ when Field_Bit_String_Base =>
+ return Get_Bit_String_Base (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Base_Type;
+
+ procedure Set_Base_Type
+ (N : Iir; F : Fields_Enum; V: Base_Type) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Base_Type);
+ case F is
+ when Field_Bit_String_Base =>
+ Set_Bit_String_Base (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Base_Type;
+
+ function Get_Boolean
+ (N : Iir; F : Fields_Enum) return Boolean is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Boolean);
+ case F is
+ when Field_Whole_Association_Flag =>
+ return Get_Whole_Association_Flag (N);
+ when Field_Collapse_Signal_Flag =>
+ return Get_Collapse_Signal_Flag (N);
+ when Field_Artificial_Flag =>
+ return Get_Artificial_Flag (N);
+ when Field_Open_Flag =>
+ return Get_Open_Flag (N);
+ when Field_After_Drivers_Flag =>
+ return Get_After_Drivers_Flag (N);
+ when Field_Same_Alternative_Flag =>
+ return Get_Same_Alternative_Flag (N);
+ when Field_Need_Body =>
+ return Get_Need_Body (N);
+ when Field_Deferred_Declaration_Flag =>
+ return Get_Deferred_Declaration_Flag (N);
+ when Field_Shared_Flag =>
+ return Get_Shared_Flag (N);
+ when Field_Visible_Flag =>
+ return Get_Visible_Flag (N);
+ when Field_Text_File_Flag =>
+ return Get_Text_File_Flag (N);
+ when Field_Only_Characters_Flag =>
+ return Get_Only_Characters_Flag (N);
+ when Field_Postponed_Flag =>
+ return Get_Postponed_Flag (N);
+ when Field_Passive_Flag =>
+ return Get_Passive_Flag (N);
+ when Field_Resolution_Function_Flag =>
+ return Get_Resolution_Function_Flag (N);
+ when Field_Seen_Flag =>
+ return Get_Seen_Flag (N);
+ when Field_Pure_Flag =>
+ return Get_Pure_Flag (N);
+ when Field_Foreign_Flag =>
+ return Get_Foreign_Flag (N);
+ when Field_Resolved_Flag =>
+ return Get_Resolved_Flag (N);
+ when Field_Signal_Type_Flag =>
+ return Get_Signal_Type_Flag (N);
+ when Field_Has_Signal_Flag =>
+ return Get_Has_Signal_Flag (N);
+ when Field_Elab_Flag =>
+ return Get_Elab_Flag (N);
+ when Field_Index_Constraint_Flag =>
+ return Get_Index_Constraint_Flag (N);
+ when Field_Aggr_Dynamic_Flag =>
+ return Get_Aggr_Dynamic_Flag (N);
+ when Field_Aggr_Others_Flag =>
+ return Get_Aggr_Others_Flag (N);
+ when Field_Aggr_Named_Flag =>
+ return Get_Aggr_Named_Flag (N);
+ when Field_Has_Disconnect_Flag =>
+ return Get_Has_Disconnect_Flag (N);
+ when Field_Has_Active_Flag =>
+ return Get_Has_Active_Flag (N);
+ when Field_Is_Within_Flag =>
+ return Get_Is_Within_Flag (N);
+ when Field_Implicit_Alias_Flag =>
+ return Get_Implicit_Alias_Flag (N);
+ when Field_Use_Flag =>
+ return Get_Use_Flag (N);
+ when Field_End_Has_Reserved_Id =>
+ return Get_End_Has_Reserved_Id (N);
+ when Field_End_Has_Identifier =>
+ return Get_End_Has_Identifier (N);
+ when Field_End_Has_Postponed =>
+ return Get_End_Has_Postponed (N);
+ when Field_Has_Begin =>
+ return Get_Has_Begin (N);
+ when Field_Has_Is =>
+ return Get_Has_Is (N);
+ when Field_Has_Pure =>
+ return Get_Has_Pure (N);
+ when Field_Has_Body =>
+ return Get_Has_Body (N);
+ when Field_Has_Identifier_List =>
+ return Get_Has_Identifier_List (N);
+ when Field_Has_Mode =>
+ return Get_Has_Mode (N);
+ when Field_Is_Ref =>
+ return Get_Is_Ref (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Boolean;
+
+ procedure Set_Boolean
+ (N : Iir; F : Fields_Enum; V: Boolean) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Boolean);
+ case F is
+ when Field_Whole_Association_Flag =>
+ Set_Whole_Association_Flag (N, V);
+ when Field_Collapse_Signal_Flag =>
+ Set_Collapse_Signal_Flag (N, V);
+ when Field_Artificial_Flag =>
+ Set_Artificial_Flag (N, V);
+ when Field_Open_Flag =>
+ Set_Open_Flag (N, V);
+ when Field_After_Drivers_Flag =>
+ Set_After_Drivers_Flag (N, V);
+ when Field_Same_Alternative_Flag =>
+ Set_Same_Alternative_Flag (N, V);
+ when Field_Need_Body =>
+ Set_Need_Body (N, V);
+ when Field_Deferred_Declaration_Flag =>
+ Set_Deferred_Declaration_Flag (N, V);
+ when Field_Shared_Flag =>
+ Set_Shared_Flag (N, V);
+ when Field_Visible_Flag =>
+ Set_Visible_Flag (N, V);
+ when Field_Text_File_Flag =>
+ Set_Text_File_Flag (N, V);
+ when Field_Only_Characters_Flag =>
+ Set_Only_Characters_Flag (N, V);
+ when Field_Postponed_Flag =>
+ Set_Postponed_Flag (N, V);
+ when Field_Passive_Flag =>
+ Set_Passive_Flag (N, V);
+ when Field_Resolution_Function_Flag =>
+ Set_Resolution_Function_Flag (N, V);
+ when Field_Seen_Flag =>
+ Set_Seen_Flag (N, V);
+ when Field_Pure_Flag =>
+ Set_Pure_Flag (N, V);
+ when Field_Foreign_Flag =>
+ Set_Foreign_Flag (N, V);
+ when Field_Resolved_Flag =>
+ Set_Resolved_Flag (N, V);
+ when Field_Signal_Type_Flag =>
+ Set_Signal_Type_Flag (N, V);
+ when Field_Has_Signal_Flag =>
+ Set_Has_Signal_Flag (N, V);
+ when Field_Elab_Flag =>
+ Set_Elab_Flag (N, V);
+ when Field_Index_Constraint_Flag =>
+ Set_Index_Constraint_Flag (N, V);
+ when Field_Aggr_Dynamic_Flag =>
+ Set_Aggr_Dynamic_Flag (N, V);
+ when Field_Aggr_Others_Flag =>
+ Set_Aggr_Others_Flag (N, V);
+ when Field_Aggr_Named_Flag =>
+ Set_Aggr_Named_Flag (N, V);
+ when Field_Has_Disconnect_Flag =>
+ Set_Has_Disconnect_Flag (N, V);
+ when Field_Has_Active_Flag =>
+ Set_Has_Active_Flag (N, V);
+ when Field_Is_Within_Flag =>
+ Set_Is_Within_Flag (N, V);
+ when Field_Implicit_Alias_Flag =>
+ Set_Implicit_Alias_Flag (N, V);
+ when Field_Use_Flag =>
+ Set_Use_Flag (N, V);
+ when Field_End_Has_Reserved_Id =>
+ Set_End_Has_Reserved_Id (N, V);
+ when Field_End_Has_Identifier =>
+ Set_End_Has_Identifier (N, V);
+ when Field_End_Has_Postponed =>
+ Set_End_Has_Postponed (N, V);
+ when Field_Has_Begin =>
+ Set_Has_Begin (N, V);
+ when Field_Has_Is =>
+ Set_Has_Is (N, V);
+ when Field_Has_Pure =>
+ Set_Has_Pure (N, V);
+ when Field_Has_Body =>
+ Set_Has_Body (N, V);
+ when Field_Has_Identifier_List =>
+ Set_Has_Identifier_List (N, V);
+ when Field_Has_Mode =>
+ Set_Has_Mode (N, V);
+ when Field_Is_Ref =>
+ Set_Is_Ref (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Boolean;
+
+ function Get_Date_State_Type
+ (N : Iir; F : Fields_Enum) return Date_State_Type is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Date_State_Type);
+ case F is
+ when Field_Date_State =>
+ return Get_Date_State (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Date_State_Type;
+
+ procedure Set_Date_State_Type
+ (N : Iir; F : Fields_Enum; V: Date_State_Type) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Date_State_Type);
+ case F is
+ when Field_Date_State =>
+ Set_Date_State (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Date_State_Type;
+
+ function Get_Date_Type
+ (N : Iir; F : Fields_Enum) return Date_Type is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Date_Type);
+ case F is
+ when Field_Date =>
+ return Get_Date (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Date_Type;
+
+ procedure Set_Date_Type
+ (N : Iir; F : Fields_Enum; V: Date_Type) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Date_Type);
+ case F is
+ when Field_Date =>
+ Set_Date (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Date_Type;
+
+ function Get_Iir
+ (N : Iir; F : Fields_Enum) return Iir is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir);
+ case F is
+ when Field_First_Design_Unit =>
+ return Get_First_Design_Unit (N);
+ when Field_Last_Design_Unit =>
+ return Get_Last_Design_Unit (N);
+ when Field_Library_Declaration =>
+ return Get_Library_Declaration (N);
+ when Field_Library =>
+ return Get_Library (N);
+ when Field_Design_File =>
+ return Get_Design_File (N);
+ when Field_Design_File_Chain =>
+ return Get_Design_File_Chain (N);
+ when Field_Context_Items =>
+ return Get_Context_Items (N);
+ when Field_Library_Unit =>
+ return Get_Library_Unit (N);
+ when Field_Hash_Chain =>
+ return Get_Hash_Chain (N);
+ when Field_Physical_Literal =>
+ return Get_Physical_Literal (N);
+ when Field_Physical_Unit_Value =>
+ return Get_Physical_Unit_Value (N);
+ when Field_Enumeration_Decl =>
+ return Get_Enumeration_Decl (N);
+ when Field_Bit_String_0 =>
+ return Get_Bit_String_0 (N);
+ when Field_Bit_String_1 =>
+ return Get_Bit_String_1 (N);
+ when Field_Literal_Origin =>
+ return Get_Literal_Origin (N);
+ when Field_Range_Origin =>
+ return Get_Range_Origin (N);
+ when Field_Literal_Subtype =>
+ return Get_Literal_Subtype (N);
+ when Field_Attribute_Designator =>
+ return Get_Attribute_Designator (N);
+ when Field_Attribute_Specification_Chain =>
+ return Get_Attribute_Specification_Chain (N);
+ when Field_Attribute_Specification =>
+ return Get_Attribute_Specification (N);
+ when Field_Designated_Entity =>
+ return Get_Designated_Entity (N);
+ when Field_Formal =>
+ return Get_Formal (N);
+ when Field_Actual =>
+ return Get_Actual (N);
+ when Field_In_Conversion =>
+ return Get_In_Conversion (N);
+ when Field_Out_Conversion =>
+ return Get_Out_Conversion (N);
+ when Field_We_Value =>
+ return Get_We_Value (N);
+ when Field_Time =>
+ return Get_Time (N);
+ when Field_Associated_Expr =>
+ return Get_Associated_Expr (N);
+ when Field_Associated_Chain =>
+ return Get_Associated_Chain (N);
+ when Field_Choice_Name =>
+ return Get_Choice_Name (N);
+ when Field_Choice_Expression =>
+ return Get_Choice_Expression (N);
+ when Field_Choice_Range =>
+ return Get_Choice_Range (N);
+ when Field_Architecture =>
+ return Get_Architecture (N);
+ when Field_Block_Specification =>
+ return Get_Block_Specification (N);
+ when Field_Prev_Block_Configuration =>
+ return Get_Prev_Block_Configuration (N);
+ when Field_Configuration_Item_Chain =>
+ return Get_Configuration_Item_Chain (N);
+ when Field_Attribute_Value_Chain =>
+ return Get_Attribute_Value_Chain (N);
+ when Field_Spec_Chain =>
+ return Get_Spec_Chain (N);
+ when Field_Attribute_Value_Spec_Chain =>
+ return Get_Attribute_Value_Spec_Chain (N);
+ when Field_Entity_Name =>
+ return Get_Entity_Name (N);
+ when Field_Package =>
+ return Get_Package (N);
+ when Field_Package_Body =>
+ return Get_Package_Body (N);
+ when Field_Block_Configuration =>
+ return Get_Block_Configuration (N);
+ when Field_Concurrent_Statement_Chain =>
+ return Get_Concurrent_Statement_Chain (N);
+ when Field_Chain =>
+ return Get_Chain (N);
+ when Field_Port_Chain =>
+ return Get_Port_Chain (N);
+ when Field_Generic_Chain =>
+ return Get_Generic_Chain (N);
+ when Field_Type =>
+ return Get_Type (N);
+ when Field_Subtype_Indication =>
+ return Get_Subtype_Indication (N);
+ when Field_Discrete_Range =>
+ return Get_Discrete_Range (N);
+ when Field_Type_Definition =>
+ return Get_Type_Definition (N);
+ when Field_Subtype_Definition =>
+ return Get_Subtype_Definition (N);
+ when Field_Nature =>
+ return Get_Nature (N);
+ when Field_Base_Name =>
+ return Get_Base_Name (N);
+ when Field_Interface_Declaration_Chain =>
+ return Get_Interface_Declaration_Chain (N);
+ when Field_Subprogram_Specification =>
+ return Get_Subprogram_Specification (N);
+ when Field_Sequential_Statement_Chain =>
+ return Get_Sequential_Statement_Chain (N);
+ when Field_Subprogram_Body =>
+ return Get_Subprogram_Body (N);
+ when Field_Return_Type =>
+ return Get_Return_Type (N);
+ when Field_Type_Reference =>
+ return Get_Type_Reference (N);
+ when Field_Default_Value =>
+ return Get_Default_Value (N);
+ when Field_Deferred_Declaration =>
+ return Get_Deferred_Declaration (N);
+ when Field_Design_Unit =>
+ return Get_Design_Unit (N);
+ when Field_Block_Statement =>
+ return Get_Block_Statement (N);
+ when Field_Signal_Driver =>
+ return Get_Signal_Driver (N);
+ when Field_Declaration_Chain =>
+ return Get_Declaration_Chain (N);
+ when Field_File_Logical_Name =>
+ return Get_File_Logical_Name (N);
+ when Field_File_Open_Kind =>
+ return Get_File_Open_Kind (N);
+ when Field_Element_Declaration =>
+ return Get_Element_Declaration (N);
+ when Field_Selected_Element =>
+ return Get_Selected_Element (N);
+ when Field_Use_Clause_Chain =>
+ return Get_Use_Clause_Chain (N);
+ when Field_Selected_Name =>
+ return Get_Selected_Name (N);
+ when Field_Type_Declarator =>
+ return Get_Type_Declarator (N);
+ when Field_Entity_Class_Entry_Chain =>
+ return Get_Entity_Class_Entry_Chain (N);
+ when Field_Unit_Chain =>
+ return Get_Unit_Chain (N);
+ when Field_Primary_Unit =>
+ return Get_Primary_Unit (N);
+ when Field_Range_Constraint =>
+ return Get_Range_Constraint (N);
+ when Field_Left_Limit =>
+ return Get_Left_Limit (N);
+ when Field_Right_Limit =>
+ return Get_Right_Limit (N);
+ when Field_Base_Type =>
+ return Get_Base_Type (N);
+ when Field_Resolution_Indication =>
+ return Get_Resolution_Indication (N);
+ when Field_Record_Element_Resolution_Chain =>
+ return Get_Record_Element_Resolution_Chain (N);
+ when Field_Tolerance =>
+ return Get_Tolerance (N);
+ when Field_Plus_Terminal =>
+ return Get_Plus_Terminal (N);
+ when Field_Minus_Terminal =>
+ return Get_Minus_Terminal (N);
+ when Field_Simultaneous_Left =>
+ return Get_Simultaneous_Left (N);
+ when Field_Simultaneous_Right =>
+ return Get_Simultaneous_Right (N);
+ when Field_Element_Subtype_Indication =>
+ return Get_Element_Subtype_Indication (N);
+ when Field_Element_Subtype =>
+ return Get_Element_Subtype (N);
+ when Field_Array_Element_Constraint =>
+ return Get_Array_Element_Constraint (N);
+ when Field_Designated_Type =>
+ return Get_Designated_Type (N);
+ when Field_Designated_Subtype_Indication =>
+ return Get_Designated_Subtype_Indication (N);
+ when Field_Reference =>
+ return Get_Reference (N);
+ when Field_Nature_Declarator =>
+ return Get_Nature_Declarator (N);
+ when Field_Across_Type =>
+ return Get_Across_Type (N);
+ when Field_Through_Type =>
+ return Get_Through_Type (N);
+ when Field_Target =>
+ return Get_Target (N);
+ when Field_Waveform_Chain =>
+ return Get_Waveform_Chain (N);
+ when Field_Guard =>
+ return Get_Guard (N);
+ when Field_Reject_Time_Expression =>
+ return Get_Reject_Time_Expression (N);
+ when Field_Process_Origin =>
+ return Get_Process_Origin (N);
+ when Field_Condition_Clause =>
+ return Get_Condition_Clause (N);
+ when Field_Timeout_Clause =>
+ return Get_Timeout_Clause (N);
+ when Field_Assertion_Condition =>
+ return Get_Assertion_Condition (N);
+ when Field_Report_Expression =>
+ return Get_Report_Expression (N);
+ when Field_Severity_Expression =>
+ return Get_Severity_Expression (N);
+ when Field_Instantiated_Unit =>
+ return Get_Instantiated_Unit (N);
+ when Field_Generic_Map_Aspect_Chain =>
+ return Get_Generic_Map_Aspect_Chain (N);
+ when Field_Port_Map_Aspect_Chain =>
+ return Get_Port_Map_Aspect_Chain (N);
+ when Field_Configuration_Name =>
+ return Get_Configuration_Name (N);
+ when Field_Component_Configuration =>
+ return Get_Component_Configuration (N);
+ when Field_Configuration_Specification =>
+ return Get_Configuration_Specification (N);
+ when Field_Default_Binding_Indication =>
+ return Get_Default_Binding_Indication (N);
+ when Field_Default_Configuration_Declaration =>
+ return Get_Default_Configuration_Declaration (N);
+ when Field_Expression =>
+ return Get_Expression (N);
+ when Field_Allocator_Designated_Type =>
+ return Get_Allocator_Designated_Type (N);
+ when Field_Selected_Waveform_Chain =>
+ return Get_Selected_Waveform_Chain (N);
+ when Field_Conditional_Waveform_Chain =>
+ return Get_Conditional_Waveform_Chain (N);
+ when Field_Guard_Expression =>
+ return Get_Guard_Expression (N);
+ when Field_Guard_Decl =>
+ return Get_Guard_Decl (N);
+ when Field_Block_Block_Configuration =>
+ return Get_Block_Block_Configuration (N);
+ when Field_Package_Header =>
+ return Get_Package_Header (N);
+ when Field_Block_Header =>
+ return Get_Block_Header (N);
+ when Field_Uninstantiated_Package_Name =>
+ return Get_Uninstantiated_Package_Name (N);
+ when Field_Generate_Block_Configuration =>
+ return Get_Generate_Block_Configuration (N);
+ when Field_Generation_Scheme =>
+ return Get_Generation_Scheme (N);
+ when Field_Condition =>
+ return Get_Condition (N);
+ when Field_Else_Clause =>
+ return Get_Else_Clause (N);
+ when Field_Parameter_Specification =>
+ return Get_Parameter_Specification (N);
+ when Field_Parent =>
+ return Get_Parent (N);
+ when Field_Loop_Label =>
+ return Get_Loop_Label (N);
+ when Field_Component_Name =>
+ return Get_Component_Name (N);
+ when Field_Entity_Aspect =>
+ return Get_Entity_Aspect (N);
+ when Field_Default_Entity_Aspect =>
+ return Get_Default_Entity_Aspect (N);
+ when Field_Default_Generic_Map_Aspect_Chain =>
+ return Get_Default_Generic_Map_Aspect_Chain (N);
+ when Field_Default_Port_Map_Aspect_Chain =>
+ return Get_Default_Port_Map_Aspect_Chain (N);
+ when Field_Binding_Indication =>
+ return Get_Binding_Indication (N);
+ when Field_Named_Entity =>
+ return Get_Named_Entity (N);
+ when Field_Alias_Declaration =>
+ return Get_Alias_Declaration (N);
+ when Field_Error_Origin =>
+ return Get_Error_Origin (N);
+ when Field_Operand =>
+ return Get_Operand (N);
+ when Field_Left =>
+ return Get_Left (N);
+ when Field_Right =>
+ return Get_Right (N);
+ when Field_Unit_Name =>
+ return Get_Unit_Name (N);
+ when Field_Name =>
+ return Get_Name (N);
+ when Field_Group_Template_Name =>
+ return Get_Group_Template_Name (N);
+ when Field_Prefix =>
+ return Get_Prefix (N);
+ when Field_Signature_Prefix =>
+ return Get_Signature_Prefix (N);
+ when Field_Slice_Subtype =>
+ return Get_Slice_Subtype (N);
+ when Field_Suffix =>
+ return Get_Suffix (N);
+ when Field_Index_Subtype =>
+ return Get_Index_Subtype (N);
+ when Field_Parameter =>
+ return Get_Parameter (N);
+ when Field_Actual_Type =>
+ return Get_Actual_Type (N);
+ when Field_Associated_Interface =>
+ return Get_Associated_Interface (N);
+ when Field_Association_Chain =>
+ return Get_Association_Chain (N);
+ when Field_Individual_Association_Chain =>
+ return Get_Individual_Association_Chain (N);
+ when Field_Aggregate_Info =>
+ return Get_Aggregate_Info (N);
+ when Field_Sub_Aggregate_Info =>
+ return Get_Sub_Aggregate_Info (N);
+ when Field_Aggr_Low_Limit =>
+ return Get_Aggr_Low_Limit (N);
+ when Field_Aggr_High_Limit =>
+ return Get_Aggr_High_Limit (N);
+ when Field_Association_Choices_Chain =>
+ return Get_Association_Choices_Chain (N);
+ when Field_Case_Statement_Alternative_Chain =>
+ return Get_Case_Statement_Alternative_Chain (N);
+ when Field_Procedure_Call =>
+ return Get_Procedure_Call (N);
+ when Field_Implementation =>
+ return Get_Implementation (N);
+ when Field_Parameter_Association_Chain =>
+ return Get_Parameter_Association_Chain (N);
+ when Field_Method_Object =>
+ return Get_Method_Object (N);
+ when Field_Subtype_Type_Mark =>
+ return Get_Subtype_Type_Mark (N);
+ when Field_Type_Conversion_Subtype =>
+ return Get_Type_Conversion_Subtype (N);
+ when Field_Type_Mark =>
+ return Get_Type_Mark (N);
+ when Field_File_Type_Mark =>
+ return Get_File_Type_Mark (N);
+ when Field_Return_Type_Mark =>
+ return Get_Return_Type_Mark (N);
+ when Field_Alias_Signature =>
+ return Get_Alias_Signature (N);
+ when Field_Attribute_Signature =>
+ return Get_Attribute_Signature (N);
+ when Field_Simple_Name_Subtype =>
+ return Get_Simple_Name_Subtype (N);
+ when Field_Protected_Type_Body =>
+ return Get_Protected_Type_Body (N);
+ when Field_Protected_Type_Declaration =>
+ return Get_Protected_Type_Declaration (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir;
+
+ procedure Set_Iir
+ (N : Iir; F : Fields_Enum; V: Iir) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir);
+ case F is
+ when Field_First_Design_Unit =>
+ Set_First_Design_Unit (N, V);
+ when Field_Last_Design_Unit =>
+ Set_Last_Design_Unit (N, V);
+ when Field_Library_Declaration =>
+ Set_Library_Declaration (N, V);
+ when Field_Library =>
+ Set_Library (N, V);
+ when Field_Design_File =>
+ Set_Design_File (N, V);
+ when Field_Design_File_Chain =>
+ Set_Design_File_Chain (N, V);
+ when Field_Context_Items =>
+ Set_Context_Items (N, V);
+ when Field_Library_Unit =>
+ Set_Library_Unit (N, V);
+ when Field_Hash_Chain =>
+ Set_Hash_Chain (N, V);
+ when Field_Physical_Literal =>
+ Set_Physical_Literal (N, V);
+ when Field_Physical_Unit_Value =>
+ Set_Physical_Unit_Value (N, V);
+ when Field_Enumeration_Decl =>
+ Set_Enumeration_Decl (N, V);
+ when Field_Bit_String_0 =>
+ Set_Bit_String_0 (N, V);
+ when Field_Bit_String_1 =>
+ Set_Bit_String_1 (N, V);
+ when Field_Literal_Origin =>
+ Set_Literal_Origin (N, V);
+ when Field_Range_Origin =>
+ Set_Range_Origin (N, V);
+ when Field_Literal_Subtype =>
+ Set_Literal_Subtype (N, V);
+ when Field_Attribute_Designator =>
+ Set_Attribute_Designator (N, V);
+ when Field_Attribute_Specification_Chain =>
+ Set_Attribute_Specification_Chain (N, V);
+ when Field_Attribute_Specification =>
+ Set_Attribute_Specification (N, V);
+ when Field_Designated_Entity =>
+ Set_Designated_Entity (N, V);
+ when Field_Formal =>
+ Set_Formal (N, V);
+ when Field_Actual =>
+ Set_Actual (N, V);
+ when Field_In_Conversion =>
+ Set_In_Conversion (N, V);
+ when Field_Out_Conversion =>
+ Set_Out_Conversion (N, V);
+ when Field_We_Value =>
+ Set_We_Value (N, V);
+ when Field_Time =>
+ Set_Time (N, V);
+ when Field_Associated_Expr =>
+ Set_Associated_Expr (N, V);
+ when Field_Associated_Chain =>
+ Set_Associated_Chain (N, V);
+ when Field_Choice_Name =>
+ Set_Choice_Name (N, V);
+ when Field_Choice_Expression =>
+ Set_Choice_Expression (N, V);
+ when Field_Choice_Range =>
+ Set_Choice_Range (N, V);
+ when Field_Architecture =>
+ Set_Architecture (N, V);
+ when Field_Block_Specification =>
+ Set_Block_Specification (N, V);
+ when Field_Prev_Block_Configuration =>
+ Set_Prev_Block_Configuration (N, V);
+ when Field_Configuration_Item_Chain =>
+ Set_Configuration_Item_Chain (N, V);
+ when Field_Attribute_Value_Chain =>
+ Set_Attribute_Value_Chain (N, V);
+ when Field_Spec_Chain =>
+ Set_Spec_Chain (N, V);
+ when Field_Attribute_Value_Spec_Chain =>
+ Set_Attribute_Value_Spec_Chain (N, V);
+ when Field_Entity_Name =>
+ Set_Entity_Name (N, V);
+ when Field_Package =>
+ Set_Package (N, V);
+ when Field_Package_Body =>
+ Set_Package_Body (N, V);
+ when Field_Block_Configuration =>
+ Set_Block_Configuration (N, V);
+ when Field_Concurrent_Statement_Chain =>
+ Set_Concurrent_Statement_Chain (N, V);
+ when Field_Chain =>
+ Set_Chain (N, V);
+ when Field_Port_Chain =>
+ Set_Port_Chain (N, V);
+ when Field_Generic_Chain =>
+ Set_Generic_Chain (N, V);
+ when Field_Type =>
+ Set_Type (N, V);
+ when Field_Subtype_Indication =>
+ Set_Subtype_Indication (N, V);
+ when Field_Discrete_Range =>
+ Set_Discrete_Range (N, V);
+ when Field_Type_Definition =>
+ Set_Type_Definition (N, V);
+ when Field_Subtype_Definition =>
+ Set_Subtype_Definition (N, V);
+ when Field_Nature =>
+ Set_Nature (N, V);
+ when Field_Base_Name =>
+ Set_Base_Name (N, V);
+ when Field_Interface_Declaration_Chain =>
+ Set_Interface_Declaration_Chain (N, V);
+ when Field_Subprogram_Specification =>
+ Set_Subprogram_Specification (N, V);
+ when Field_Sequential_Statement_Chain =>
+ Set_Sequential_Statement_Chain (N, V);
+ when Field_Subprogram_Body =>
+ Set_Subprogram_Body (N, V);
+ when Field_Return_Type =>
+ Set_Return_Type (N, V);
+ when Field_Type_Reference =>
+ Set_Type_Reference (N, V);
+ when Field_Default_Value =>
+ Set_Default_Value (N, V);
+ when Field_Deferred_Declaration =>
+ Set_Deferred_Declaration (N, V);
+ when Field_Design_Unit =>
+ Set_Design_Unit (N, V);
+ when Field_Block_Statement =>
+ Set_Block_Statement (N, V);
+ when Field_Signal_Driver =>
+ Set_Signal_Driver (N, V);
+ when Field_Declaration_Chain =>
+ Set_Declaration_Chain (N, V);
+ when Field_File_Logical_Name =>
+ Set_File_Logical_Name (N, V);
+ when Field_File_Open_Kind =>
+ Set_File_Open_Kind (N, V);
+ when Field_Element_Declaration =>
+ Set_Element_Declaration (N, V);
+ when Field_Selected_Element =>
+ Set_Selected_Element (N, V);
+ when Field_Use_Clause_Chain =>
+ Set_Use_Clause_Chain (N, V);
+ when Field_Selected_Name =>
+ Set_Selected_Name (N, V);
+ when Field_Type_Declarator =>
+ Set_Type_Declarator (N, V);
+ when Field_Entity_Class_Entry_Chain =>
+ Set_Entity_Class_Entry_Chain (N, V);
+ when Field_Unit_Chain =>
+ Set_Unit_Chain (N, V);
+ when Field_Primary_Unit =>
+ Set_Primary_Unit (N, V);
+ when Field_Range_Constraint =>
+ Set_Range_Constraint (N, V);
+ when Field_Left_Limit =>
+ Set_Left_Limit (N, V);
+ when Field_Right_Limit =>
+ Set_Right_Limit (N, V);
+ when Field_Base_Type =>
+ Set_Base_Type (N, V);
+ when Field_Resolution_Indication =>
+ Set_Resolution_Indication (N, V);
+ when Field_Record_Element_Resolution_Chain =>
+ Set_Record_Element_Resolution_Chain (N, V);
+ when Field_Tolerance =>
+ Set_Tolerance (N, V);
+ when Field_Plus_Terminal =>
+ Set_Plus_Terminal (N, V);
+ when Field_Minus_Terminal =>
+ Set_Minus_Terminal (N, V);
+ when Field_Simultaneous_Left =>
+ Set_Simultaneous_Left (N, V);
+ when Field_Simultaneous_Right =>
+ Set_Simultaneous_Right (N, V);
+ when Field_Element_Subtype_Indication =>
+ Set_Element_Subtype_Indication (N, V);
+ when Field_Element_Subtype =>
+ Set_Element_Subtype (N, V);
+ when Field_Array_Element_Constraint =>
+ Set_Array_Element_Constraint (N, V);
+ when Field_Designated_Type =>
+ Set_Designated_Type (N, V);
+ when Field_Designated_Subtype_Indication =>
+ Set_Designated_Subtype_Indication (N, V);
+ when Field_Reference =>
+ Set_Reference (N, V);
+ when Field_Nature_Declarator =>
+ Set_Nature_Declarator (N, V);
+ when Field_Across_Type =>
+ Set_Across_Type (N, V);
+ when Field_Through_Type =>
+ Set_Through_Type (N, V);
+ when Field_Target =>
+ Set_Target (N, V);
+ when Field_Waveform_Chain =>
+ Set_Waveform_Chain (N, V);
+ when Field_Guard =>
+ Set_Guard (N, V);
+ when Field_Reject_Time_Expression =>
+ Set_Reject_Time_Expression (N, V);
+ when Field_Process_Origin =>
+ Set_Process_Origin (N, V);
+ when Field_Condition_Clause =>
+ Set_Condition_Clause (N, V);
+ when Field_Timeout_Clause =>
+ Set_Timeout_Clause (N, V);
+ when Field_Assertion_Condition =>
+ Set_Assertion_Condition (N, V);
+ when Field_Report_Expression =>
+ Set_Report_Expression (N, V);
+ when Field_Severity_Expression =>
+ Set_Severity_Expression (N, V);
+ when Field_Instantiated_Unit =>
+ Set_Instantiated_Unit (N, V);
+ when Field_Generic_Map_Aspect_Chain =>
+ Set_Generic_Map_Aspect_Chain (N, V);
+ when Field_Port_Map_Aspect_Chain =>
+ Set_Port_Map_Aspect_Chain (N, V);
+ when Field_Configuration_Name =>
+ Set_Configuration_Name (N, V);
+ when Field_Component_Configuration =>
+ Set_Component_Configuration (N, V);
+ when Field_Configuration_Specification =>
+ Set_Configuration_Specification (N, V);
+ when Field_Default_Binding_Indication =>
+ Set_Default_Binding_Indication (N, V);
+ when Field_Default_Configuration_Declaration =>
+ Set_Default_Configuration_Declaration (N, V);
+ when Field_Expression =>
+ Set_Expression (N, V);
+ when Field_Allocator_Designated_Type =>
+ Set_Allocator_Designated_Type (N, V);
+ when Field_Selected_Waveform_Chain =>
+ Set_Selected_Waveform_Chain (N, V);
+ when Field_Conditional_Waveform_Chain =>
+ Set_Conditional_Waveform_Chain (N, V);
+ when Field_Guard_Expression =>
+ Set_Guard_Expression (N, V);
+ when Field_Guard_Decl =>
+ Set_Guard_Decl (N, V);
+ when Field_Block_Block_Configuration =>
+ Set_Block_Block_Configuration (N, V);
+ when Field_Package_Header =>
+ Set_Package_Header (N, V);
+ when Field_Block_Header =>
+ Set_Block_Header (N, V);
+ when Field_Uninstantiated_Package_Name =>
+ Set_Uninstantiated_Package_Name (N, V);
+ when Field_Generate_Block_Configuration =>
+ Set_Generate_Block_Configuration (N, V);
+ when Field_Generation_Scheme =>
+ Set_Generation_Scheme (N, V);
+ when Field_Condition =>
+ Set_Condition (N, V);
+ when Field_Else_Clause =>
+ Set_Else_Clause (N, V);
+ when Field_Parameter_Specification =>
+ Set_Parameter_Specification (N, V);
+ when Field_Parent =>
+ Set_Parent (N, V);
+ when Field_Loop_Label =>
+ Set_Loop_Label (N, V);
+ when Field_Component_Name =>
+ Set_Component_Name (N, V);
+ when Field_Entity_Aspect =>
+ Set_Entity_Aspect (N, V);
+ when Field_Default_Entity_Aspect =>
+ Set_Default_Entity_Aspect (N, V);
+ when Field_Default_Generic_Map_Aspect_Chain =>
+ Set_Default_Generic_Map_Aspect_Chain (N, V);
+ when Field_Default_Port_Map_Aspect_Chain =>
+ Set_Default_Port_Map_Aspect_Chain (N, V);
+ when Field_Binding_Indication =>
+ Set_Binding_Indication (N, V);
+ when Field_Named_Entity =>
+ Set_Named_Entity (N, V);
+ when Field_Alias_Declaration =>
+ Set_Alias_Declaration (N, V);
+ when Field_Error_Origin =>
+ Set_Error_Origin (N, V);
+ when Field_Operand =>
+ Set_Operand (N, V);
+ when Field_Left =>
+ Set_Left (N, V);
+ when Field_Right =>
+ Set_Right (N, V);
+ when Field_Unit_Name =>
+ Set_Unit_Name (N, V);
+ when Field_Name =>
+ Set_Name (N, V);
+ when Field_Group_Template_Name =>
+ Set_Group_Template_Name (N, V);
+ when Field_Prefix =>
+ Set_Prefix (N, V);
+ when Field_Signature_Prefix =>
+ Set_Signature_Prefix (N, V);
+ when Field_Slice_Subtype =>
+ Set_Slice_Subtype (N, V);
+ when Field_Suffix =>
+ Set_Suffix (N, V);
+ when Field_Index_Subtype =>
+ Set_Index_Subtype (N, V);
+ when Field_Parameter =>
+ Set_Parameter (N, V);
+ when Field_Actual_Type =>
+ Set_Actual_Type (N, V);
+ when Field_Associated_Interface =>
+ Set_Associated_Interface (N, V);
+ when Field_Association_Chain =>
+ Set_Association_Chain (N, V);
+ when Field_Individual_Association_Chain =>
+ Set_Individual_Association_Chain (N, V);
+ when Field_Aggregate_Info =>
+ Set_Aggregate_Info (N, V);
+ when Field_Sub_Aggregate_Info =>
+ Set_Sub_Aggregate_Info (N, V);
+ when Field_Aggr_Low_Limit =>
+ Set_Aggr_Low_Limit (N, V);
+ when Field_Aggr_High_Limit =>
+ Set_Aggr_High_Limit (N, V);
+ when Field_Association_Choices_Chain =>
+ Set_Association_Choices_Chain (N, V);
+ when Field_Case_Statement_Alternative_Chain =>
+ Set_Case_Statement_Alternative_Chain (N, V);
+ when Field_Procedure_Call =>
+ Set_Procedure_Call (N, V);
+ when Field_Implementation =>
+ Set_Implementation (N, V);
+ when Field_Parameter_Association_Chain =>
+ Set_Parameter_Association_Chain (N, V);
+ when Field_Method_Object =>
+ Set_Method_Object (N, V);
+ when Field_Subtype_Type_Mark =>
+ Set_Subtype_Type_Mark (N, V);
+ when Field_Type_Conversion_Subtype =>
+ Set_Type_Conversion_Subtype (N, V);
+ when Field_Type_Mark =>
+ Set_Type_Mark (N, V);
+ when Field_File_Type_Mark =>
+ Set_File_Type_Mark (N, V);
+ when Field_Return_Type_Mark =>
+ Set_Return_Type_Mark (N, V);
+ when Field_Alias_Signature =>
+ Set_Alias_Signature (N, V);
+ when Field_Attribute_Signature =>
+ Set_Attribute_Signature (N, V);
+ when Field_Simple_Name_Subtype =>
+ Set_Simple_Name_Subtype (N, V);
+ when Field_Protected_Type_Body =>
+ Set_Protected_Type_Body (N, V);
+ when Field_Protected_Type_Declaration =>
+ Set_Protected_Type_Declaration (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir;
+
+ function Get_Iir_All_Sensitized
+ (N : Iir; F : Fields_Enum) return Iir_All_Sensitized is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_All_Sensitized);
+ case F is
+ when Field_All_Sensitized_State =>
+ return Get_All_Sensitized_State (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_All_Sensitized;
+
+ procedure Set_Iir_All_Sensitized
+ (N : Iir; F : Fields_Enum; V: Iir_All_Sensitized) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_All_Sensitized);
+ case F is
+ when Field_All_Sensitized_State =>
+ Set_All_Sensitized_State (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_All_Sensitized;
+
+ function Get_Iir_Constraint
+ (N : Iir; F : Fields_Enum) return Iir_Constraint is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Constraint);
+ case F is
+ when Field_Constraint_State =>
+ return Get_Constraint_State (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Constraint;
+
+ procedure Set_Iir_Constraint
+ (N : Iir; F : Fields_Enum; V: Iir_Constraint) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Constraint);
+ case F is
+ when Field_Constraint_State =>
+ Set_Constraint_State (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Constraint;
+
+ function Get_Iir_Delay_Mechanism
+ (N : Iir; F : Fields_Enum) return Iir_Delay_Mechanism is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Delay_Mechanism);
+ case F is
+ when Field_Delay_Mechanism =>
+ return Get_Delay_Mechanism (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Delay_Mechanism;
+
+ procedure Set_Iir_Delay_Mechanism
+ (N : Iir; F : Fields_Enum; V: Iir_Delay_Mechanism) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Delay_Mechanism);
+ case F is
+ when Field_Delay_Mechanism =>
+ Set_Delay_Mechanism (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Delay_Mechanism;
+
+ function Get_Iir_Direction
+ (N : Iir; F : Fields_Enum) return Iir_Direction is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Direction);
+ case F is
+ when Field_Direction =>
+ return Get_Direction (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Direction;
+
+ procedure Set_Iir_Direction
+ (N : Iir; F : Fields_Enum; V: Iir_Direction) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Direction);
+ case F is
+ when Field_Direction =>
+ Set_Direction (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Direction;
+
+ function Get_Iir_Fp64
+ (N : Iir; F : Fields_Enum) return Iir_Fp64 is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Fp64);
+ case F is
+ when Field_Fp_Value =>
+ return Get_Fp_Value (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Fp64;
+
+ procedure Set_Iir_Fp64
+ (N : Iir; F : Fields_Enum; V: Iir_Fp64) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Fp64);
+ case F is
+ when Field_Fp_Value =>
+ Set_Fp_Value (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Fp64;
+
+ function Get_Iir_Index32
+ (N : Iir; F : Fields_Enum) return Iir_Index32 is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Index32);
+ case F is
+ when Field_Element_Position =>
+ return Get_Element_Position (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Index32;
+
+ procedure Set_Iir_Index32
+ (N : Iir; F : Fields_Enum; V: Iir_Index32) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Index32);
+ case F is
+ when Field_Element_Position =>
+ Set_Element_Position (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Index32;
+
+ function Get_Iir_Int32
+ (N : Iir; F : Fields_Enum) return Iir_Int32 is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Int32);
+ case F is
+ when Field_Enum_Pos =>
+ return Get_Enum_Pos (N);
+ when Field_Overload_Number =>
+ return Get_Overload_Number (N);
+ when Field_Subprogram_Depth =>
+ return Get_Subprogram_Depth (N);
+ when Field_Subprogram_Hash =>
+ return Get_Subprogram_Hash (N);
+ when Field_Impure_Depth =>
+ return Get_Impure_Depth (N);
+ when Field_Aggr_Min_Length =>
+ return Get_Aggr_Min_Length (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Int32;
+
+ procedure Set_Iir_Int32
+ (N : Iir; F : Fields_Enum; V: Iir_Int32) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Int32);
+ case F is
+ when Field_Enum_Pos =>
+ Set_Enum_Pos (N, V);
+ when Field_Overload_Number =>
+ Set_Overload_Number (N, V);
+ when Field_Subprogram_Depth =>
+ Set_Subprogram_Depth (N, V);
+ when Field_Subprogram_Hash =>
+ Set_Subprogram_Hash (N, V);
+ when Field_Impure_Depth =>
+ Set_Impure_Depth (N, V);
+ when Field_Aggr_Min_Length =>
+ Set_Aggr_Min_Length (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Int32;
+
+ function Get_Iir_Int64
+ (N : Iir; F : Fields_Enum) return Iir_Int64 is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Int64);
+ case F is
+ when Field_Value =>
+ return Get_Value (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Int64;
+
+ procedure Set_Iir_Int64
+ (N : Iir; F : Fields_Enum; V: Iir_Int64) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Int64);
+ case F is
+ when Field_Value =>
+ Set_Value (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Int64;
+
+ function Get_Iir_Lexical_Layout_Type
+ (N : Iir; F : Fields_Enum) return Iir_Lexical_Layout_Type is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Lexical_Layout_Type);
+ case F is
+ when Field_Lexical_Layout =>
+ return Get_Lexical_Layout (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Lexical_Layout_Type;
+
+ procedure Set_Iir_Lexical_Layout_Type
+ (N : Iir; F : Fields_Enum; V: Iir_Lexical_Layout_Type) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Lexical_Layout_Type);
+ case F is
+ when Field_Lexical_Layout =>
+ Set_Lexical_Layout (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Lexical_Layout_Type;
+
+ function Get_Iir_List
+ (N : Iir; F : Fields_Enum) return Iir_List is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_List);
+ case F is
+ when Field_File_Dependence_List =>
+ return Get_File_Dependence_List (N);
+ when Field_Dependence_List =>
+ return Get_Dependence_List (N);
+ when Field_Analysis_Checks_List =>
+ return Get_Analysis_Checks_List (N);
+ when Field_Simple_Aggregate_List =>
+ return Get_Simple_Aggregate_List (N);
+ when Field_Entity_Name_List =>
+ return Get_Entity_Name_List (N);
+ when Field_Signal_List =>
+ return Get_Signal_List (N);
+ when Field_Enumeration_Literal_List =>
+ return Get_Enumeration_Literal_List (N);
+ when Field_Group_Constituent_List =>
+ return Get_Group_Constituent_List (N);
+ when Field_Index_Subtype_List =>
+ return Get_Index_Subtype_List (N);
+ when Field_Index_Subtype_Definition_List =>
+ return Get_Index_Subtype_Definition_List (N);
+ when Field_Index_Constraint_List =>
+ return Get_Index_Constraint_List (N);
+ when Field_Elements_Declaration_List =>
+ return Get_Elements_Declaration_List (N);
+ when Field_Index_List =>
+ return Get_Index_List (N);
+ when Field_Sensitivity_List =>
+ return Get_Sensitivity_List (N);
+ when Field_Callees_List =>
+ return Get_Callees_List (N);
+ when Field_Guard_Sensitivity_List =>
+ return Get_Guard_Sensitivity_List (N);
+ when Field_Instantiation_List =>
+ return Get_Instantiation_List (N);
+ when Field_Incomplete_Type_List =>
+ return Get_Incomplete_Type_List (N);
+ when Field_Type_Marks_List =>
+ return Get_Type_Marks_List (N);
+ when Field_Overload_List =>
+ return Get_Overload_List (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_List;
+
+ procedure Set_Iir_List
+ (N : Iir; F : Fields_Enum; V: Iir_List) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_List);
+ case F is
+ when Field_File_Dependence_List =>
+ Set_File_Dependence_List (N, V);
+ when Field_Dependence_List =>
+ Set_Dependence_List (N, V);
+ when Field_Analysis_Checks_List =>
+ Set_Analysis_Checks_List (N, V);
+ when Field_Simple_Aggregate_List =>
+ Set_Simple_Aggregate_List (N, V);
+ when Field_Entity_Name_List =>
+ Set_Entity_Name_List (N, V);
+ when Field_Signal_List =>
+ Set_Signal_List (N, V);
+ when Field_Enumeration_Literal_List =>
+ Set_Enumeration_Literal_List (N, V);
+ when Field_Group_Constituent_List =>
+ Set_Group_Constituent_List (N, V);
+ when Field_Index_Subtype_List =>
+ Set_Index_Subtype_List (N, V);
+ when Field_Index_Subtype_Definition_List =>
+ Set_Index_Subtype_Definition_List (N, V);
+ when Field_Index_Constraint_List =>
+ Set_Index_Constraint_List (N, V);
+ when Field_Elements_Declaration_List =>
+ Set_Elements_Declaration_List (N, V);
+ when Field_Index_List =>
+ Set_Index_List (N, V);
+ when Field_Sensitivity_List =>
+ Set_Sensitivity_List (N, V);
+ when Field_Callees_List =>
+ Set_Callees_List (N, V);
+ when Field_Guard_Sensitivity_List =>
+ Set_Guard_Sensitivity_List (N, V);
+ when Field_Instantiation_List =>
+ Set_Instantiation_List (N, V);
+ when Field_Incomplete_Type_List =>
+ Set_Incomplete_Type_List (N, V);
+ when Field_Type_Marks_List =>
+ Set_Type_Marks_List (N, V);
+ when Field_Overload_List =>
+ Set_Overload_List (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_List;
+
+ function Get_Iir_Mode
+ (N : Iir; F : Fields_Enum) return Iir_Mode is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Mode);
+ case F is
+ when Field_Mode =>
+ return Get_Mode (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Mode;
+
+ procedure Set_Iir_Mode
+ (N : Iir; F : Fields_Enum; V: Iir_Mode) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Mode);
+ case F is
+ when Field_Mode =>
+ Set_Mode (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Mode;
+
+ function Get_Iir_Predefined_Functions
+ (N : Iir; F : Fields_Enum) return Iir_Predefined_Functions is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Predefined_Functions);
+ case F is
+ when Field_Implicit_Definition =>
+ return Get_Implicit_Definition (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Predefined_Functions;
+
+ procedure Set_Iir_Predefined_Functions
+ (N : Iir; F : Fields_Enum; V: Iir_Predefined_Functions) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Predefined_Functions);
+ case F is
+ when Field_Implicit_Definition =>
+ Set_Implicit_Definition (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Predefined_Functions;
+
+ function Get_Iir_Pure_State
+ (N : Iir; F : Fields_Enum) return Iir_Pure_State is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Pure_State);
+ case F is
+ when Field_Purity_State =>
+ return Get_Purity_State (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Pure_State;
+
+ procedure Set_Iir_Pure_State
+ (N : Iir; F : Fields_Enum; V: Iir_Pure_State) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Pure_State);
+ case F is
+ when Field_Purity_State =>
+ Set_Purity_State (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Pure_State;
+
+ function Get_Iir_Signal_Kind
+ (N : Iir; F : Fields_Enum) return Iir_Signal_Kind is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Signal_Kind);
+ case F is
+ when Field_Signal_Kind =>
+ return Get_Signal_Kind (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Signal_Kind;
+
+ procedure Set_Iir_Signal_Kind
+ (N : Iir; F : Fields_Enum; V: Iir_Signal_Kind) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Signal_Kind);
+ case F is
+ when Field_Signal_Kind =>
+ Set_Signal_Kind (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Signal_Kind;
+
+ function Get_Iir_Staticness
+ (N : Iir; F : Fields_Enum) return Iir_Staticness is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Staticness);
+ case F is
+ when Field_Type_Staticness =>
+ return Get_Type_Staticness (N);
+ when Field_Expr_Staticness =>
+ return Get_Expr_Staticness (N);
+ when Field_Name_Staticness =>
+ return Get_Name_Staticness (N);
+ when Field_Value_Staticness =>
+ return Get_Value_Staticness (N);
+ when Field_Choice_Staticness =>
+ return Get_Choice_Staticness (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Iir_Staticness;
+
+ procedure Set_Iir_Staticness
+ (N : Iir; F : Fields_Enum; V: Iir_Staticness) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Iir_Staticness);
+ case F is
+ when Field_Type_Staticness =>
+ Set_Type_Staticness (N, V);
+ when Field_Expr_Staticness =>
+ Set_Expr_Staticness (N, V);
+ when Field_Name_Staticness =>
+ Set_Name_Staticness (N, V);
+ when Field_Value_Staticness =>
+ Set_Value_Staticness (N, V);
+ when Field_Choice_Staticness =>
+ Set_Choice_Staticness (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Iir_Staticness;
+
+ function Get_Int32
+ (N : Iir; F : Fields_Enum) return Int32 is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Int32);
+ case F is
+ when Field_Design_Unit_Source_Line =>
+ return Get_Design_Unit_Source_Line (N);
+ when Field_Design_Unit_Source_Col =>
+ return Get_Design_Unit_Source_Col (N);
+ when Field_String_Length =>
+ return Get_String_Length (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Int32;
+
+ procedure Set_Int32
+ (N : Iir; F : Fields_Enum; V: Int32) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Int32);
+ case F is
+ when Field_Design_Unit_Source_Line =>
+ Set_Design_Unit_Source_Line (N, V);
+ when Field_Design_Unit_Source_Col =>
+ Set_Design_Unit_Source_Col (N, V);
+ when Field_String_Length =>
+ Set_String_Length (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Int32;
+
+ function Get_Location_Type
+ (N : Iir; F : Fields_Enum) return Location_Type is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Location_Type);
+ case F is
+ when Field_End_Location =>
+ return Get_End_Location (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Location_Type;
+
+ procedure Set_Location_Type
+ (N : Iir; F : Fields_Enum; V: Location_Type) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Location_Type);
+ case F is
+ when Field_End_Location =>
+ Set_End_Location (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Location_Type;
+
+ function Get_Name_Id
+ (N : Iir; F : Fields_Enum) return Name_Id is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Name_Id);
+ case F is
+ when Field_Design_File_Filename =>
+ return Get_Design_File_Filename (N);
+ when Field_Design_File_Directory =>
+ return Get_Design_File_Directory (N);
+ when Field_Library_Directory =>
+ return Get_Library_Directory (N);
+ when Field_Identifier =>
+ return Get_Identifier (N);
+ when Field_Label =>
+ return Get_Label (N);
+ when Field_Simple_Name_Identifier =>
+ return Get_Simple_Name_Identifier (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Name_Id;
+
+ procedure Set_Name_Id
+ (N : Iir; F : Fields_Enum; V: Name_Id) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Name_Id);
+ case F is
+ when Field_Design_File_Filename =>
+ Set_Design_File_Filename (N, V);
+ when Field_Design_File_Directory =>
+ Set_Design_File_Directory (N, V);
+ when Field_Library_Directory =>
+ Set_Library_Directory (N, V);
+ when Field_Identifier =>
+ Set_Identifier (N, V);
+ when Field_Label =>
+ Set_Label (N, V);
+ when Field_Simple_Name_Identifier =>
+ Set_Simple_Name_Identifier (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Name_Id;
+
+ function Get_PSL_NFA
+ (N : Iir; F : Fields_Enum) return PSL_NFA is
+ begin
+ pragma Assert (Fields_Type (F) = Type_PSL_NFA);
+ case F is
+ when Field_PSL_NFA =>
+ return Get_PSL_NFA (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_PSL_NFA;
+
+ procedure Set_PSL_NFA
+ (N : Iir; F : Fields_Enum; V: PSL_NFA) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_PSL_NFA);
+ case F is
+ when Field_PSL_NFA =>
+ Set_PSL_NFA (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_PSL_NFA;
+
+ function Get_PSL_Node
+ (N : Iir; F : Fields_Enum) return PSL_Node is
+ begin
+ pragma Assert (Fields_Type (F) = Type_PSL_Node);
+ case F is
+ when Field_Psl_Property =>
+ return Get_Psl_Property (N);
+ when Field_Psl_Declaration =>
+ return Get_Psl_Declaration (N);
+ when Field_Psl_Expression =>
+ return Get_Psl_Expression (N);
+ when Field_Psl_Boolean =>
+ return Get_Psl_Boolean (N);
+ when Field_PSL_Clock =>
+ return Get_PSL_Clock (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_PSL_Node;
+
+ procedure Set_PSL_Node
+ (N : Iir; F : Fields_Enum; V: PSL_Node) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_PSL_Node);
+ case F is
+ when Field_Psl_Property =>
+ Set_Psl_Property (N, V);
+ when Field_Psl_Declaration =>
+ Set_Psl_Declaration (N, V);
+ when Field_Psl_Expression =>
+ Set_Psl_Expression (N, V);
+ when Field_Psl_Boolean =>
+ Set_Psl_Boolean (N, V);
+ when Field_PSL_Clock =>
+ Set_PSL_Clock (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_PSL_Node;
+
+ function Get_Source_Ptr
+ (N : Iir; F : Fields_Enum) return Source_Ptr is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Source_Ptr);
+ case F is
+ when Field_Design_Unit_Source_Pos =>
+ return Get_Design_Unit_Source_Pos (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Source_Ptr;
+
+ procedure Set_Source_Ptr
+ (N : Iir; F : Fields_Enum; V: Source_Ptr) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Source_Ptr);
+ case F is
+ when Field_Design_Unit_Source_Pos =>
+ Set_Design_Unit_Source_Pos (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Source_Ptr;
+
+ function Get_String_Id
+ (N : Iir; F : Fields_Enum) return String_Id is
+ begin
+ pragma Assert (Fields_Type (F) = Type_String_Id);
+ case F is
+ when Field_String_Id =>
+ return Get_String_Id (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_String_Id;
+
+ procedure Set_String_Id
+ (N : Iir; F : Fields_Enum; V: String_Id) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_String_Id);
+ case F is
+ when Field_String_Id =>
+ Set_String_Id (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_String_Id;
+
+ function Get_Time_Stamp_Id
+ (N : Iir; F : Fields_Enum) return Time_Stamp_Id is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Time_Stamp_Id);
+ case F is
+ when Field_File_Time_Stamp =>
+ return Get_File_Time_Stamp (N);
+ when Field_Analysis_Time_Stamp =>
+ return Get_Analysis_Time_Stamp (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Time_Stamp_Id;
+
+ procedure Set_Time_Stamp_Id
+ (N : Iir; F : Fields_Enum; V: Time_Stamp_Id) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Time_Stamp_Id);
+ case F is
+ when Field_File_Time_Stamp =>
+ Set_File_Time_Stamp (N, V);
+ when Field_Analysis_Time_Stamp =>
+ Set_Analysis_Time_Stamp (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Time_Stamp_Id;
+
+ function Get_Token_Type
+ (N : Iir; F : Fields_Enum) return Token_Type is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Token_Type);
+ case F is
+ when Field_Entity_Class =>
+ return Get_Entity_Class (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Token_Type;
+
+ procedure Set_Token_Type
+ (N : Iir; F : Fields_Enum; V: Token_Type) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Token_Type);
+ case F is
+ when Field_Entity_Class =>
+ Set_Entity_Class (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Token_Type;
+
+ function Get_Tri_State_Type
+ (N : Iir; F : Fields_Enum) return Tri_State_Type is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Tri_State_Type);
+ case F is
+ when Field_Guarded_Target_State =>
+ return Get_Guarded_Target_State (N);
+ when Field_Wait_State =>
+ return Get_Wait_State (N);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Tri_State_Type;
+
+ procedure Set_Tri_State_Type
+ (N : Iir; F : Fields_Enum; V: Tri_State_Type) is
+ begin
+ pragma Assert (Fields_Type (F) = Type_Tri_State_Type);
+ case F is
+ when Field_Guarded_Target_State =>
+ Set_Guarded_Target_State (N, V);
+ when Field_Wait_State =>
+ Set_Wait_State (N, V);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Set_Tri_State_Type;
+
+ function Has_First_Design_Unit (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_File;
+ end Has_First_Design_Unit;
+
+ function Has_Last_Design_Unit (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_File;
+ end Has_Last_Design_Unit;
+
+ function Has_Library_Declaration (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Library_Clause;
+ end Has_Library_Declaration;
+
+ function Has_File_Time_Stamp (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_File;
+ end Has_File_Time_Stamp;
+
+ function Has_Analysis_Time_Stamp (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_File;
+ end Has_Analysis_Time_Stamp;
+
+ function Has_Library (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_File;
+ end Has_Library;
+
+ function Has_File_Dependence_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_File;
+ end Has_File_Dependence_List;
+
+ function Has_Design_File_Filename (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_File;
+ end Has_Design_File_Filename;
+
+ function Has_Design_File_Directory (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_File;
+ end Has_Design_File_Directory;
+
+ function Has_Design_File (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_Unit;
+ end Has_Design_File;
+
+ function Has_Design_File_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Library_Declaration;
+ end Has_Design_File_Chain;
+
+ function Has_Library_Directory (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Library_Declaration;
+ end Has_Library_Directory;
+
+ function Has_Date (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Design_Unit
+ | Iir_Kind_Library_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Date;
+
+ function Has_Context_Items (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_Unit;
+ end Has_Context_Items;
+
+ function Has_Dependence_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_Unit;
+ end Has_Dependence_List;
+
+ function Has_Analysis_Checks_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_Unit;
+ end Has_Analysis_Checks_List;
+
+ function Has_Date_State (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_Unit;
+ end Has_Date_State;
+
+ function Has_Guarded_Target_State (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Signal_Assignment_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Guarded_Target_State;
+
+ function Has_Library_Unit (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_Unit;
+ end Has_Library_Unit;
+
+ function Has_Hash_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_Unit;
+ end Has_Hash_Chain;
+
+ function Has_Design_Unit_Source_Pos (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_Unit;
+ end Has_Design_Unit_Source_Pos;
+
+ function Has_Design_Unit_Source_Line (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_Unit;
+ end Has_Design_Unit_Source_Line;
+
+ function Has_Design_Unit_Source_Col (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_Unit;
+ end Has_Design_Unit_Source_Col;
+
+ function Has_Value (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Integer_Literal
+ | Iir_Kind_Physical_Int_Literal =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Value;
+
+ function Has_Enum_Pos (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Enumeration_Literal;
+ end Has_Enum_Pos;
+
+ function Has_Physical_Literal (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Unit_Declaration;
+ end Has_Physical_Literal;
+
+ function Has_Physical_Unit_Value (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Unit_Declaration;
+ end Has_Physical_Unit_Value;
+
+ function Has_Fp_Value (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Floating_Point_Literal
+ | Iir_Kind_Physical_Fp_Literal =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Fp_Value;
+
+ function Has_Enumeration_Decl (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Enumeration_Literal;
+ end Has_Enumeration_Decl;
+
+ function Has_Simple_Aggregate_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Simple_Aggregate;
+ end Has_Simple_Aggregate_List;
+
+ function Has_Bit_String_Base (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Bit_String_Literal;
+ end Has_Bit_String_Base;
+
+ function Has_Bit_String_0 (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Bit_String_Literal;
+ end Has_Bit_String_0;
+
+ function Has_Bit_String_1 (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Bit_String_Literal;
+ end Has_Bit_String_1;
+
+ function Has_Literal_Origin (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Integer_Literal
+ | Iir_Kind_Floating_Point_Literal
+ | Iir_Kind_String_Literal
+ | Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal
+ | Iir_Kind_Bit_String_Literal
+ | Iir_Kind_Simple_Aggregate
+ | Iir_Kind_Overflow_Literal
+ | Iir_Kind_Enumeration_Literal =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Literal_Origin;
+
+ function Has_Range_Origin (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Range_Expression;
+ end Has_Range_Origin;
+
+ function Has_Literal_Subtype (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal
+ | Iir_Kind_Simple_Aggregate
+ | Iir_Kind_Aggregate =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Literal_Subtype;
+
+ function Has_Entity_Class (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Entity_Class
+ | Iir_Kind_Attribute_Specification =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Entity_Class;
+
+ function Has_Entity_Name_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Attribute_Specification;
+ end Has_Entity_Name_List;
+
+ function Has_Attribute_Designator (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Attribute_Specification;
+ end Has_Attribute_Designator;
+
+ function Has_Attribute_Specification_Chain (K : Iir_Kind)
+ return Boolean is
+ begin
+ return K = Iir_Kind_Attribute_Specification;
+ end Has_Attribute_Specification_Chain;
+
+ function Has_Attribute_Specification (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Attribute_Value;
+ end Has_Attribute_Specification;
+
+ function Has_Signal_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Disconnection_Specification;
+ end Has_Signal_List;
+
+ function Has_Designated_Entity (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Attribute_Value;
+ end Has_Designated_Entity;
+
+ function Has_Formal (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Association_Element_By_Expression
+ | Iir_Kind_Association_Element_By_Individual
+ | Iir_Kind_Association_Element_Open
+ | Iir_Kind_Association_Element_Package =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Formal;
+
+ function Has_Actual (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Association_Element_By_Expression
+ | Iir_Kind_Association_Element_Package =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Actual;
+
+ function Has_In_Conversion (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Association_Element_By_Expression;
+ end Has_In_Conversion;
+
+ function Has_Out_Conversion (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Association_Element_By_Expression;
+ end Has_Out_Conversion;
+
+ function Has_Whole_Association_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Association_Element_By_Expression
+ | Iir_Kind_Association_Element_By_Individual
+ | Iir_Kind_Association_Element_Open
+ | Iir_Kind_Association_Element_Package =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Whole_Association_Flag;
+
+ function Has_Collapse_Signal_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Association_Element_By_Expression
+ | Iir_Kind_Association_Element_By_Individual
+ | Iir_Kind_Association_Element_Open
+ | Iir_Kind_Association_Element_Package =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Collapse_Signal_Flag;
+
+ function Has_Artificial_Flag (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Association_Element_Open;
+ end Has_Artificial_Flag;
+
+ function Has_Open_Flag (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Interface_Signal_Declaration;
+ end Has_Open_Flag;
+
+ function Has_After_Drivers_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_After_Drivers_Flag;
+
+ function Has_We_Value (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Waveform_Element;
+ end Has_We_Value;
+
+ function Has_Time (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Waveform_Element;
+ end Has_Time;
+
+ function Has_Associated_Expr (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Choice_By_Others
+ | Iir_Kind_Choice_By_Expression
+ | Iir_Kind_Choice_By_Range
+ | Iir_Kind_Choice_By_None
+ | Iir_Kind_Choice_By_Name =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Associated_Expr;
+
+ function Has_Associated_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Choice_By_Others
+ | Iir_Kind_Choice_By_Expression
+ | Iir_Kind_Choice_By_Range
+ | Iir_Kind_Choice_By_None
+ | Iir_Kind_Choice_By_Name =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Associated_Chain;
+
+ function Has_Choice_Name (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Choice_By_Name;
+ end Has_Choice_Name;
+
+ function Has_Choice_Expression (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Choice_By_Expression;
+ end Has_Choice_Expression;
+
+ function Has_Choice_Range (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Choice_By_Range;
+ end Has_Choice_Range;
+
+ function Has_Same_Alternative_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Choice_By_Others
+ | Iir_Kind_Choice_By_Expression
+ | Iir_Kind_Choice_By_Range
+ | Iir_Kind_Choice_By_None
+ | Iir_Kind_Choice_By_Name =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Same_Alternative_Flag;
+
+ function Has_Architecture (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Entity_Aspect_Entity;
+ end Has_Architecture;
+
+ function Has_Block_Specification (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Block_Configuration;
+ end Has_Block_Specification;
+
+ function Has_Prev_Block_Configuration (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Block_Configuration;
+ end Has_Prev_Block_Configuration;
+
+ function Has_Configuration_Item_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Block_Configuration;
+ end Has_Configuration_Item_Chain;
+
+ function Has_Attribute_Value_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Nature_Declaration
+ | Iir_Kind_Subnature_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Group_Declaration
+ | Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Interface_Package_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement
+ | Iir_Kind_Concurrent_Procedure_Call_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Component_Instantiation_Statement
+ | Iir_Kind_Simple_Simultaneous_Statement
+ | Iir_Kind_Signal_Assignment_Statement
+ | Iir_Kind_Null_Statement
+ | Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement
+ | Iir_Kind_Wait_Statement
+ | Iir_Kind_Variable_Assignment_Statement
+ | Iir_Kind_Return_Statement
+ | Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement
+ | Iir_Kind_Case_Statement
+ | Iir_Kind_Procedure_Call_Statement
+ | Iir_Kind_If_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Attribute_Value_Chain;
+
+ function Has_Spec_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Attribute_Value;
+ end Has_Spec_Chain;
+
+ function Has_Attribute_Value_Spec_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Attribute_Specification;
+ end Has_Attribute_Value_Spec_Chain;
+
+ function Has_Entity_Name (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Entity_Aspect_Entity
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Architecture_Body =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Entity_Name;
+
+ function Has_Package (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Package_Body;
+ end Has_Package;
+
+ function Has_Package_Body (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Package_Body;
+
+ function Has_Need_Body (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Package_Declaration;
+ end Has_Need_Body;
+
+ function Has_Block_Configuration (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Component_Configuration
+ | Iir_Kind_Configuration_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Block_Configuration;
+
+ function Has_Concurrent_Statement_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Concurrent_Statement_Chain;
+
+ function Has_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Design_File
+ | Iir_Kind_Design_Unit
+ | Iir_Kind_Library_Clause
+ | Iir_Kind_Use_Clause
+ | Iir_Kind_Waveform_Element
+ | Iir_Kind_Conditional_Waveform
+ | Iir_Kind_Association_Element_By_Expression
+ | Iir_Kind_Association_Element_By_Individual
+ | Iir_Kind_Association_Element_Open
+ | Iir_Kind_Association_Element_Package
+ | Iir_Kind_Choice_By_Others
+ | Iir_Kind_Choice_By_Expression
+ | Iir_Kind_Choice_By_Range
+ | Iir_Kind_Choice_By_None
+ | Iir_Kind_Choice_By_Name
+ | Iir_Kind_Block_Configuration
+ | Iir_Kind_Component_Configuration
+ | Iir_Kind_Entity_Class
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Record_Element_Resolution
+ | Iir_Kind_Attribute_Specification
+ | Iir_Kind_Disconnection_Specification
+ | Iir_Kind_Configuration_Specification
+ | Iir_Kind_Protected_Type_Body
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Nature_Declaration
+ | Iir_Kind_Subnature_Declaration
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Library_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Psl_Declaration
+ | Iir_Kind_Terminal_Declaration
+ | Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Interface_Package_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Psl_Default_Clock
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement
+ | Iir_Kind_Concurrent_Procedure_Call_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Component_Instantiation_Statement
+ | Iir_Kind_Simple_Simultaneous_Statement
+ | Iir_Kind_Signal_Assignment_Statement
+ | Iir_Kind_Null_Statement
+ | Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement
+ | Iir_Kind_Wait_Statement
+ | Iir_Kind_Variable_Assignment_Statement
+ | Iir_Kind_Return_Statement
+ | Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement
+ | Iir_Kind_Case_Statement
+ | Iir_Kind_Procedure_Call_Statement
+ | Iir_Kind_If_Statement
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Chain;
+
+ function Has_Port_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Block_Header
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Component_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Port_Chain;
+
+ function Has_Generic_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Block_Header
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Package_Header
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Interface_Package_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Generic_Chain;
+
+ function Has_Type (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Error
+ | Iir_Kind_Integer_Literal
+ | Iir_Kind_Floating_Point_Literal
+ | Iir_Kind_Null_Literal
+ | Iir_Kind_String_Literal
+ | Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal
+ | Iir_Kind_Bit_String_Literal
+ | Iir_Kind_Simple_Aggregate
+ | Iir_Kind_Overflow_Literal
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Record_Element_Constraint
+ | Iir_Kind_Range_Expression
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Element_Declaration
+ | Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Identity_Operator
+ | Iir_Kind_Negation_Operator
+ | Iir_Kind_Absolute_Operator
+ | Iir_Kind_Not_Operator
+ | Iir_Kind_Condition_Operator
+ | Iir_Kind_Reduction_And_Operator
+ | Iir_Kind_Reduction_Or_Operator
+ | Iir_Kind_Reduction_Nand_Operator
+ | Iir_Kind_Reduction_Nor_Operator
+ | Iir_Kind_Reduction_Xor_Operator
+ | Iir_Kind_Reduction_Xnor_Operator
+ | Iir_Kind_And_Operator
+ | Iir_Kind_Or_Operator
+ | Iir_Kind_Nand_Operator
+ | Iir_Kind_Nor_Operator
+ | Iir_Kind_Xor_Operator
+ | Iir_Kind_Xnor_Operator
+ | Iir_Kind_Equality_Operator
+ | Iir_Kind_Inequality_Operator
+ | Iir_Kind_Less_Than_Operator
+ | Iir_Kind_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Greater_Than_Operator
+ | Iir_Kind_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Equality_Operator
+ | Iir_Kind_Match_Inequality_Operator
+ | Iir_Kind_Match_Less_Than_Operator
+ | Iir_Kind_Match_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Greater_Than_Operator
+ | Iir_Kind_Match_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Sll_Operator
+ | Iir_Kind_Sla_Operator
+ | Iir_Kind_Srl_Operator
+ | Iir_Kind_Sra_Operator
+ | Iir_Kind_Rol_Operator
+ | Iir_Kind_Ror_Operator
+ | Iir_Kind_Addition_Operator
+ | Iir_Kind_Substraction_Operator
+ | Iir_Kind_Concatenation_Operator
+ | Iir_Kind_Multiplication_Operator
+ | Iir_Kind_Division_Operator
+ | Iir_Kind_Modulus_Operator
+ | Iir_Kind_Remainder_Operator
+ | Iir_Kind_Exponentiation_Operator
+ | Iir_Kind_Function_Call
+ | Iir_Kind_Aggregate
+ | Iir_Kind_Parenthesis_Expression
+ | Iir_Kind_Qualified_Expression
+ | Iir_Kind_Type_Conversion
+ | Iir_Kind_Allocator_By_Expression
+ | Iir_Kind_Allocator_By_Subtype
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Psl_Expression
+ | Iir_Kind_Return_Statement
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Operator_Symbol
+ | Iir_Kind_Selected_By_All_Name
+ | Iir_Kind_Parenthesis_Name
+ | Iir_Kind_Base_Attribute
+ | Iir_Kind_Left_Type_Attribute
+ | Iir_Kind_Right_Type_Attribute
+ | Iir_Kind_High_Type_Attribute
+ | Iir_Kind_Low_Type_Attribute
+ | Iir_Kind_Ascending_Type_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute
+ | Iir_Kind_Pos_Attribute
+ | Iir_Kind_Val_Attribute
+ | Iir_Kind_Succ_Attribute
+ | Iir_Kind_Pred_Attribute
+ | Iir_Kind_Leftof_Attribute
+ | Iir_Kind_Rightof_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Event_Attribute
+ | Iir_Kind_Active_Attribute
+ | Iir_Kind_Last_Event_Attribute
+ | Iir_Kind_Last_Active_Attribute
+ | Iir_Kind_Last_Value_Attribute
+ | Iir_Kind_Driving_Attribute
+ | Iir_Kind_Driving_Value_Attribute
+ | Iir_Kind_Simple_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute
+ | Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Left_Array_Attribute
+ | Iir_Kind_Right_Array_Attribute
+ | Iir_Kind_High_Array_Attribute
+ | Iir_Kind_Low_Array_Attribute
+ | Iir_Kind_Length_Array_Attribute
+ | Iir_Kind_Ascending_Array_Attribute
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute
+ | Iir_Kind_Attribute_Name =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Type;
+
+ function Has_Subtype_Indication (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Element_Declaration
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Allocator_By_Subtype =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Subtype_Indication;
+
+ function Has_Discrete_Range (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Iterator_Declaration;
+ end Has_Discrete_Range;
+
+ function Has_Type_Definition (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Type_Definition;
+
+ function Has_Subtype_Definition (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Anonymous_Type_Declaration;
+ end Has_Subtype_Definition;
+
+ function Has_Nature (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Nature_Declaration
+ | Iir_Kind_Subnature_Declaration
+ | Iir_Kind_Terminal_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Nature;
+
+ function Has_Mode (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_File_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Mode;
+
+ function Has_Signal_Kind (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Signal_Kind;
+
+ function Has_Base_Name (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Attribute_Value
+ | Iir_Kind_Function_Call
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Operator_Symbol
+ | Iir_Kind_Selected_By_All_Name
+ | Iir_Kind_Left_Type_Attribute
+ | Iir_Kind_Right_Type_Attribute
+ | Iir_Kind_High_Type_Attribute
+ | Iir_Kind_Low_Type_Attribute
+ | Iir_Kind_Ascending_Type_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute
+ | Iir_Kind_Pos_Attribute
+ | Iir_Kind_Val_Attribute
+ | Iir_Kind_Succ_Attribute
+ | Iir_Kind_Pred_Attribute
+ | Iir_Kind_Leftof_Attribute
+ | Iir_Kind_Rightof_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Simple_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute
+ | Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Left_Array_Attribute
+ | Iir_Kind_Right_Array_Attribute
+ | Iir_Kind_High_Array_Attribute
+ | Iir_Kind_Low_Array_Attribute
+ | Iir_Kind_Length_Array_Attribute
+ | Iir_Kind_Ascending_Array_Attribute
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute
+ | Iir_Kind_Attribute_Name =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Base_Name;
+
+ function Has_Interface_Declaration_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Interface_Declaration_Chain;
+
+ function Has_Subprogram_Specification (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Subprogram_Specification;
+
+ function Has_Sequential_Statement_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_If_Statement
+ | Iir_Kind_Elsif =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Sequential_Statement_Chain;
+
+ function Has_Subprogram_Body (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Subprogram_Body;
+
+ function Has_Overload_Number (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Overload_Number;
+
+ function Has_Subprogram_Depth (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Subprogram_Depth;
+
+ function Has_Subprogram_Hash (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Subprogram_Hash;
+
+ function Has_Impure_Depth (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Impure_Depth;
+
+ function Has_Return_Type (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Return_Type;
+
+ function Has_Implicit_Definition (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Implicit_Definition;
+
+ function Has_Type_Reference (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Type_Reference;
+
+ function Has_Default_Value (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Default_Value;
+
+ function Has_Deferred_Declaration (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Constant_Declaration;
+ end Has_Deferred_Declaration;
+
+ function Has_Deferred_Declaration_Flag (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Constant_Declaration;
+ end Has_Deferred_Declaration_Flag;
+
+ function Has_Shared_Flag (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Variable_Declaration;
+ end Has_Shared_Flag;
+
+ function Has_Design_Unit (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Design_Unit;
+
+ function Has_Block_Statement (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Guard_Signal_Declaration;
+ end Has_Block_Statement;
+
+ function Has_Signal_Driver (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Signal_Declaration;
+ end Has_Signal_Driver;
+
+ function Has_Declaration_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Block_Configuration
+ | Iir_Kind_Protected_Type_Declaration
+ | Iir_Kind_Protected_Type_Body
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_Interface_Package_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Declaration_Chain;
+
+ function Has_File_Logical_Name (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_File_Declaration;
+ end Has_File_Logical_Name;
+
+ function Has_File_Open_Kind (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_File_Declaration;
+ end Has_File_Open_Kind;
+
+ function Has_Element_Position (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Record_Element_Constraint
+ | Iir_Kind_Element_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Element_Position;
+
+ function Has_Element_Declaration (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Record_Element_Constraint;
+ end Has_Element_Declaration;
+
+ function Has_Selected_Element (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Selected_Element;
+ end Has_Selected_Element;
+
+ function Has_Use_Clause_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Use_Clause;
+ end Has_Use_Clause_Chain;
+
+ function Has_Selected_Name (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Use_Clause;
+ end Has_Selected_Name;
+
+ function Has_Type_Declarator (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Error
+ | Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Incomplete_Type_Definition
+ | Iir_Kind_File_Type_Definition
+ | Iir_Kind_Protected_Type_Declaration
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Access_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Physical_Type_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Type_Declarator;
+
+ function Has_Enumeration_Literal_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Enumeration_Type_Definition;
+ end Has_Enumeration_Literal_List;
+
+ function Has_Entity_Class_Entry_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Group_Template_Declaration;
+ end Has_Entity_Class_Entry_Chain;
+
+ function Has_Group_Constituent_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Group_Declaration;
+ end Has_Group_Constituent_List;
+
+ function Has_Unit_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Physical_Type_Definition;
+ end Has_Unit_Chain;
+
+ function Has_Primary_Unit (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Physical_Type_Definition;
+ end Has_Primary_Unit;
+
+ function Has_Identifier (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Design_Unit
+ | Iir_Kind_Library_Clause
+ | Iir_Kind_Record_Element_Constraint
+ | Iir_Kind_Record_Element_Resolution
+ | Iir_Kind_Protected_Type_Body
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Nature_Declaration
+ | Iir_Kind_Subnature_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Library_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration
+ | Iir_Kind_Element_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Psl_Declaration
+ | Iir_Kind_Terminal_Declaration
+ | Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Interface_Package_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Psl_Default_Clock
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement
+ | Iir_Kind_Concurrent_Procedure_Call_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Component_Instantiation_Statement
+ | Iir_Kind_Simple_Simultaneous_Statement
+ | Iir_Kind_Signal_Assignment_Statement
+ | Iir_Kind_Null_Statement
+ | Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement
+ | Iir_Kind_Wait_Statement
+ | Iir_Kind_Variable_Assignment_Statement
+ | Iir_Kind_Return_Statement
+ | Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement
+ | Iir_Kind_Case_Statement
+ | Iir_Kind_Procedure_Call_Statement
+ | Iir_Kind_If_Statement
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Operator_Symbol
+ | Iir_Kind_Attribute_Name =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Identifier;
+
+ function Has_Label (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Psl_Default_Clock
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement
+ | Iir_Kind_Concurrent_Procedure_Call_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Component_Instantiation_Statement
+ | Iir_Kind_Simple_Simultaneous_Statement
+ | Iir_Kind_Signal_Assignment_Statement
+ | Iir_Kind_Null_Statement
+ | Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement
+ | Iir_Kind_Wait_Statement
+ | Iir_Kind_Variable_Assignment_Statement
+ | Iir_Kind_Return_Statement
+ | Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement
+ | Iir_Kind_Case_Statement
+ | Iir_Kind_Procedure_Call_Statement
+ | Iir_Kind_If_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Label;
+
+ function Has_Visible_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Record_Element_Constraint
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Nature_Declaration
+ | Iir_Kind_Subnature_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Library_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration
+ | Iir_Kind_Element_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Psl_Declaration
+ | Iir_Kind_Terminal_Declaration
+ | Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Interface_Package_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement
+ | Iir_Kind_Concurrent_Procedure_Call_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Component_Instantiation_Statement
+ | Iir_Kind_Simple_Simultaneous_Statement
+ | Iir_Kind_Signal_Assignment_Statement
+ | Iir_Kind_Null_Statement
+ | Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement
+ | Iir_Kind_Wait_Statement
+ | Iir_Kind_Variable_Assignment_Statement
+ | Iir_Kind_Return_Statement
+ | Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement
+ | Iir_Kind_Case_Statement
+ | Iir_Kind_Procedure_Call_Statement
+ | Iir_Kind_If_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Visible_Flag;
+
+ function Has_Range_Constraint (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Subtype_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Range_Constraint;
+
+ function Has_Direction (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Range_Expression;
+ end Has_Direction;
+
+ function Has_Left_Limit (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Range_Expression;
+ end Has_Left_Limit;
+
+ function Has_Right_Limit (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Range_Expression;
+ end Has_Right_Limit;
+
+ function Has_Base_Type (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Error
+ | Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Incomplete_Type_Definition
+ | Iir_Kind_File_Type_Definition
+ | Iir_Kind_Protected_Type_Declaration
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Access_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Physical_Type_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Base_Type;
+
+ function Has_Resolution_Indication (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Array_Element_Resolution
+ | Iir_Kind_Record_Element_Resolution
+ | Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Subtype_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Resolution_Indication;
+
+ function Has_Record_Element_Resolution_Chain (K : Iir_Kind)
+ return Boolean is
+ begin
+ return K = Iir_Kind_Record_Resolution;
+ end Has_Record_Element_Resolution_Chain;
+
+ function Has_Tolerance (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Subtype_Definition
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Simple_Simultaneous_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Tolerance;
+
+ function Has_Plus_Terminal (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Plus_Terminal;
+
+ function Has_Minus_Terminal (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Minus_Terminal;
+
+ function Has_Simultaneous_Left (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Simple_Simultaneous_Statement;
+ end Has_Simultaneous_Left;
+
+ function Has_Simultaneous_Right (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Simple_Simultaneous_Statement;
+ end Has_Simultaneous_Right;
+
+ function Has_Text_File_Flag (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_File_Type_Definition;
+ end Has_Text_File_Flag;
+
+ function Has_Only_Characters_Flag (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Enumeration_Type_Definition;
+ end Has_Only_Characters_Flag;
+
+ function Has_Type_Staticness (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Error
+ | Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Incomplete_Type_Definition
+ | Iir_Kind_File_Type_Definition
+ | Iir_Kind_Protected_Type_Declaration
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Access_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Physical_Type_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Type_Staticness;
+
+ function Has_Constraint_State (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Constraint_State;
+
+ function Has_Index_Subtype_List (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Index_Subtype_List;
+
+ function Has_Index_Subtype_Definition_List (K : Iir_Kind)
+ return Boolean is
+ begin
+ return K = Iir_Kind_Array_Type_Definition;
+ end Has_Index_Subtype_Definition_List;
+
+ function Has_Element_Subtype_Indication (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Array_Type_Definition;
+ end Has_Element_Subtype_Indication;
+
+ function Has_Element_Subtype (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Element_Subtype;
+
+ function Has_Index_Constraint_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Array_Subtype_Definition;
+ end Has_Index_Constraint_List;
+
+ function Has_Array_Element_Constraint (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Array_Subtype_Definition;
+ end Has_Array_Element_Constraint;
+
+ function Has_Elements_Declaration_List (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Record_Subtype_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Elements_Declaration_List;
+
+ function Has_Designated_Type (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Designated_Type;
+
+ function Has_Designated_Subtype_Indication (K : Iir_Kind)
+ return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Access_Subtype_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Designated_Subtype_Indication;
+
+ function Has_Index_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Indexed_Name;
+ end Has_Index_List;
+
+ function Has_Reference (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Scalar_Nature_Definition;
+ end Has_Reference;
+
+ function Has_Nature_Declarator (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Scalar_Nature_Definition;
+ end Has_Nature_Declarator;
+
+ function Has_Across_Type (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Scalar_Nature_Definition;
+ end Has_Across_Type;
+
+ function Has_Through_Type (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Scalar_Nature_Definition;
+ end Has_Through_Type;
+
+ function Has_Target (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Signal_Assignment_Statement
+ | Iir_Kind_Variable_Assignment_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Target;
+
+ function Has_Waveform_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Conditional_Waveform
+ | Iir_Kind_Signal_Assignment_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Waveform_Chain;
+
+ function Has_Guard (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Guard;
+
+ function Has_Delay_Mechanism (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Signal_Assignment_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Delay_Mechanism;
+
+ function Has_Reject_Time_Expression (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Signal_Assignment_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Reject_Time_Expression;
+
+ function Has_Sensitivity_List (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Wait_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Sensitivity_List;
+
+ function Has_Process_Origin (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Process_Origin;
+
+ function Has_Condition_Clause (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Wait_Statement;
+ end Has_Condition_Clause;
+
+ function Has_Timeout_Clause (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Wait_Statement;
+ end Has_Timeout_Clause;
+
+ function Has_Postponed_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Concurrent_Procedure_Call_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Postponed_Flag;
+
+ function Has_Callees_List (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Callees_List;
+
+ function Has_Passive_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Passive_Flag;
+
+ function Has_Resolution_Function_Flag (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Function_Declaration;
+ end Has_Resolution_Function_Flag;
+
+ function Has_Wait_State (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Wait_State;
+
+ function Has_All_Sensitized_State (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_All_Sensitized_State;
+
+ function Has_Seen_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Seen_Flag;
+
+ function Has_Pure_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Pure_Flag;
+
+ function Has_Foreign_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Architecture_Body
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Foreign_Flag;
+
+ function Has_Resolved_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Error
+ | Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Incomplete_Type_Definition
+ | Iir_Kind_File_Type_Definition
+ | Iir_Kind_Protected_Type_Declaration
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Access_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Physical_Type_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Resolved_Flag;
+
+ function Has_Signal_Type_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Error
+ | Iir_Kind_Access_Type_Definition
+ | Iir_Kind_Incomplete_Type_Definition
+ | Iir_Kind_File_Type_Definition
+ | Iir_Kind_Protected_Type_Declaration
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Access_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Physical_Type_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Signal_Type_Flag;
+
+ function Has_Has_Signal_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Error
+ | Iir_Kind_Incomplete_Type_Definition
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Enumeration_Type_Definition
+ | Iir_Kind_Integer_Type_Definition
+ | Iir_Kind_Floating_Type_Definition
+ | Iir_Kind_Physical_Type_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Has_Signal_Flag;
+
+ function Has_Purity_State (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Procedure_Declaration;
+ end Has_Purity_State;
+
+ function Has_Elab_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Design_File
+ | Iir_Kind_Design_Unit =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Elab_Flag;
+
+ function Has_Index_Constraint_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Array_Type_Definition
+ | Iir_Kind_Array_Subtype_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Index_Constraint_Flag;
+
+ function Has_Assertion_Condition (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Assertion_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Assertion_Condition;
+
+ function Has_Report_Expression (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement
+ | Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Report_Expression;
+
+ function Has_Severity_Expression (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement
+ | Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Severity_Expression;
+
+ function Has_Instantiated_Unit (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Component_Instantiation_Statement;
+ end Has_Instantiated_Unit;
+
+ function Has_Generic_Map_Aspect_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Block_Header
+ | Iir_Kind_Binding_Indication
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Package_Header
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Interface_Package_Declaration
+ | Iir_Kind_Component_Instantiation_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Generic_Map_Aspect_Chain;
+
+ function Has_Port_Map_Aspect_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Block_Header
+ | Iir_Kind_Binding_Indication
+ | Iir_Kind_Component_Instantiation_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Port_Map_Aspect_Chain;
+
+ function Has_Configuration_Name (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Entity_Aspect_Configuration;
+ end Has_Configuration_Name;
+
+ function Has_Component_Configuration (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Component_Instantiation_Statement;
+ end Has_Component_Configuration;
+
+ function Has_Configuration_Specification (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Component_Instantiation_Statement;
+ end Has_Configuration_Specification;
+
+ function Has_Default_Binding_Indication (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Component_Instantiation_Statement;
+ end Has_Default_Binding_Indication;
+
+ function Has_Default_Configuration_Declaration (K : Iir_Kind)
+ return Boolean is
+ begin
+ return K = Iir_Kind_Architecture_Body;
+ end Has_Default_Configuration_Declaration;
+
+ function Has_Expression (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Attribute_Specification
+ | Iir_Kind_Disconnection_Specification
+ | Iir_Kind_Parenthesis_Expression
+ | Iir_Kind_Qualified_Expression
+ | Iir_Kind_Type_Conversion
+ | Iir_Kind_Allocator_By_Expression
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Variable_Assignment_Statement
+ | Iir_Kind_Return_Statement
+ | Iir_Kind_Case_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Expression;
+
+ function Has_Allocator_Designated_Type (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Allocator_By_Expression
+ | Iir_Kind_Allocator_By_Subtype =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Allocator_Designated_Type;
+
+ function Has_Selected_Waveform_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Concurrent_Selected_Signal_Assignment;
+ end Has_Selected_Waveform_Chain;
+
+ function Has_Conditional_Waveform_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Concurrent_Conditional_Signal_Assignment;
+ end Has_Conditional_Waveform_Chain;
+
+ function Has_Guard_Expression (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Guard_Signal_Declaration;
+ end Has_Guard_Expression;
+
+ function Has_Guard_Decl (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Block_Statement;
+ end Has_Guard_Decl;
+
+ function Has_Guard_Sensitivity_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Guard_Signal_Declaration;
+ end Has_Guard_Sensitivity_List;
+
+ function Has_Block_Block_Configuration (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Block_Statement;
+ end Has_Block_Block_Configuration;
+
+ function Has_Package_Header (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Package_Declaration;
+ end Has_Package_Header;
+
+ function Has_Block_Header (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Block_Statement;
+ end Has_Block_Header;
+
+ function Has_Uninstantiated_Package_Name (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Interface_Package_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Uninstantiated_Package_Name;
+
+ function Has_Generate_Block_Configuration (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Generate_Statement;
+ end Has_Generate_Block_Configuration;
+
+ function Has_Generation_Scheme (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Generate_Statement;
+ end Has_Generation_Scheme;
+
+ function Has_Condition (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Conditional_Waveform
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement
+ | Iir_Kind_If_Statement
+ | Iir_Kind_Elsif =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Condition;
+
+ function Has_Else_Clause (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_If_Statement
+ | Iir_Kind_Elsif =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Else_Clause;
+
+ function Has_Parameter_Specification (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_For_Loop_Statement;
+ end Has_Parameter_Specification;
+
+ function Has_Parent (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Design_File
+ | Iir_Kind_Design_Unit
+ | Iir_Kind_Library_Clause
+ | Iir_Kind_Use_Clause
+ | Iir_Kind_Choice_By_Others
+ | Iir_Kind_Choice_By_Expression
+ | Iir_Kind_Choice_By_Range
+ | Iir_Kind_Choice_By_None
+ | Iir_Kind_Choice_By_Name
+ | Iir_Kind_Block_Configuration
+ | Iir_Kind_Component_Configuration
+ | Iir_Kind_Record_Element_Constraint
+ | Iir_Kind_Attribute_Specification
+ | Iir_Kind_Disconnection_Specification
+ | Iir_Kind_Configuration_Specification
+ | Iir_Kind_Protected_Type_Body
+ | Iir_Kind_Type_Declaration
+ | Iir_Kind_Anonymous_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Nature_Declaration
+ | Iir_Kind_Subnature_Declaration
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Psl_Declaration
+ | Iir_Kind_Terminal_Declaration
+ | Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Interface_Package_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Concurrent_Conditional_Signal_Assignment
+ | Iir_Kind_Concurrent_Selected_Signal_Assignment
+ | Iir_Kind_Concurrent_Assertion_Statement
+ | Iir_Kind_Psl_Default_Clock
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement
+ | Iir_Kind_Concurrent_Procedure_Call_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_Component_Instantiation_Statement
+ | Iir_Kind_Simple_Simultaneous_Statement
+ | Iir_Kind_Signal_Assignment_Statement
+ | Iir_Kind_Null_Statement
+ | Iir_Kind_Assertion_Statement
+ | Iir_Kind_Report_Statement
+ | Iir_Kind_Wait_Statement
+ | Iir_Kind_Variable_Assignment_Statement
+ | Iir_Kind_Return_Statement
+ | Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement
+ | Iir_Kind_Case_Statement
+ | Iir_Kind_Procedure_Call_Statement
+ | Iir_Kind_If_Statement
+ | Iir_Kind_Elsif =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Parent;
+
+ function Has_Loop_Label (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Next_Statement
+ | Iir_Kind_Exit_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Loop_Label;
+
+ function Has_Component_Name (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Component_Configuration
+ | Iir_Kind_Configuration_Specification =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Component_Name;
+
+ function Has_Instantiation_List (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Component_Configuration
+ | Iir_Kind_Configuration_Specification =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Instantiation_List;
+
+ function Has_Entity_Aspect (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Binding_Indication;
+ end Has_Entity_Aspect;
+
+ function Has_Default_Entity_Aspect (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Binding_Indication;
+ end Has_Default_Entity_Aspect;
+
+ function Has_Default_Generic_Map_Aspect_Chain (K : Iir_Kind)
+ return Boolean is
+ begin
+ return K = Iir_Kind_Binding_Indication;
+ end Has_Default_Generic_Map_Aspect_Chain;
+
+ function Has_Default_Port_Map_Aspect_Chain (K : Iir_Kind)
+ return Boolean is
+ begin
+ return K = Iir_Kind_Binding_Indication;
+ end Has_Default_Port_Map_Aspect_Chain;
+
+ function Has_Binding_Indication (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Component_Configuration
+ | Iir_Kind_Configuration_Specification =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Binding_Indication;
+
+ function Has_Named_Entity (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Character_Literal
+ | Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Operator_Symbol
+ | Iir_Kind_Selected_By_All_Name
+ | Iir_Kind_Parenthesis_Name
+ | Iir_Kind_Attribute_Name =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Named_Entity;
+
+ function Has_Alias_Declaration (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Character_Literal
+ | Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Operator_Symbol =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Alias_Declaration;
+
+ function Has_Expr_Staticness (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Error
+ | Iir_Kind_Integer_Literal
+ | Iir_Kind_Floating_Point_Literal
+ | Iir_Kind_Null_Literal
+ | Iir_Kind_String_Literal
+ | Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal
+ | Iir_Kind_Bit_String_Literal
+ | Iir_Kind_Simple_Aggregate
+ | Iir_Kind_Overflow_Literal
+ | Iir_Kind_Attribute_Value
+ | Iir_Kind_Range_Expression
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Identity_Operator
+ | Iir_Kind_Negation_Operator
+ | Iir_Kind_Absolute_Operator
+ | Iir_Kind_Not_Operator
+ | Iir_Kind_Condition_Operator
+ | Iir_Kind_Reduction_And_Operator
+ | Iir_Kind_Reduction_Or_Operator
+ | Iir_Kind_Reduction_Nand_Operator
+ | Iir_Kind_Reduction_Nor_Operator
+ | Iir_Kind_Reduction_Xor_Operator
+ | Iir_Kind_Reduction_Xnor_Operator
+ | Iir_Kind_And_Operator
+ | Iir_Kind_Or_Operator
+ | Iir_Kind_Nand_Operator
+ | Iir_Kind_Nor_Operator
+ | Iir_Kind_Xor_Operator
+ | Iir_Kind_Xnor_Operator
+ | Iir_Kind_Equality_Operator
+ | Iir_Kind_Inequality_Operator
+ | Iir_Kind_Less_Than_Operator
+ | Iir_Kind_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Greater_Than_Operator
+ | Iir_Kind_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Equality_Operator
+ | Iir_Kind_Match_Inequality_Operator
+ | Iir_Kind_Match_Less_Than_Operator
+ | Iir_Kind_Match_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Greater_Than_Operator
+ | Iir_Kind_Match_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Sll_Operator
+ | Iir_Kind_Sla_Operator
+ | Iir_Kind_Srl_Operator
+ | Iir_Kind_Sra_Operator
+ | Iir_Kind_Rol_Operator
+ | Iir_Kind_Ror_Operator
+ | Iir_Kind_Addition_Operator
+ | Iir_Kind_Substraction_Operator
+ | Iir_Kind_Concatenation_Operator
+ | Iir_Kind_Multiplication_Operator
+ | Iir_Kind_Division_Operator
+ | Iir_Kind_Modulus_Operator
+ | Iir_Kind_Remainder_Operator
+ | Iir_Kind_Exponentiation_Operator
+ | Iir_Kind_Function_Call
+ | Iir_Kind_Aggregate
+ | Iir_Kind_Parenthesis_Expression
+ | Iir_Kind_Qualified_Expression
+ | Iir_Kind_Type_Conversion
+ | Iir_Kind_Allocator_By_Expression
+ | Iir_Kind_Allocator_By_Subtype
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Selected_By_All_Name
+ | Iir_Kind_Left_Type_Attribute
+ | Iir_Kind_Right_Type_Attribute
+ | Iir_Kind_High_Type_Attribute
+ | Iir_Kind_Low_Type_Attribute
+ | Iir_Kind_Ascending_Type_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute
+ | Iir_Kind_Pos_Attribute
+ | Iir_Kind_Val_Attribute
+ | Iir_Kind_Succ_Attribute
+ | Iir_Kind_Pred_Attribute
+ | Iir_Kind_Leftof_Attribute
+ | Iir_Kind_Rightof_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Event_Attribute
+ | Iir_Kind_Active_Attribute
+ | Iir_Kind_Last_Event_Attribute
+ | Iir_Kind_Last_Active_Attribute
+ | Iir_Kind_Last_Value_Attribute
+ | Iir_Kind_Driving_Attribute
+ | Iir_Kind_Driving_Value_Attribute
+ | Iir_Kind_Simple_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute
+ | Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Left_Array_Attribute
+ | Iir_Kind_Right_Array_Attribute
+ | Iir_Kind_High_Array_Attribute
+ | Iir_Kind_Low_Array_Attribute
+ | Iir_Kind_Length_Array_Attribute
+ | Iir_Kind_Ascending_Array_Attribute
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute
+ | Iir_Kind_Attribute_Name =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Expr_Staticness;
+
+ function Has_Error_Origin (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Error;
+ end Has_Error_Origin;
+
+ function Has_Operand (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Identity_Operator
+ | Iir_Kind_Negation_Operator
+ | Iir_Kind_Absolute_Operator
+ | Iir_Kind_Not_Operator
+ | Iir_Kind_Condition_Operator
+ | Iir_Kind_Reduction_And_Operator
+ | Iir_Kind_Reduction_Or_Operator
+ | Iir_Kind_Reduction_Nand_Operator
+ | Iir_Kind_Reduction_Nor_Operator
+ | Iir_Kind_Reduction_Xor_Operator
+ | Iir_Kind_Reduction_Xnor_Operator =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Operand;
+
+ function Has_Left (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_And_Operator
+ | Iir_Kind_Or_Operator
+ | Iir_Kind_Nand_Operator
+ | Iir_Kind_Nor_Operator
+ | Iir_Kind_Xor_Operator
+ | Iir_Kind_Xnor_Operator
+ | Iir_Kind_Equality_Operator
+ | Iir_Kind_Inequality_Operator
+ | Iir_Kind_Less_Than_Operator
+ | Iir_Kind_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Greater_Than_Operator
+ | Iir_Kind_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Equality_Operator
+ | Iir_Kind_Match_Inequality_Operator
+ | Iir_Kind_Match_Less_Than_Operator
+ | Iir_Kind_Match_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Greater_Than_Operator
+ | Iir_Kind_Match_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Sll_Operator
+ | Iir_Kind_Sla_Operator
+ | Iir_Kind_Srl_Operator
+ | Iir_Kind_Sra_Operator
+ | Iir_Kind_Rol_Operator
+ | Iir_Kind_Ror_Operator
+ | Iir_Kind_Addition_Operator
+ | Iir_Kind_Substraction_Operator
+ | Iir_Kind_Concatenation_Operator
+ | Iir_Kind_Multiplication_Operator
+ | Iir_Kind_Division_Operator
+ | Iir_Kind_Modulus_Operator
+ | Iir_Kind_Remainder_Operator
+ | Iir_Kind_Exponentiation_Operator =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Left;
+
+ function Has_Right (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_And_Operator
+ | Iir_Kind_Or_Operator
+ | Iir_Kind_Nand_Operator
+ | Iir_Kind_Nor_Operator
+ | Iir_Kind_Xor_Operator
+ | Iir_Kind_Xnor_Operator
+ | Iir_Kind_Equality_Operator
+ | Iir_Kind_Inequality_Operator
+ | Iir_Kind_Less_Than_Operator
+ | Iir_Kind_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Greater_Than_Operator
+ | Iir_Kind_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Equality_Operator
+ | Iir_Kind_Match_Inequality_Operator
+ | Iir_Kind_Match_Less_Than_Operator
+ | Iir_Kind_Match_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Greater_Than_Operator
+ | Iir_Kind_Match_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Sll_Operator
+ | Iir_Kind_Sla_Operator
+ | Iir_Kind_Srl_Operator
+ | Iir_Kind_Sra_Operator
+ | Iir_Kind_Rol_Operator
+ | Iir_Kind_Ror_Operator
+ | Iir_Kind_Addition_Operator
+ | Iir_Kind_Substraction_Operator
+ | Iir_Kind_Concatenation_Operator
+ | Iir_Kind_Multiplication_Operator
+ | Iir_Kind_Division_Operator
+ | Iir_Kind_Modulus_Operator
+ | Iir_Kind_Remainder_Operator
+ | Iir_Kind_Exponentiation_Operator =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Right;
+
+ function Has_Unit_Name (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Physical_Int_Literal
+ | Iir_Kind_Physical_Fp_Literal =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Unit_Name;
+
+ function Has_Name (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Object_Alias_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Name;
+
+ function Has_Group_Template_Name (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Group_Declaration;
+ end Has_Group_Template_Name;
+
+ function Has_Name_Staticness (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Attribute_Value
+ | Iir_Kind_Unit_Declaration
+ | Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration
+ | Iir_Kind_Function_Call
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Character_Literal
+ | Iir_Kind_Simple_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Left_Type_Attribute
+ | Iir_Kind_Right_Type_Attribute
+ | Iir_Kind_High_Type_Attribute
+ | Iir_Kind_Low_Type_Attribute
+ | Iir_Kind_Ascending_Type_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute
+ | Iir_Kind_Pos_Attribute
+ | Iir_Kind_Val_Attribute
+ | Iir_Kind_Succ_Attribute
+ | Iir_Kind_Pred_Attribute
+ | Iir_Kind_Leftof_Attribute
+ | Iir_Kind_Rightof_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Event_Attribute
+ | Iir_Kind_Active_Attribute
+ | Iir_Kind_Last_Event_Attribute
+ | Iir_Kind_Last_Active_Attribute
+ | Iir_Kind_Last_Value_Attribute
+ | Iir_Kind_Driving_Attribute
+ | Iir_Kind_Driving_Value_Attribute
+ | Iir_Kind_Simple_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute
+ | Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Left_Array_Attribute
+ | Iir_Kind_Right_Array_Attribute
+ | Iir_Kind_High_Array_Attribute
+ | Iir_Kind_Low_Array_Attribute
+ | Iir_Kind_Length_Array_Attribute
+ | Iir_Kind_Ascending_Array_Attribute
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute
+ | Iir_Kind_Attribute_Name =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Name_Staticness;
+
+ function Has_Prefix (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Procedure_Call
+ | Iir_Kind_Function_Call
+ | Iir_Kind_Selected_Element
+ | Iir_Kind_Dereference
+ | Iir_Kind_Implicit_Dereference
+ | Iir_Kind_Slice_Name
+ | Iir_Kind_Indexed_Name
+ | Iir_Kind_Selected_Name
+ | Iir_Kind_Selected_By_All_Name
+ | Iir_Kind_Parenthesis_Name
+ | Iir_Kind_Base_Attribute
+ | Iir_Kind_Left_Type_Attribute
+ | Iir_Kind_Right_Type_Attribute
+ | Iir_Kind_High_Type_Attribute
+ | Iir_Kind_Low_Type_Attribute
+ | Iir_Kind_Ascending_Type_Attribute
+ | Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute
+ | Iir_Kind_Pos_Attribute
+ | Iir_Kind_Val_Attribute
+ | Iir_Kind_Succ_Attribute
+ | Iir_Kind_Pred_Attribute
+ | Iir_Kind_Leftof_Attribute
+ | Iir_Kind_Rightof_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Event_Attribute
+ | Iir_Kind_Active_Attribute
+ | Iir_Kind_Last_Event_Attribute
+ | Iir_Kind_Last_Active_Attribute
+ | Iir_Kind_Last_Value_Attribute
+ | Iir_Kind_Driving_Attribute
+ | Iir_Kind_Driving_Value_Attribute
+ | Iir_Kind_Simple_Name_Attribute
+ | Iir_Kind_Instance_Name_Attribute
+ | Iir_Kind_Path_Name_Attribute
+ | Iir_Kind_Left_Array_Attribute
+ | Iir_Kind_Right_Array_Attribute
+ | Iir_Kind_High_Array_Attribute
+ | Iir_Kind_Low_Array_Attribute
+ | Iir_Kind_Length_Array_Attribute
+ | Iir_Kind_Ascending_Array_Attribute
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute
+ | Iir_Kind_Attribute_Name =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Prefix;
+
+ function Has_Signature_Prefix (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Signature;
+ end Has_Signature_Prefix;
+
+ function Has_Slice_Subtype (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Slice_Name;
+ end Has_Slice_Subtype;
+
+ function Has_Suffix (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Slice_Name;
+ end Has_Suffix;
+
+ function Has_Index_Subtype (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Left_Array_Attribute
+ | Iir_Kind_Right_Array_Attribute
+ | Iir_Kind_High_Array_Attribute
+ | Iir_Kind_Low_Array_Attribute
+ | Iir_Kind_Length_Array_Attribute
+ | Iir_Kind_Ascending_Array_Attribute
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Index_Subtype;
+
+ function Has_Parameter (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Image_Attribute
+ | Iir_Kind_Value_Attribute
+ | Iir_Kind_Pos_Attribute
+ | Iir_Kind_Val_Attribute
+ | Iir_Kind_Succ_Attribute
+ | Iir_Kind_Pred_Attribute
+ | Iir_Kind_Leftof_Attribute
+ | Iir_Kind_Rightof_Attribute
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute
+ | Iir_Kind_Left_Array_Attribute
+ | Iir_Kind_Right_Array_Attribute
+ | Iir_Kind_High_Array_Attribute
+ | Iir_Kind_Low_Array_Attribute
+ | Iir_Kind_Length_Array_Attribute
+ | Iir_Kind_Ascending_Array_Attribute
+ | Iir_Kind_Range_Array_Attribute
+ | Iir_Kind_Reverse_Range_Array_Attribute =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Parameter;
+
+ function Has_Actual_Type (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Association_Element_By_Individual;
+ end Has_Actual_Type;
+
+ function Has_Associated_Interface (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Association_Element_Package;
+ end Has_Associated_Interface;
+
+ function Has_Association_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Parenthesis_Name;
+ end Has_Association_Chain;
+
+ function Has_Individual_Association_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Association_Element_By_Individual;
+ end Has_Individual_Association_Chain;
+
+ function Has_Aggregate_Info (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Aggregate;
+ end Has_Aggregate_Info;
+
+ function Has_Sub_Aggregate_Info (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Aggregate_Info;
+ end Has_Sub_Aggregate_Info;
+
+ function Has_Aggr_Dynamic_Flag (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Aggregate_Info;
+ end Has_Aggr_Dynamic_Flag;
+
+ function Has_Aggr_Min_Length (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Aggregate_Info;
+ end Has_Aggr_Min_Length;
+
+ function Has_Aggr_Low_Limit (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Aggregate_Info;
+ end Has_Aggr_Low_Limit;
+
+ function Has_Aggr_High_Limit (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Aggregate_Info;
+ end Has_Aggr_High_Limit;
+
+ function Has_Aggr_Others_Flag (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Aggregate_Info;
+ end Has_Aggr_Others_Flag;
+
+ function Has_Aggr_Named_Flag (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Aggregate_Info;
+ end Has_Aggr_Named_Flag;
+
+ function Has_Value_Staticness (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Aggregate;
+ end Has_Value_Staticness;
+
+ function Has_Association_Choices_Chain (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Aggregate;
+ end Has_Association_Choices_Chain;
+
+ function Has_Case_Statement_Alternative_Chain (K : Iir_Kind)
+ return Boolean is
+ begin
+ return K = Iir_Kind_Case_Statement;
+ end Has_Case_Statement_Alternative_Chain;
+
+ function Has_Choice_Staticness (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Choice_By_Expression
+ | Iir_Kind_Choice_By_Range =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Choice_Staticness;
+
+ function Has_Procedure_Call (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Concurrent_Procedure_Call_Statement
+ | Iir_Kind_Procedure_Call_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Procedure_Call;
+
+ function Has_Implementation (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Procedure_Call
+ | Iir_Kind_Identity_Operator
+ | Iir_Kind_Negation_Operator
+ | Iir_Kind_Absolute_Operator
+ | Iir_Kind_Not_Operator
+ | Iir_Kind_Condition_Operator
+ | Iir_Kind_Reduction_And_Operator
+ | Iir_Kind_Reduction_Or_Operator
+ | Iir_Kind_Reduction_Nand_Operator
+ | Iir_Kind_Reduction_Nor_Operator
+ | Iir_Kind_Reduction_Xor_Operator
+ | Iir_Kind_Reduction_Xnor_Operator
+ | Iir_Kind_And_Operator
+ | Iir_Kind_Or_Operator
+ | Iir_Kind_Nand_Operator
+ | Iir_Kind_Nor_Operator
+ | Iir_Kind_Xor_Operator
+ | Iir_Kind_Xnor_Operator
+ | Iir_Kind_Equality_Operator
+ | Iir_Kind_Inequality_Operator
+ | Iir_Kind_Less_Than_Operator
+ | Iir_Kind_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Greater_Than_Operator
+ | Iir_Kind_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Equality_Operator
+ | Iir_Kind_Match_Inequality_Operator
+ | Iir_Kind_Match_Less_Than_Operator
+ | Iir_Kind_Match_Less_Than_Or_Equal_Operator
+ | Iir_Kind_Match_Greater_Than_Operator
+ | Iir_Kind_Match_Greater_Than_Or_Equal_Operator
+ | Iir_Kind_Sll_Operator
+ | Iir_Kind_Sla_Operator
+ | Iir_Kind_Srl_Operator
+ | Iir_Kind_Sra_Operator
+ | Iir_Kind_Rol_Operator
+ | Iir_Kind_Ror_Operator
+ | Iir_Kind_Addition_Operator
+ | Iir_Kind_Substraction_Operator
+ | Iir_Kind_Concatenation_Operator
+ | Iir_Kind_Multiplication_Operator
+ | Iir_Kind_Division_Operator
+ | Iir_Kind_Modulus_Operator
+ | Iir_Kind_Remainder_Operator
+ | Iir_Kind_Exponentiation_Operator
+ | Iir_Kind_Function_Call =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Implementation;
+
+ function Has_Parameter_Association_Chain (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Procedure_Call
+ | Iir_Kind_Function_Call =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Parameter_Association_Chain;
+
+ function Has_Method_Object (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Procedure_Call
+ | Iir_Kind_Function_Call =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Method_Object;
+
+ function Has_Subtype_Type_Mark (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Array_Subtype_Definition
+ | Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Access_Subtype_Definition
+ | Iir_Kind_Physical_Subtype_Definition
+ | Iir_Kind_Floating_Subtype_Definition
+ | Iir_Kind_Integer_Subtype_Definition
+ | Iir_Kind_Enumeration_Subtype_Definition
+ | Iir_Kind_Subtype_Definition =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Subtype_Type_Mark;
+
+ function Has_Type_Conversion_Subtype (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Type_Conversion;
+ end Has_Type_Conversion_Subtype;
+
+ function Has_Type_Mark (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Disconnection_Specification
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Qualified_Expression
+ | Iir_Kind_Type_Conversion =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Type_Mark;
+
+ function Has_File_Type_Mark (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_File_Type_Definition;
+ end Has_File_Type_Mark;
+
+ function Has_Return_Type_Mark (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Signature
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Return_Type_Mark;
+
+ function Has_Lexical_Layout (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Lexical_Layout;
+
+ function Has_Incomplete_Type_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Incomplete_Type_Definition;
+ end Has_Incomplete_Type_List;
+
+ function Has_Has_Disconnect_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Has_Disconnect_Flag;
+
+ function Has_Has_Active_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Delayed_Attribute
+ | Iir_Kind_Stable_Attribute
+ | Iir_Kind_Quiet_Attribute
+ | Iir_Kind_Transaction_Attribute =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Has_Active_Flag;
+
+ function Has_Is_Within_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Enumeration_Literal
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_For_Loop_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Is_Within_Flag;
+
+ function Has_Type_Marks_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Signature;
+ end Has_Type_Marks_List;
+
+ function Has_Implicit_Alias_Flag (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Non_Object_Alias_Declaration;
+ end Has_Implicit_Alias_Flag;
+
+ function Has_Alias_Signature (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Non_Object_Alias_Declaration;
+ end Has_Alias_Signature;
+
+ function Has_Attribute_Signature (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Attribute_Name;
+ end Has_Attribute_Signature;
+
+ function Has_Overload_List (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Overload_List;
+ end Has_Overload_List;
+
+ function Has_Simple_Name_Identifier (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Simple_Name_Attribute;
+ end Has_Simple_Name_Identifier;
+
+ function Has_Simple_Name_Subtype (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Simple_Name_Attribute;
+ end Has_Simple_Name_Subtype;
+
+ function Has_Protected_Type_Body (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Protected_Type_Declaration;
+ end Has_Protected_Type_Body;
+
+ function Has_Protected_Type_Declaration (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Protected_Type_Body;
+ end Has_Protected_Type_Declaration;
+
+ function Has_End_Location (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Design_Unit;
+ end Has_End_Location;
+
+ function Has_String_Id (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_String_Id;
+
+ function Has_String_Length (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_String_Literal
+ | Iir_Kind_Bit_String_Literal =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_String_Length;
+
+ function Has_Use_Flag (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Type_Declaration
+ | Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Nature_Declaration
+ | Iir_Kind_Subnature_Declaration
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Attribute_Declaration
+ | Iir_Kind_Group_Template_Declaration
+ | Iir_Kind_Group_Declaration
+ | Iir_Kind_Non_Object_Alias_Declaration
+ | Iir_Kind_Psl_Declaration
+ | Iir_Kind_Terminal_Declaration
+ | Iir_Kind_Free_Quantity_Declaration
+ | Iir_Kind_Across_Quantity_Declaration
+ | Iir_Kind_Through_Quantity_Declaration
+ | Iir_Kind_Function_Declaration
+ | Iir_Kind_Implicit_Function_Declaration
+ | Iir_Kind_Implicit_Procedure_Declaration
+ | Iir_Kind_Procedure_Declaration
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Guard_Signal_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Use_Flag;
+
+ function Has_End_Has_Reserved_Id (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Protected_Type_Declaration
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Physical_Type_Definition
+ | Iir_Kind_Protected_Type_Body
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_End_Has_Reserved_Id;
+
+ function Has_End_Has_Identifier (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Protected_Type_Declaration
+ | Iir_Kind_Record_Type_Definition
+ | Iir_Kind_Physical_Type_Definition
+ | Iir_Kind_Protected_Type_Body
+ | Iir_Kind_Package_Declaration
+ | Iir_Kind_Package_Instantiation_Declaration
+ | Iir_Kind_Package_Body
+ | Iir_Kind_Configuration_Declaration
+ | Iir_Kind_Entity_Declaration
+ | Iir_Kind_Architecture_Body
+ | Iir_Kind_Component_Declaration
+ | Iir_Kind_Function_Body
+ | Iir_Kind_Procedure_Body
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement
+ | Iir_Kind_Block_Statement
+ | Iir_Kind_Generate_Statement
+ | Iir_Kind_For_Loop_Statement
+ | Iir_Kind_While_Loop_Statement
+ | Iir_Kind_Case_Statement
+ | Iir_Kind_If_Statement
+ | Iir_Kind_Elsif =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_End_Has_Identifier;
+
+ function Has_End_Has_Postponed (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_End_Has_Postponed;
+
+ function Has_Has_Begin (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Entity_Declaration
+ | Iir_Kind_Generate_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Has_Begin;
+
+ function Has_Has_Is (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Component_Declaration
+ | Iir_Kind_Sensitized_Process_Statement
+ | Iir_Kind_Process_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Has_Is;
+
+ function Has_Has_Pure (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Function_Declaration;
+ end Has_Has_Pure;
+
+ function Has_Has_Body (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Function_Declaration
+ | Iir_Kind_Procedure_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Has_Body;
+
+ function Has_Has_Identifier_List (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Library_Clause
+ | Iir_Kind_Element_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Has_Identifier_List;
+
+ function Has_Has_Mode (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_File_Declaration;
+ end Has_Has_Mode;
+
+ function Has_Is_Ref (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Subtype_Declaration
+ | Iir_Kind_Element_Declaration
+ | Iir_Kind_Object_Alias_Declaration
+ | Iir_Kind_File_Declaration
+ | Iir_Kind_Signal_Declaration
+ | Iir_Kind_Variable_Declaration
+ | Iir_Kind_Constant_Declaration
+ | Iir_Kind_Iterator_Declaration
+ | Iir_Kind_Interface_Constant_Declaration
+ | Iir_Kind_Interface_Variable_Declaration
+ | Iir_Kind_Interface_Signal_Declaration
+ | Iir_Kind_Interface_File_Declaration =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Is_Ref;
+
+ function Has_Psl_Property (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_Psl_Property;
+
+ function Has_Psl_Declaration (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Psl_Declaration;
+ end Has_Psl_Declaration;
+
+ function Has_Psl_Expression (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Psl_Expression;
+ end Has_Psl_Expression;
+
+ function Has_Psl_Boolean (K : Iir_Kind) return Boolean is
+ begin
+ return K = Iir_Kind_Psl_Default_Clock;
+ end Has_Psl_Boolean;
+
+ function Has_PSL_Clock (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Psl_Declaration
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_PSL_Clock;
+
+ function Has_PSL_NFA (K : Iir_Kind) return Boolean is
+ begin
+ case K is
+ when Iir_Kind_Psl_Declaration
+ | Iir_Kind_Psl_Assert_Statement
+ | Iir_Kind_Psl_Cover_Statement =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Has_PSL_NFA;
+
+end Nodes_Meta;
diff --git a/src/nodes_meta.adb.in b/src/nodes_meta.adb.in
new file mode 100644
index 000000000..d94c2d626
--- /dev/null
+++ b/src/nodes_meta.adb.in
@@ -0,0 +1,76 @@
+-- Meta description of nodes.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package body Nodes_Meta is
+ Fields_Type : constant array (Fields_Enum) of Types_Enum :=
+ (
+ -- FIELDS_TYPE
+ );
+
+ function Get_Field_Type (F : Fields_Enum) return Types_Enum is
+ begin
+ return Fields_Type (F);
+ end Get_Field_Type;
+
+ function Get_Field_Image (F : Fields_Enum) return String is
+ begin
+ case F is
+ -- FIELD_IMAGE
+ end case;
+ end Get_Field_Image;
+
+ function Get_Iir_Image (K : Iir_Kind) return String is
+ begin
+ case K is
+ -- IIR_IMAGE
+ end case;
+ end Get_Iir_Image;
+
+ function Get_Field_Attribute (F : Fields_Enum) return Field_Attribute is
+ begin
+ case F is
+ -- FIELD_ATTRIBUTE
+ end case;
+ end Get_Field_Attribute;
+
+ Fields_Of_Iir : constant Fields_Array :=
+ (
+ -- FIELDS_ARRAY
+ );
+
+ Fields_Of_Iir_Last : constant array (Iir_Kind) of Integer :=
+ (
+ -- FIELDS_ARRAY_POS
+ );
+
+ function Get_Fields (K : Iir_Kind) return Fields_Array
+ is
+ First : Natural;
+ Last : Integer;
+ begin
+ if K = Iir_Kind'First then
+ First := Fields_Of_Iir'First;
+ else
+ First := Fields_Of_Iir_Last (Iir_Kind'Pred (K)) + 1;
+ end if;
+ Last := Fields_Of_Iir_Last (K);
+ return Fields_Of_Iir (First .. Last);
+ end Get_Fields;
+
+ -- FUNCS_BODY
+end Nodes_Meta;
diff --git a/src/nodes_meta.ads b/src/nodes_meta.ads
new file mode 100644
index 000000000..2d1f5e1c0
--- /dev/null
+++ b/src/nodes_meta.ads
@@ -0,0 +1,823 @@
+-- Meta description of nodes.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Types; use Types;
+with Iirs; use Iirs;
+with Tokens; use Tokens;
+
+package Nodes_Meta is
+ -- The enumeration of all possible types in the nodes.
+ type Types_Enum is
+ (
+ Type_Base_Type,
+ Type_Boolean,
+ Type_Date_State_Type,
+ Type_Date_Type,
+ Type_Iir,
+ Type_Iir_All_Sensitized,
+ Type_Iir_Constraint,
+ Type_Iir_Delay_Mechanism,
+ Type_Iir_Direction,
+ Type_Iir_Fp64,
+ Type_Iir_Index32,
+ Type_Iir_Int32,
+ Type_Iir_Int64,
+ Type_Iir_Lexical_Layout_Type,
+ Type_Iir_List,
+ Type_Iir_Mode,
+ Type_Iir_Predefined_Functions,
+ Type_Iir_Pure_State,
+ Type_Iir_Signal_Kind,
+ Type_Iir_Staticness,
+ Type_Int32,
+ Type_Location_Type,
+ Type_Name_Id,
+ Type_PSL_NFA,
+ Type_PSL_Node,
+ Type_Source_Ptr,
+ Type_String_Id,
+ Type_Time_Stamp_Id,
+ Type_Token_Type,
+ Type_Tri_State_Type
+ );
+
+ -- The enumeration of all fields defined in iirs.
+ type Fields_Enum is
+ (
+ Field_First_Design_Unit,
+ Field_Last_Design_Unit,
+ Field_Library_Declaration,
+ Field_File_Time_Stamp,
+ Field_Analysis_Time_Stamp,
+ Field_Library,
+ Field_File_Dependence_List,
+ Field_Design_File_Filename,
+ Field_Design_File_Directory,
+ Field_Design_File,
+ Field_Design_File_Chain,
+ Field_Library_Directory,
+ Field_Date,
+ Field_Context_Items,
+ Field_Dependence_List,
+ Field_Analysis_Checks_List,
+ Field_Date_State,
+ Field_Guarded_Target_State,
+ Field_Library_Unit,
+ Field_Hash_Chain,
+ Field_Design_Unit_Source_Pos,
+ Field_Design_Unit_Source_Line,
+ Field_Design_Unit_Source_Col,
+ Field_Value,
+ Field_Enum_Pos,
+ Field_Physical_Literal,
+ Field_Physical_Unit_Value,
+ Field_Fp_Value,
+ Field_Enumeration_Decl,
+ Field_Simple_Aggregate_List,
+ Field_Bit_String_Base,
+ Field_Bit_String_0,
+ Field_Bit_String_1,
+ Field_Literal_Origin,
+ Field_Range_Origin,
+ Field_Literal_Subtype,
+ Field_Entity_Class,
+ Field_Entity_Name_List,
+ Field_Attribute_Designator,
+ Field_Attribute_Specification_Chain,
+ Field_Attribute_Specification,
+ Field_Signal_List,
+ Field_Designated_Entity,
+ Field_Formal,
+ Field_Actual,
+ Field_In_Conversion,
+ Field_Out_Conversion,
+ Field_Whole_Association_Flag,
+ Field_Collapse_Signal_Flag,
+ Field_Artificial_Flag,
+ Field_Open_Flag,
+ Field_After_Drivers_Flag,
+ Field_We_Value,
+ Field_Time,
+ Field_Associated_Expr,
+ Field_Associated_Chain,
+ Field_Choice_Name,
+ Field_Choice_Expression,
+ Field_Choice_Range,
+ Field_Same_Alternative_Flag,
+ Field_Architecture,
+ Field_Block_Specification,
+ Field_Prev_Block_Configuration,
+ Field_Configuration_Item_Chain,
+ Field_Attribute_Value_Chain,
+ Field_Spec_Chain,
+ Field_Attribute_Value_Spec_Chain,
+ Field_Entity_Name,
+ Field_Package,
+ Field_Package_Body,
+ Field_Need_Body,
+ Field_Block_Configuration,
+ Field_Concurrent_Statement_Chain,
+ Field_Chain,
+ Field_Port_Chain,
+ Field_Generic_Chain,
+ Field_Type,
+ Field_Subtype_Indication,
+ Field_Discrete_Range,
+ Field_Type_Definition,
+ Field_Subtype_Definition,
+ Field_Nature,
+ Field_Mode,
+ Field_Signal_Kind,
+ Field_Base_Name,
+ Field_Interface_Declaration_Chain,
+ Field_Subprogram_Specification,
+ Field_Sequential_Statement_Chain,
+ Field_Subprogram_Body,
+ Field_Overload_Number,
+ Field_Subprogram_Depth,
+ Field_Subprogram_Hash,
+ Field_Impure_Depth,
+ Field_Return_Type,
+ Field_Implicit_Definition,
+ Field_Type_Reference,
+ Field_Default_Value,
+ Field_Deferred_Declaration,
+ Field_Deferred_Declaration_Flag,
+ Field_Shared_Flag,
+ Field_Design_Unit,
+ Field_Block_Statement,
+ Field_Signal_Driver,
+ Field_Declaration_Chain,
+ Field_File_Logical_Name,
+ Field_File_Open_Kind,
+ Field_Element_Position,
+ Field_Element_Declaration,
+ Field_Selected_Element,
+ Field_Use_Clause_Chain,
+ Field_Selected_Name,
+ Field_Type_Declarator,
+ Field_Enumeration_Literal_List,
+ Field_Entity_Class_Entry_Chain,
+ Field_Group_Constituent_List,
+ Field_Unit_Chain,
+ Field_Primary_Unit,
+ Field_Identifier,
+ Field_Label,
+ Field_Visible_Flag,
+ Field_Range_Constraint,
+ Field_Direction,
+ Field_Left_Limit,
+ Field_Right_Limit,
+ Field_Base_Type,
+ Field_Resolution_Indication,
+ Field_Record_Element_Resolution_Chain,
+ Field_Tolerance,
+ Field_Plus_Terminal,
+ Field_Minus_Terminal,
+ Field_Simultaneous_Left,
+ Field_Simultaneous_Right,
+ Field_Text_File_Flag,
+ Field_Only_Characters_Flag,
+ Field_Type_Staticness,
+ Field_Constraint_State,
+ Field_Index_Subtype_List,
+ Field_Index_Subtype_Definition_List,
+ Field_Element_Subtype_Indication,
+ Field_Element_Subtype,
+ Field_Index_Constraint_List,
+ Field_Array_Element_Constraint,
+ Field_Elements_Declaration_List,
+ Field_Designated_Type,
+ Field_Designated_Subtype_Indication,
+ Field_Index_List,
+ Field_Reference,
+ Field_Nature_Declarator,
+ Field_Across_Type,
+ Field_Through_Type,
+ Field_Target,
+ Field_Waveform_Chain,
+ Field_Guard,
+ Field_Delay_Mechanism,
+ Field_Reject_Time_Expression,
+ Field_Sensitivity_List,
+ Field_Process_Origin,
+ Field_Condition_Clause,
+ Field_Timeout_Clause,
+ Field_Postponed_Flag,
+ Field_Callees_List,
+ Field_Passive_Flag,
+ Field_Resolution_Function_Flag,
+ Field_Wait_State,
+ Field_All_Sensitized_State,
+ Field_Seen_Flag,
+ Field_Pure_Flag,
+ Field_Foreign_Flag,
+ Field_Resolved_Flag,
+ Field_Signal_Type_Flag,
+ Field_Has_Signal_Flag,
+ Field_Purity_State,
+ Field_Elab_Flag,
+ Field_Index_Constraint_Flag,
+ Field_Assertion_Condition,
+ Field_Report_Expression,
+ Field_Severity_Expression,
+ Field_Instantiated_Unit,
+ Field_Generic_Map_Aspect_Chain,
+ Field_Port_Map_Aspect_Chain,
+ Field_Configuration_Name,
+ Field_Component_Configuration,
+ Field_Configuration_Specification,
+ Field_Default_Binding_Indication,
+ Field_Default_Configuration_Declaration,
+ Field_Expression,
+ Field_Allocator_Designated_Type,
+ Field_Selected_Waveform_Chain,
+ Field_Conditional_Waveform_Chain,
+ Field_Guard_Expression,
+ Field_Guard_Decl,
+ Field_Guard_Sensitivity_List,
+ Field_Block_Block_Configuration,
+ Field_Package_Header,
+ Field_Block_Header,
+ Field_Uninstantiated_Package_Name,
+ Field_Generate_Block_Configuration,
+ Field_Generation_Scheme,
+ Field_Condition,
+ Field_Else_Clause,
+ Field_Parameter_Specification,
+ Field_Parent,
+ Field_Loop_Label,
+ Field_Component_Name,
+ Field_Instantiation_List,
+ Field_Entity_Aspect,
+ Field_Default_Entity_Aspect,
+ Field_Default_Generic_Map_Aspect_Chain,
+ Field_Default_Port_Map_Aspect_Chain,
+ Field_Binding_Indication,
+ Field_Named_Entity,
+ Field_Alias_Declaration,
+ Field_Expr_Staticness,
+ Field_Error_Origin,
+ Field_Operand,
+ Field_Left,
+ Field_Right,
+ Field_Unit_Name,
+ Field_Name,
+ Field_Group_Template_Name,
+ Field_Name_Staticness,
+ Field_Prefix,
+ Field_Signature_Prefix,
+ Field_Slice_Subtype,
+ Field_Suffix,
+ Field_Index_Subtype,
+ Field_Parameter,
+ Field_Actual_Type,
+ Field_Associated_Interface,
+ Field_Association_Chain,
+ Field_Individual_Association_Chain,
+ Field_Aggregate_Info,
+ Field_Sub_Aggregate_Info,
+ Field_Aggr_Dynamic_Flag,
+ Field_Aggr_Min_Length,
+ Field_Aggr_Low_Limit,
+ Field_Aggr_High_Limit,
+ Field_Aggr_Others_Flag,
+ Field_Aggr_Named_Flag,
+ Field_Value_Staticness,
+ Field_Association_Choices_Chain,
+ Field_Case_Statement_Alternative_Chain,
+ Field_Choice_Staticness,
+ Field_Procedure_Call,
+ Field_Implementation,
+ Field_Parameter_Association_Chain,
+ Field_Method_Object,
+ Field_Subtype_Type_Mark,
+ Field_Type_Conversion_Subtype,
+ Field_Type_Mark,
+ Field_File_Type_Mark,
+ Field_Return_Type_Mark,
+ Field_Lexical_Layout,
+ Field_Incomplete_Type_List,
+ Field_Has_Disconnect_Flag,
+ Field_Has_Active_Flag,
+ Field_Is_Within_Flag,
+ Field_Type_Marks_List,
+ Field_Implicit_Alias_Flag,
+ Field_Alias_Signature,
+ Field_Attribute_Signature,
+ Field_Overload_List,
+ Field_Simple_Name_Identifier,
+ Field_Simple_Name_Subtype,
+ Field_Protected_Type_Body,
+ Field_Protected_Type_Declaration,
+ Field_End_Location,
+ Field_String_Id,
+ Field_String_Length,
+ Field_Use_Flag,
+ Field_End_Has_Reserved_Id,
+ Field_End_Has_Identifier,
+ Field_End_Has_Postponed,
+ Field_Has_Begin,
+ Field_Has_Is,
+ Field_Has_Pure,
+ Field_Has_Body,
+ Field_Has_Identifier_List,
+ Field_Has_Mode,
+ Field_Is_Ref,
+ Field_Psl_Property,
+ Field_Psl_Declaration,
+ Field_Psl_Expression,
+ Field_Psl_Boolean,
+ Field_PSL_Clock,
+ Field_PSL_NFA
+ );
+ pragma Discard_Names (Fields_Enum);
+
+ -- Return the type of field F.
+ function Get_Field_Type (F : Fields_Enum) return Types_Enum;
+
+ -- Get the name of a field.
+ function Get_Field_Image (F : Fields_Enum) return String;
+
+ -- Get the name of a kind.
+ function Get_Iir_Image (K : Iir_Kind) return String;
+
+ -- Possible attributes of a field.
+ type Field_Attribute is
+ (
+ Attr_None,
+ Attr_Ref, Attr_Maybe_Ref, Attr_Of_Ref,
+ Attr_Chain, Attr_Chain_Next
+ );
+
+ -- Get the attribute of a field.
+ function Get_Field_Attribute (F : Fields_Enum) return Field_Attribute;
+
+ type Fields_Array is array (Natural range <>) of Fields_Enum;
+
+ -- Return the list of fields for node K. The fields are sorted: first
+ -- the non nodes/list of nodes, then the nodes/lists that aren't reference,
+ -- and then the reference.
+ function Get_Fields (K : Iir_Kind) return Fields_Array;
+
+ -- Get/Set a field.
+ function Get_Base_Type
+ (N : Iir; F : Fields_Enum) return Base_Type;
+ procedure Set_Base_Type
+ (N : Iir; F : Fields_Enum; V: Base_Type);
+
+ function Get_Boolean
+ (N : Iir; F : Fields_Enum) return Boolean;
+ procedure Set_Boolean
+ (N : Iir; F : Fields_Enum; V: Boolean);
+
+ function Get_Date_State_Type
+ (N : Iir; F : Fields_Enum) return Date_State_Type;
+ procedure Set_Date_State_Type
+ (N : Iir; F : Fields_Enum; V: Date_State_Type);
+
+ function Get_Date_Type
+ (N : Iir; F : Fields_Enum) return Date_Type;
+ procedure Set_Date_Type
+ (N : Iir; F : Fields_Enum; V: Date_Type);
+
+ function Get_Iir
+ (N : Iir; F : Fields_Enum) return Iir;
+ procedure Set_Iir
+ (N : Iir; F : Fields_Enum; V: Iir);
+
+ function Get_Iir_All_Sensitized
+ (N : Iir; F : Fields_Enum) return Iir_All_Sensitized;
+ procedure Set_Iir_All_Sensitized
+ (N : Iir; F : Fields_Enum; V: Iir_All_Sensitized);
+
+ function Get_Iir_Constraint
+ (N : Iir; F : Fields_Enum) return Iir_Constraint;
+ procedure Set_Iir_Constraint
+ (N : Iir; F : Fields_Enum; V: Iir_Constraint);
+
+ function Get_Iir_Delay_Mechanism
+ (N : Iir; F : Fields_Enum) return Iir_Delay_Mechanism;
+ procedure Set_Iir_Delay_Mechanism
+ (N : Iir; F : Fields_Enum; V: Iir_Delay_Mechanism);
+
+ function Get_Iir_Direction
+ (N : Iir; F : Fields_Enum) return Iir_Direction;
+ procedure Set_Iir_Direction
+ (N : Iir; F : Fields_Enum; V: Iir_Direction);
+
+ function Get_Iir_Fp64
+ (N : Iir; F : Fields_Enum) return Iir_Fp64;
+ procedure Set_Iir_Fp64
+ (N : Iir; F : Fields_Enum; V: Iir_Fp64);
+
+ function Get_Iir_Index32
+ (N : Iir; F : Fields_Enum) return Iir_Index32;
+ procedure Set_Iir_Index32
+ (N : Iir; F : Fields_Enum; V: Iir_Index32);
+
+ function Get_Iir_Int32
+ (N : Iir; F : Fields_Enum) return Iir_Int32;
+ procedure Set_Iir_Int32
+ (N : Iir; F : Fields_Enum; V: Iir_Int32);
+
+ function Get_Iir_Int64
+ (N : Iir; F : Fields_Enum) return Iir_Int64;
+ procedure Set_Iir_Int64
+ (N : Iir; F : Fields_Enum; V: Iir_Int64);
+
+ function Get_Iir_Lexical_Layout_Type
+ (N : Iir; F : Fields_Enum) return Iir_Lexical_Layout_Type;
+ procedure Set_Iir_Lexical_Layout_Type
+ (N : Iir; F : Fields_Enum; V: Iir_Lexical_Layout_Type);
+
+ function Get_Iir_List
+ (N : Iir; F : Fields_Enum) return Iir_List;
+ procedure Set_Iir_List
+ (N : Iir; F : Fields_Enum; V: Iir_List);
+
+ function Get_Iir_Mode
+ (N : Iir; F : Fields_Enum) return Iir_Mode;
+ procedure Set_Iir_Mode
+ (N : Iir; F : Fields_Enum; V: Iir_Mode);
+
+ function Get_Iir_Predefined_Functions
+ (N : Iir; F : Fields_Enum) return Iir_Predefined_Functions;
+ procedure Set_Iir_Predefined_Functions
+ (N : Iir; F : Fields_Enum; V: Iir_Predefined_Functions);
+
+ function Get_Iir_Pure_State
+ (N : Iir; F : Fields_Enum) return Iir_Pure_State;
+ procedure Set_Iir_Pure_State
+ (N : Iir; F : Fields_Enum; V: Iir_Pure_State);
+
+ function Get_Iir_Signal_Kind
+ (N : Iir; F : Fields_Enum) return Iir_Signal_Kind;
+ procedure Set_Iir_Signal_Kind
+ (N : Iir; F : Fields_Enum; V: Iir_Signal_Kind);
+
+ function Get_Iir_Staticness
+ (N : Iir; F : Fields_Enum) return Iir_Staticness;
+ procedure Set_Iir_Staticness
+ (N : Iir; F : Fields_Enum; V: Iir_Staticness);
+
+ function Get_Int32
+ (N : Iir; F : Fields_Enum) return Int32;
+ procedure Set_Int32
+ (N : Iir; F : Fields_Enum; V: Int32);
+
+ function Get_Location_Type
+ (N : Iir; F : Fields_Enum) return Location_Type;
+ procedure Set_Location_Type
+ (N : Iir; F : Fields_Enum; V: Location_Type);
+
+ function Get_Name_Id
+ (N : Iir; F : Fields_Enum) return Name_Id;
+ procedure Set_Name_Id
+ (N : Iir; F : Fields_Enum; V: Name_Id);
+
+ function Get_PSL_NFA
+ (N : Iir; F : Fields_Enum) return PSL_NFA;
+ procedure Set_PSL_NFA
+ (N : Iir; F : Fields_Enum; V: PSL_NFA);
+
+ function Get_PSL_Node
+ (N : Iir; F : Fields_Enum) return PSL_Node;
+ procedure Set_PSL_Node
+ (N : Iir; F : Fields_Enum; V: PSL_Node);
+
+ function Get_Source_Ptr
+ (N : Iir; F : Fields_Enum) return Source_Ptr;
+ procedure Set_Source_Ptr
+ (N : Iir; F : Fields_Enum; V: Source_Ptr);
+
+ function Get_String_Id
+ (N : Iir; F : Fields_Enum) return String_Id;
+ procedure Set_String_Id
+ (N : Iir; F : Fields_Enum; V: String_Id);
+
+ function Get_Time_Stamp_Id
+ (N : Iir; F : Fields_Enum) return Time_Stamp_Id;
+ procedure Set_Time_Stamp_Id
+ (N : Iir; F : Fields_Enum; V: Time_Stamp_Id);
+
+ function Get_Token_Type
+ (N : Iir; F : Fields_Enum) return Token_Type;
+ procedure Set_Token_Type
+ (N : Iir; F : Fields_Enum; V: Token_Type);
+
+ function Get_Tri_State_Type
+ (N : Iir; F : Fields_Enum) return Tri_State_Type;
+ procedure Set_Tri_State_Type
+ (N : Iir; F : Fields_Enum; V: Tri_State_Type);
+
+ function Has_First_Design_Unit (K : Iir_Kind) return Boolean;
+ function Has_Last_Design_Unit (K : Iir_Kind) return Boolean;
+ function Has_Library_Declaration (K : Iir_Kind) return Boolean;
+ function Has_File_Time_Stamp (K : Iir_Kind) return Boolean;
+ function Has_Analysis_Time_Stamp (K : Iir_Kind) return Boolean;
+ function Has_Library (K : Iir_Kind) return Boolean;
+ function Has_File_Dependence_List (K : Iir_Kind) return Boolean;
+ function Has_Design_File_Filename (K : Iir_Kind) return Boolean;
+ function Has_Design_File_Directory (K : Iir_Kind) return Boolean;
+ function Has_Design_File (K : Iir_Kind) return Boolean;
+ function Has_Design_File_Chain (K : Iir_Kind) return Boolean;
+ function Has_Library_Directory (K : Iir_Kind) return Boolean;
+ function Has_Date (K : Iir_Kind) return Boolean;
+ function Has_Context_Items (K : Iir_Kind) return Boolean;
+ function Has_Dependence_List (K : Iir_Kind) return Boolean;
+ function Has_Analysis_Checks_List (K : Iir_Kind) return Boolean;
+ function Has_Date_State (K : Iir_Kind) return Boolean;
+ function Has_Guarded_Target_State (K : Iir_Kind) return Boolean;
+ function Has_Library_Unit (K : Iir_Kind) return Boolean;
+ function Has_Hash_Chain (K : Iir_Kind) return Boolean;
+ function Has_Design_Unit_Source_Pos (K : Iir_Kind) return Boolean;
+ function Has_Design_Unit_Source_Line (K : Iir_Kind) return Boolean;
+ function Has_Design_Unit_Source_Col (K : Iir_Kind) return Boolean;
+ function Has_Value (K : Iir_Kind) return Boolean;
+ function Has_Enum_Pos (K : Iir_Kind) return Boolean;
+ function Has_Physical_Literal (K : Iir_Kind) return Boolean;
+ function Has_Physical_Unit_Value (K : Iir_Kind) return Boolean;
+ function Has_Fp_Value (K : Iir_Kind) return Boolean;
+ function Has_Enumeration_Decl (K : Iir_Kind) return Boolean;
+ function Has_Simple_Aggregate_List (K : Iir_Kind) return Boolean;
+ function Has_Bit_String_Base (K : Iir_Kind) return Boolean;
+ function Has_Bit_String_0 (K : Iir_Kind) return Boolean;
+ function Has_Bit_String_1 (K : Iir_Kind) return Boolean;
+ function Has_Literal_Origin (K : Iir_Kind) return Boolean;
+ function Has_Range_Origin (K : Iir_Kind) return Boolean;
+ function Has_Literal_Subtype (K : Iir_Kind) return Boolean;
+ function Has_Entity_Class (K : Iir_Kind) return Boolean;
+ function Has_Entity_Name_List (K : Iir_Kind) return Boolean;
+ function Has_Attribute_Designator (K : Iir_Kind) return Boolean;
+ function Has_Attribute_Specification_Chain (K : Iir_Kind)
+ return Boolean;
+ function Has_Attribute_Specification (K : Iir_Kind) return Boolean;
+ function Has_Signal_List (K : Iir_Kind) return Boolean;
+ function Has_Designated_Entity (K : Iir_Kind) return Boolean;
+ function Has_Formal (K : Iir_Kind) return Boolean;
+ function Has_Actual (K : Iir_Kind) return Boolean;
+ function Has_In_Conversion (K : Iir_Kind) return Boolean;
+ function Has_Out_Conversion (K : Iir_Kind) return Boolean;
+ function Has_Whole_Association_Flag (K : Iir_Kind) return Boolean;
+ function Has_Collapse_Signal_Flag (K : Iir_Kind) return Boolean;
+ function Has_Artificial_Flag (K : Iir_Kind) return Boolean;
+ function Has_Open_Flag (K : Iir_Kind) return Boolean;
+ function Has_After_Drivers_Flag (K : Iir_Kind) return Boolean;
+ function Has_We_Value (K : Iir_Kind) return Boolean;
+ function Has_Time (K : Iir_Kind) return Boolean;
+ function Has_Associated_Expr (K : Iir_Kind) return Boolean;
+ function Has_Associated_Chain (K : Iir_Kind) return Boolean;
+ function Has_Choice_Name (K : Iir_Kind) return Boolean;
+ function Has_Choice_Expression (K : Iir_Kind) return Boolean;
+ function Has_Choice_Range (K : Iir_Kind) return Boolean;
+ function Has_Same_Alternative_Flag (K : Iir_Kind) return Boolean;
+ function Has_Architecture (K : Iir_Kind) return Boolean;
+ function Has_Block_Specification (K : Iir_Kind) return Boolean;
+ function Has_Prev_Block_Configuration (K : Iir_Kind) return Boolean;
+ function Has_Configuration_Item_Chain (K : Iir_Kind) return Boolean;
+ function Has_Attribute_Value_Chain (K : Iir_Kind) return Boolean;
+ function Has_Spec_Chain (K : Iir_Kind) return Boolean;
+ function Has_Attribute_Value_Spec_Chain (K : Iir_Kind) return Boolean;
+ function Has_Entity_Name (K : Iir_Kind) return Boolean;
+ function Has_Package (K : Iir_Kind) return Boolean;
+ function Has_Package_Body (K : Iir_Kind) return Boolean;
+ function Has_Need_Body (K : Iir_Kind) return Boolean;
+ function Has_Block_Configuration (K : Iir_Kind) return Boolean;
+ function Has_Concurrent_Statement_Chain (K : Iir_Kind) return Boolean;
+ function Has_Chain (K : Iir_Kind) return Boolean;
+ function Has_Port_Chain (K : Iir_Kind) return Boolean;
+ function Has_Generic_Chain (K : Iir_Kind) return Boolean;
+ function Has_Type (K : Iir_Kind) return Boolean;
+ function Has_Subtype_Indication (K : Iir_Kind) return Boolean;
+ function Has_Discrete_Range (K : Iir_Kind) return Boolean;
+ function Has_Type_Definition (K : Iir_Kind) return Boolean;
+ function Has_Subtype_Definition (K : Iir_Kind) return Boolean;
+ function Has_Nature (K : Iir_Kind) return Boolean;
+ function Has_Mode (K : Iir_Kind) return Boolean;
+ function Has_Signal_Kind (K : Iir_Kind) return Boolean;
+ function Has_Base_Name (K : Iir_Kind) return Boolean;
+ function Has_Interface_Declaration_Chain (K : Iir_Kind) return Boolean;
+ function Has_Subprogram_Specification (K : Iir_Kind) return Boolean;
+ function Has_Sequential_Statement_Chain (K : Iir_Kind) return Boolean;
+ function Has_Subprogram_Body (K : Iir_Kind) return Boolean;
+ function Has_Overload_Number (K : Iir_Kind) return Boolean;
+ function Has_Subprogram_Depth (K : Iir_Kind) return Boolean;
+ function Has_Subprogram_Hash (K : Iir_Kind) return Boolean;
+ function Has_Impure_Depth (K : Iir_Kind) return Boolean;
+ function Has_Return_Type (K : Iir_Kind) return Boolean;
+ function Has_Implicit_Definition (K : Iir_Kind) return Boolean;
+ function Has_Type_Reference (K : Iir_Kind) return Boolean;
+ function Has_Default_Value (K : Iir_Kind) return Boolean;
+ function Has_Deferred_Declaration (K : Iir_Kind) return Boolean;
+ function Has_Deferred_Declaration_Flag (K : Iir_Kind) return Boolean;
+ function Has_Shared_Flag (K : Iir_Kind) return Boolean;
+ function Has_Design_Unit (K : Iir_Kind) return Boolean;
+ function Has_Block_Statement (K : Iir_Kind) return Boolean;
+ function Has_Signal_Driver (K : Iir_Kind) return Boolean;
+ function Has_Declaration_Chain (K : Iir_Kind) return Boolean;
+ function Has_File_Logical_Name (K : Iir_Kind) return Boolean;
+ function Has_File_Open_Kind (K : Iir_Kind) return Boolean;
+ function Has_Element_Position (K : Iir_Kind) return Boolean;
+ function Has_Element_Declaration (K : Iir_Kind) return Boolean;
+ function Has_Selected_Element (K : Iir_Kind) return Boolean;
+ function Has_Use_Clause_Chain (K : Iir_Kind) return Boolean;
+ function Has_Selected_Name (K : Iir_Kind) return Boolean;
+ function Has_Type_Declarator (K : Iir_Kind) return Boolean;
+ function Has_Enumeration_Literal_List (K : Iir_Kind) return Boolean;
+ function Has_Entity_Class_Entry_Chain (K : Iir_Kind) return Boolean;
+ function Has_Group_Constituent_List (K : Iir_Kind) return Boolean;
+ function Has_Unit_Chain (K : Iir_Kind) return Boolean;
+ function Has_Primary_Unit (K : Iir_Kind) return Boolean;
+ function Has_Identifier (K : Iir_Kind) return Boolean;
+ function Has_Label (K : Iir_Kind) return Boolean;
+ function Has_Visible_Flag (K : Iir_Kind) return Boolean;
+ function Has_Range_Constraint (K : Iir_Kind) return Boolean;
+ function Has_Direction (K : Iir_Kind) return Boolean;
+ function Has_Left_Limit (K : Iir_Kind) return Boolean;
+ function Has_Right_Limit (K : Iir_Kind) return Boolean;
+ function Has_Base_Type (K : Iir_Kind) return Boolean;
+ function Has_Resolution_Indication (K : Iir_Kind) return Boolean;
+ function Has_Record_Element_Resolution_Chain (K : Iir_Kind)
+ return Boolean;
+ function Has_Tolerance (K : Iir_Kind) return Boolean;
+ function Has_Plus_Terminal (K : Iir_Kind) return Boolean;
+ function Has_Minus_Terminal (K : Iir_Kind) return Boolean;
+ function Has_Simultaneous_Left (K : Iir_Kind) return Boolean;
+ function Has_Simultaneous_Right (K : Iir_Kind) return Boolean;
+ function Has_Text_File_Flag (K : Iir_Kind) return Boolean;
+ function Has_Only_Characters_Flag (K : Iir_Kind) return Boolean;
+ function Has_Type_Staticness (K : Iir_Kind) return Boolean;
+ function Has_Constraint_State (K : Iir_Kind) return Boolean;
+ function Has_Index_Subtype_List (K : Iir_Kind) return Boolean;
+ function Has_Index_Subtype_Definition_List (K : Iir_Kind)
+ return Boolean;
+ function Has_Element_Subtype_Indication (K : Iir_Kind) return Boolean;
+ function Has_Element_Subtype (K : Iir_Kind) return Boolean;
+ function Has_Index_Constraint_List (K : Iir_Kind) return Boolean;
+ function Has_Array_Element_Constraint (K : Iir_Kind) return Boolean;
+ function Has_Elements_Declaration_List (K : Iir_Kind) return Boolean;
+ function Has_Designated_Type (K : Iir_Kind) return Boolean;
+ function Has_Designated_Subtype_Indication (K : Iir_Kind)
+ return Boolean;
+ function Has_Index_List (K : Iir_Kind) return Boolean;
+ function Has_Reference (K : Iir_Kind) return Boolean;
+ function Has_Nature_Declarator (K : Iir_Kind) return Boolean;
+ function Has_Across_Type (K : Iir_Kind) return Boolean;
+ function Has_Through_Type (K : Iir_Kind) return Boolean;
+ function Has_Target (K : Iir_Kind) return Boolean;
+ function Has_Waveform_Chain (K : Iir_Kind) return Boolean;
+ function Has_Guard (K : Iir_Kind) return Boolean;
+ function Has_Delay_Mechanism (K : Iir_Kind) return Boolean;
+ function Has_Reject_Time_Expression (K : Iir_Kind) return Boolean;
+ function Has_Sensitivity_List (K : Iir_Kind) return Boolean;
+ function Has_Process_Origin (K : Iir_Kind) return Boolean;
+ function Has_Condition_Clause (K : Iir_Kind) return Boolean;
+ function Has_Timeout_Clause (K : Iir_Kind) return Boolean;
+ function Has_Postponed_Flag (K : Iir_Kind) return Boolean;
+ function Has_Callees_List (K : Iir_Kind) return Boolean;
+ function Has_Passive_Flag (K : Iir_Kind) return Boolean;
+ function Has_Resolution_Function_Flag (K : Iir_Kind) return Boolean;
+ function Has_Wait_State (K : Iir_Kind) return Boolean;
+ function Has_All_Sensitized_State (K : Iir_Kind) return Boolean;
+ function Has_Seen_Flag (K : Iir_Kind) return Boolean;
+ function Has_Pure_Flag (K : Iir_Kind) return Boolean;
+ function Has_Foreign_Flag (K : Iir_Kind) return Boolean;
+ function Has_Resolved_Flag (K : Iir_Kind) return Boolean;
+ function Has_Signal_Type_Flag (K : Iir_Kind) return Boolean;
+ function Has_Has_Signal_Flag (K : Iir_Kind) return Boolean;
+ function Has_Purity_State (K : Iir_Kind) return Boolean;
+ function Has_Elab_Flag (K : Iir_Kind) return Boolean;
+ function Has_Index_Constraint_Flag (K : Iir_Kind) return Boolean;
+ function Has_Assertion_Condition (K : Iir_Kind) return Boolean;
+ function Has_Report_Expression (K : Iir_Kind) return Boolean;
+ function Has_Severity_Expression (K : Iir_Kind) return Boolean;
+ function Has_Instantiated_Unit (K : Iir_Kind) return Boolean;
+ function Has_Generic_Map_Aspect_Chain (K : Iir_Kind) return Boolean;
+ function Has_Port_Map_Aspect_Chain (K : Iir_Kind) return Boolean;
+ function Has_Configuration_Name (K : Iir_Kind) return Boolean;
+ function Has_Component_Configuration (K : Iir_Kind) return Boolean;
+ function Has_Configuration_Specification (K : Iir_Kind) return Boolean;
+ function Has_Default_Binding_Indication (K : Iir_Kind) return Boolean;
+ function Has_Default_Configuration_Declaration (K : Iir_Kind)
+ return Boolean;
+ function Has_Expression (K : Iir_Kind) return Boolean;
+ function Has_Allocator_Designated_Type (K : Iir_Kind) return Boolean;
+ function Has_Selected_Waveform_Chain (K : Iir_Kind) return Boolean;
+ function Has_Conditional_Waveform_Chain (K : Iir_Kind) return Boolean;
+ function Has_Guard_Expression (K : Iir_Kind) return Boolean;
+ function Has_Guard_Decl (K : Iir_Kind) return Boolean;
+ function Has_Guard_Sensitivity_List (K : Iir_Kind) return Boolean;
+ function Has_Block_Block_Configuration (K : Iir_Kind) return Boolean;
+ function Has_Package_Header (K : Iir_Kind) return Boolean;
+ function Has_Block_Header (K : Iir_Kind) return Boolean;
+ function Has_Uninstantiated_Package_Name (K : Iir_Kind) return Boolean;
+ function Has_Generate_Block_Configuration (K : Iir_Kind) return Boolean;
+ function Has_Generation_Scheme (K : Iir_Kind) return Boolean;
+ function Has_Condition (K : Iir_Kind) return Boolean;
+ function Has_Else_Clause (K : Iir_Kind) return Boolean;
+ function Has_Parameter_Specification (K : Iir_Kind) return Boolean;
+ function Has_Parent (K : Iir_Kind) return Boolean;
+ function Has_Loop_Label (K : Iir_Kind) return Boolean;
+ function Has_Component_Name (K : Iir_Kind) return Boolean;
+ function Has_Instantiation_List (K : Iir_Kind) return Boolean;
+ function Has_Entity_Aspect (K : Iir_Kind) return Boolean;
+ function Has_Default_Entity_Aspect (K : Iir_Kind) return Boolean;
+ function Has_Default_Generic_Map_Aspect_Chain (K : Iir_Kind)
+ return Boolean;
+ function Has_Default_Port_Map_Aspect_Chain (K : Iir_Kind)
+ return Boolean;
+ function Has_Binding_Indication (K : Iir_Kind) return Boolean;
+ function Has_Named_Entity (K : Iir_Kind) return Boolean;
+ function Has_Alias_Declaration (K : Iir_Kind) return Boolean;
+ function Has_Expr_Staticness (K : Iir_Kind) return Boolean;
+ function Has_Error_Origin (K : Iir_Kind) return Boolean;
+ function Has_Operand (K : Iir_Kind) return Boolean;
+ function Has_Left (K : Iir_Kind) return Boolean;
+ function Has_Right (K : Iir_Kind) return Boolean;
+ function Has_Unit_Name (K : Iir_Kind) return Boolean;
+ function Has_Name (K : Iir_Kind) return Boolean;
+ function Has_Group_Template_Name (K : Iir_Kind) return Boolean;
+ function Has_Name_Staticness (K : Iir_Kind) return Boolean;
+ function Has_Prefix (K : Iir_Kind) return Boolean;
+ function Has_Signature_Prefix (K : Iir_Kind) return Boolean;
+ function Has_Slice_Subtype (K : Iir_Kind) return Boolean;
+ function Has_Suffix (K : Iir_Kind) return Boolean;
+ function Has_Index_Subtype (K : Iir_Kind) return Boolean;
+ function Has_Parameter (K : Iir_Kind) return Boolean;
+ function Has_Actual_Type (K : Iir_Kind) return Boolean;
+ function Has_Associated_Interface (K : Iir_Kind) return Boolean;
+ function Has_Association_Chain (K : Iir_Kind) return Boolean;
+ function Has_Individual_Association_Chain (K : Iir_Kind) return Boolean;
+ function Has_Aggregate_Info (K : Iir_Kind) return Boolean;
+ function Has_Sub_Aggregate_Info (K : Iir_Kind) return Boolean;
+ function Has_Aggr_Dynamic_Flag (K : Iir_Kind) return Boolean;
+ function Has_Aggr_Min_Length (K : Iir_Kind) return Boolean;
+ function Has_Aggr_Low_Limit (K : Iir_Kind) return Boolean;
+ function Has_Aggr_High_Limit (K : Iir_Kind) return Boolean;
+ function Has_Aggr_Others_Flag (K : Iir_Kind) return Boolean;
+ function Has_Aggr_Named_Flag (K : Iir_Kind) return Boolean;
+ function Has_Value_Staticness (K : Iir_Kind) return Boolean;
+ function Has_Association_Choices_Chain (K : Iir_Kind) return Boolean;
+ function Has_Case_Statement_Alternative_Chain (K : Iir_Kind)
+ return Boolean;
+ function Has_Choice_Staticness (K : Iir_Kind) return Boolean;
+ function Has_Procedure_Call (K : Iir_Kind) return Boolean;
+ function Has_Implementation (K : Iir_Kind) return Boolean;
+ function Has_Parameter_Association_Chain (K : Iir_Kind) return Boolean;
+ function Has_Method_Object (K : Iir_Kind) return Boolean;
+ function Has_Subtype_Type_Mark (K : Iir_Kind) return Boolean;
+ function Has_Type_Conversion_Subtype (K : Iir_Kind) return Boolean;
+ function Has_Type_Mark (K : Iir_Kind) return Boolean;
+ function Has_File_Type_Mark (K : Iir_Kind) return Boolean;
+ function Has_Return_Type_Mark (K : Iir_Kind) return Boolean;
+ function Has_Lexical_Layout (K : Iir_Kind) return Boolean;
+ function Has_Incomplete_Type_List (K : Iir_Kind) return Boolean;
+ function Has_Has_Disconnect_Flag (K : Iir_Kind) return Boolean;
+ function Has_Has_Active_Flag (K : Iir_Kind) return Boolean;
+ function Has_Is_Within_Flag (K : Iir_Kind) return Boolean;
+ function Has_Type_Marks_List (K : Iir_Kind) return Boolean;
+ function Has_Implicit_Alias_Flag (K : Iir_Kind) return Boolean;
+ function Has_Alias_Signature (K : Iir_Kind) return Boolean;
+ function Has_Attribute_Signature (K : Iir_Kind) return Boolean;
+ function Has_Overload_List (K : Iir_Kind) return Boolean;
+ function Has_Simple_Name_Identifier (K : Iir_Kind) return Boolean;
+ function Has_Simple_Name_Subtype (K : Iir_Kind) return Boolean;
+ function Has_Protected_Type_Body (K : Iir_Kind) return Boolean;
+ function Has_Protected_Type_Declaration (K : Iir_Kind) return Boolean;
+ function Has_End_Location (K : Iir_Kind) return Boolean;
+ function Has_String_Id (K : Iir_Kind) return Boolean;
+ function Has_String_Length (K : Iir_Kind) return Boolean;
+ function Has_Use_Flag (K : Iir_Kind) return Boolean;
+ function Has_End_Has_Reserved_Id (K : Iir_Kind) return Boolean;
+ function Has_End_Has_Identifier (K : Iir_Kind) return Boolean;
+ function Has_End_Has_Postponed (K : Iir_Kind) return Boolean;
+ function Has_Has_Begin (K : Iir_Kind) return Boolean;
+ function Has_Has_Is (K : Iir_Kind) return Boolean;
+ function Has_Has_Pure (K : Iir_Kind) return Boolean;
+ function Has_Has_Body (K : Iir_Kind) return Boolean;
+ function Has_Has_Identifier_List (K : Iir_Kind) return Boolean;
+ function Has_Has_Mode (K : Iir_Kind) return Boolean;
+ function Has_Is_Ref (K : Iir_Kind) return Boolean;
+ function Has_Psl_Property (K : Iir_Kind) return Boolean;
+ function Has_Psl_Declaration (K : Iir_Kind) return Boolean;
+ function Has_Psl_Expression (K : Iir_Kind) return Boolean;
+ function Has_Psl_Boolean (K : Iir_Kind) return Boolean;
+ function Has_PSL_Clock (K : Iir_Kind) return Boolean;
+ function Has_PSL_NFA (K : Iir_Kind) return Boolean;
+end Nodes_Meta;
diff --git a/src/nodes_meta.ads.in b/src/nodes_meta.ads.in
new file mode 100644
index 000000000..8e1dceca9
--- /dev/null
+++ b/src/nodes_meta.ads.in
@@ -0,0 +1,66 @@
+-- Meta description of nodes.
+-- 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 GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Types; use Types;
+with Iirs; use Iirs;
+with Tokens; use Tokens;
+
+package Nodes_Meta is
+ -- The enumeration of all possible types in the nodes.
+ type Types_Enum is
+ (
+ -- TYPES
+ );
+
+ -- The enumeration of all fields defined in iirs.
+ type Fields_Enum is
+ (
+ -- FIELDS
+ );
+ pragma Discard_Names (Fields_Enum);
+
+ -- Return the type of field F.
+ function Get_Field_Type (F : Fields_Enum) return Types_Enum;
+
+ -- Get the name of a field.
+ function Get_Field_Image (F : Fields_Enum) return String;
+
+ -- Get the name of a kind.
+ function Get_Iir_Image (K : Iir_Kind) return String;
+
+ -- Possible attributes of a field.
+ type Field_Attribute is
+ (
+ Attr_None,
+ Attr_Ref, Attr_Maybe_Ref, Attr_Of_Ref,
+ Attr_Chain, Attr_Chain_Next
+ );
+
+ -- Get the attribute of a field.
+ function Get_Field_Attribute (F : Fields_Enum) return Field_Attribute;
+
+ type Fields_Array is array (Natural range <>) of Fields_Enum;
+
+ -- Return the list of fields for node K. The fields are sorted: first
+ -- the non nodes/list of nodes, then the nodes/lists that aren't reference,
+ -- and then the reference.
+ function Get_Fields (K : Iir_Kind) return Fields_Array;
+
+ -- Get/Set a field.
+ -- FUNCS
+end Nodes_Meta;
diff --git a/src/options.adb b/src/options.adb
new file mode 100644
index 000000000..7af0804a4
--- /dev/null
+++ b/src/options.adb
@@ -0,0 +1,242 @@
+-- Command line options.
+-- Copyright (C) 2008 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GHDL; 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; use Ada.Text_IO;
+with Name_Table;
+with Libraries;
+with Std_Names;
+with PSL.Nodes;
+with PSL.Dump_Tree;
+with Disp_Tree;
+with Scanner;
+with Back_End; use Back_End;
+with Flags; use Flags;
+
+package body Options is
+ procedure Initialize is
+ begin
+ Std_Names.Std_Names_Initialize;
+ Libraries.Init_Pathes;
+ PSL.Nodes.Init;
+ PSL.Dump_Tree.Dump_Hdl_Node := Disp_Tree.Disp_Tree_For_Psl'Access;
+ end Initialize;
+
+ function Option_Warning (Opt: String; Val : Boolean) return Boolean is
+ begin
+-- if Opt = "undriven" then
+-- Warn_Undriven := True;
+ if Opt = "library" then
+ Warn_Library := Val;
+ elsif Opt = "default-binding" then
+ Warn_Default_Binding := Val;
+ elsif Opt = "binding" then
+ Warn_Binding := Val;
+ elsif Opt = "reserved" then
+ Warn_Reserved_Word := Val;
+ elsif Opt = "vital-generic" then
+ Warn_Vital_Generic := Val;
+ elsif Opt = "delayed-checks" then
+ Warn_Delayed_Checks := Val;
+ elsif Opt = "body" then
+ Warn_Body := Val;
+ elsif Opt = "specs" then
+ Warn_Specs := Val;
+ elsif Opt = "unused" then
+ Warn_Unused := Val;
+ elsif Opt = "error" then
+ Warn_Error := Val;
+ else
+ return False;
+ end if;
+ return True;
+ end Option_Warning;
+
+ function Parse_Option (Opt: String) return Boolean
+ is
+ Beg: constant Integer := Opt'First;
+ begin
+ if Opt'Length > 5 and then Opt (Beg .. Beg + 5) = "--std=" then
+ if Opt'Length = 8 then
+ if Opt (Beg + 6 .. Beg + 7) = "87" then
+ Vhdl_Std := Vhdl_87;
+ elsif Opt (Beg + 6 .. Beg + 7) = "93" then
+ Vhdl_Std := Vhdl_93;
+ elsif Opt (Beg + 6 .. Beg + 7) = "00" then
+ Vhdl_Std := Vhdl_00;
+ elsif Opt (Beg + 6 .. Beg + 7) = "02" then
+ Vhdl_Std := Vhdl_02;
+ elsif Opt (Beg + 6 .. Beg + 7) = "08" then
+ Vhdl_Std := Vhdl_08;
+ else
+ return False;
+ end if;
+ elsif Opt'Length = 9 and then Opt (Beg + 6 .. Beg + 8) = "93c" then
+ Vhdl_Std := Vhdl_93c;
+ else
+ return False;
+ end if;
+ elsif Opt'Length = 5 and then Opt (Beg .. Beg + 4) = "--ams" then
+ AMS_Vhdl := True;
+ elsif Opt'Length > 2 and then Opt (Beg .. Beg + 1) = "-P" then
+ Libraries.Add_Library_Path (Opt (Beg + 2 .. Opt'Last));
+ elsif Opt'Length > 10 and then Opt (Beg .. Beg + 9) = "--workdir=" then
+ Libraries.Set_Work_Library_Path (Opt (Beg + 10 .. Opt'Last));
+ elsif Opt'Length > 10 and then Opt (Beg .. Beg + 9) = "--warn-no-" then
+ return Option_Warning (Opt (Beg + 10 .. Opt'Last), False);
+ elsif Opt'Length > 7 and then Opt (Beg .. Beg + 6) = "--warn-" then
+ return Option_Warning (Opt (Beg + 7 .. Opt'Last), True);
+ elsif Opt'Length > 7 and then Opt (Beg .. Beg + 6) = "--work=" then
+ declare
+ use Name_Table;
+ begin
+ Name_Length := Opt'Last - (Beg + 7) + 1;
+ Name_Buffer (1 .. Name_Length) := Opt (Beg + 7 .. Opt'Last);
+ Scanner.Convert_Identifier;
+ Libraries.Work_Library_Name := Get_Identifier;
+ end;
+ elsif Opt = "-C" or else Opt = "--mb-comments" then
+ Mb_Comment := True;
+ elsif Opt = "--bootstrap" then
+ Bootstrap := True;
+ elsif Opt = "-fexplicit" then
+ Flag_Explicit := True;
+ elsif Opt = "-frelaxed-rules" then
+ Flag_Relaxed_Rules := True;
+ elsif Opt = "--syn-binding" then
+ Flag_Syn_Binding := True;
+ elsif Opt = "--no-vital-checks" then
+ Flag_Vital_Checks := False;
+ elsif Opt = "--vital-checks" then
+ Flag_Vital_Checks := True;
+ elsif Opt = "-fpsl" then
+ Scanner.Flag_Psl_Comment := True;
+ Scanner.Flag_Comment_Keyword := True;
+ elsif Opt = "-dp" then
+ Dump_Parse := True;
+ elsif Opt = "-ds" then
+ Dump_Sem := True;
+ elsif Opt = "-dc" then
+ Dump_Canon := True;
+ elsif Opt = "-da" then
+ Dump_Annotate := True;
+ elsif Opt = "--dall" then
+ Dump_All := True;
+ elsif Opt = "-dstats" then
+ Dump_Stats := True;
+ elsif Opt = "--lall" then
+ List_All := True;
+ elsif Opt = "-lv" then
+ List_Verbose := True;
+ elsif Opt = "-ls" then
+ List_Sem := True;
+ elsif Opt = "-lc" then
+ List_Canon := True;
+ elsif Opt = "-la" then
+ List_Annotate := True;
+ elsif Opt = "-v" then
+ Verbose := True;
+ elsif Opt = "--finteger64" then
+ Flag_Integer_64 := True;
+ elsif Opt = "--ftime32" then
+ Flag_Time_64 := False;
+-- elsif Opt'Length > 17
+-- and then Opt (Beg .. Beg + 17) = "--time-resolution="
+-- then
+-- Beg := Beg + 18;
+-- if Opt (Beg .. Beg + 1) = "fs" then
+-- Time_Resolution := 'f';
+-- elsif Opt (Beg .. Beg + 1) = "ps" then
+-- Time_Resolution := 'p';
+-- elsif Opt (Beg .. Beg + 1) = "ns" then
+-- Time_Resolution := 'n';
+-- elsif Opt (Beg .. Beg + 1) = "us" then
+-- Time_Resolution := 'u';
+-- elsif Opt (Beg .. Beg + 1) = "ms" then
+-- Time_Resolution := 'm';
+-- elsif Opt (Beg .. Beg + 2) = "sec" then
+-- Time_Resolution := 's';
+-- elsif Opt (Beg .. Beg + 2) = "min" then
+-- Time_Resolution := 'M';
+-- elsif Opt (Beg .. Beg + 1) = "hr" then
+-- Time_Resolution := 'h';
+-- else
+-- return False;
+-- end if;
+ elsif Back_End.Parse_Option /= null
+ and then Back_End.Parse_Option.all (Opt)
+ then
+ null;
+ else
+ return False;
+ end if;
+ return True;
+ end Parse_Option;
+
+ -- Disp help about these options.
+ procedure Disp_Options_Help
+ is
+ procedure P (S : String) renames Put_Line;
+ begin
+ P ("Main options:");
+ P (" --work=LIB use LIB as work library");
+ P (" --workdir=DIR use DIR for the file library");
+ P (" -PPATH add PATH in the library path list");
+ P (" --std=87/93/00/02/08 select vhdl 87/93/00/02/08 standard");
+ P (" --std=93c select vhdl 93 standard and allow 87 syntax");
+ P (" --[no-]vital-checks do [not] check VITAL restrictions");
+ P ("Warnings:");
+-- P (" --warn-undriven disp undriven signals");
+ P (" --warn-binding warns for component not bound");
+ P (" --warn-reserved warns use of 93 reserved words in vhdl87");
+ P (" --warn-library warns for redefinition of a design unit");
+ P (" --warn-vital-generic warns of non-vital generic names");
+ P (" --warn-delayed-checks warns for checks performed at elaboration");
+ P (" --warn-body warns for not necessary package body");
+ P (" --warn-specs warns if a all/others spec does not apply");
+ P (" --warn-unused warns if a subprogram is never used");
+ P (" --warn-error turns warnings into errors");
+-- P ("Simulation option:");
+-- P (" --time-resolution=UNIT set the resolution of type time");
+-- P (" UNIT can be fs, ps, ns, us, ms, sec, min or hr");
+-- P (" --assert-level=LEVEL set the level which stop the");
+-- P (" simulation. LEVEL is note, warning, error,");
+-- P (" failure or none");
+ P ("Extensions:");
+ P (" -fexplicit give priority to explicitly declared operator");
+ P (" -frelaxed-rules relax some LRM rules");
+ P (" -C --mb-comments allow multi-bytes chars in a comment");
+ P (" --bootstrap allow --work=std");
+ P (" --syn-binding use synthesis default binding rule");
+ P (" -fpsl parse psl in comments");
+ P ("Compilation list:");
+ P (" -ls after semantics");
+ P (" -lc after canon");
+ P (" -la after annotation");
+ P (" --lall -lX options apply to all files");
+ P (" -lv verbose list");
+ P (" -v disp compilation stages");
+ P ("Compilation dump:");
+ P (" -dp dump tree after parsing");
+ P (" -ds dump tree after semantics");
+ P (" -da dump tree after annotate");
+ P (" --dall -dX options apply to all files");
+ if Back_End.Disp_Option /= null then
+ Back_End.Disp_Option.all;
+ end if;
+ end Disp_Options_Help;
+
+end Options;
diff --git a/src/options.ads b/src/options.ads
new file mode 100644
index 000000000..24a844b59
--- /dev/null
+++ b/src/options.ads
@@ -0,0 +1,30 @@
+-- Command line options.
+-- Copyright (C) 2008 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+package Options is
+ -- Return true if opt is recognize by flags.
+ -- Note: std_names.std_names_initialize and files_map.init_pathes must have
+ -- been called before this subprogram.
+ function Parse_Option (Opt: String) return Boolean;
+
+ -- Disp help about these options.
+ procedure Disp_Options_Help;
+
+ -- Front-end intialization.
+ procedure Initialize;
+end Options;
diff --git a/src/ortho/Makefile.inc b/src/ortho/Makefile.inc
new file mode 100644
index 000000000..597aaeff1
--- /dev/null
+++ b/src/ortho/Makefile.inc
@@ -0,0 +1,38 @@
+# Common -*- Makefile -*- for ortho implementations.
+# 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.
+
+# Variable to be defined:
+# SED: sed the stream editor
+# ORTHO_BASENAME
+
+$(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).ads: \
+ $(ortho_srcdir)/ortho_nodes.common.ads \
+ $(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).private.ads
+ $(RM) -f $@
+ echo "-- DO NOT MODIFY - this file was generated from:" > $@
+ echo "-- ortho_nodes.common.ads and $(ORTHO_BASENAME).private.ads" \
+ >> $@
+ echo "--" >> $@
+ $(SED) -e '/^private/,$$d' \
+ < $(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).private.ads >> $@
+ echo "-- Start of common part" >> $@
+ $(SED) -e '1,/^package/d' -e '/^private/,$$d' < $< >> $@
+ echo "-- End of common part" >> $@
+ $(SED) -n -e '/^private/,$$p' \
+ < $(ortho_srcdir)/$(BE)/$(ORTHO_BASENAME).private.ads >> $@
+ chmod a-w $@
diff --git a/src/ortho/debug/Makefile b/src/ortho/debug/Makefile
new file mode 100644
index 000000000..0c15111ef
--- /dev/null
+++ b/src/ortho/debug/Makefile
@@ -0,0 +1,47 @@
+# -*- Makefile -*- for the ortho-code back-end
+# 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.
+BE=debug
+ortho_srcdir=..
+
+orthobe_srcdir=$(ortho_srcdir)/$(BE)
+
+GNATMAKE=gnatmake
+CC=gcc
+CFLAGS=-g
+ALL_GNAT_FLAGS=-pipe -g -gnato -gnatwl -gnatf -gnaty3befhkmr -gnatwu
+GNATMAKE_FLAGS=-m $(ALL_GNAT_FLAGS) $(GNAT_FLAGS) -aI$(ortho_srcdir) -aI$(orthobe_srcdir) -aI.
+#LARGS=-largs -static
+SED=sed
+
+all: $(ortho_exec)
+
+
+$(ortho_exec): force $(ortho_srcdir)/$(BE)/ortho_debug.ads
+ gnatmake -o $@ $(GNATMAKE_FLAGS) ortho_debug-main -bargs -E $(LARGS)
+
+clean:
+ $(RM) -f *.o *.ali *~ b~*.ad? ortho_nodes-main
+ $(RM) ortho_debug.ads
+
+force:
+
+ORTHO_BASENAME=ortho_debug
+
+# Automatically build ortho_debug.ads from ortho_node.common.ads and
+# ortho_debug.private.ads
+include $(ortho_srcdir)/Makefile.inc
diff --git a/src/ortho/debug/ortho_debug-disp.adb b/src/ortho/debug/ortho_debug-disp.adb
new file mode 100644
index 000000000..2725668bb
--- /dev/null
+++ b/src/ortho/debug/ortho_debug-disp.adb
@@ -0,0 +1,1064 @@
+-- Display the code from the ortho debug tree.
+-- 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.
+
+package body Ortho_Debug.Disp is
+ Disp_All_Types : constant Boolean := False;
+
+ package Formated_Output is
+ use Interfaces.C_Streams;
+
+ type Disp_Context is limited private;
+
+ procedure Init_Context (File : FILEs);
+
+ -- Save the current context, and create a new one.
+ procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context);
+
+ -- Restore a previous context, saved by Push_Context.
+ procedure Pop_Context (Prev_Ctx : Disp_Context);
+
+ procedure Put (Str : String);
+
+ procedure Put_Line (Str : String);
+
+ -- Add a tabulation.
+ -- Every new line will start at this tabulation.
+ procedure Add_Tab;
+
+ -- Removed a tabulation.
+ -- The next new line will start at the previous tabulation.
+ procedure Rem_Tab;
+
+ -- Flush the current output.
+ procedure Flush;
+
+ -- Return TRUE if the ident level is nul.
+ function Is_Top return Boolean;
+
+ procedure Put_Tab;
+
+ procedure New_Line;
+
+ procedure Put (C : Character);
+
+ procedure Put_Trim (Str : String);
+
+ procedure Set_Mark;
+
+ -- Flush to disk. Only for debugging in case of crash.
+ procedure Flush_File;
+ pragma Unreferenced (Flush_File);
+ private
+ type Disp_Context is record
+ -- File where the info are written to.
+ File : FILEs;
+ -- Line number of the line to be written.
+ Lineno : Natural;
+ -- Buffer for the current line.
+ Line : String (1 .. 256);
+ -- Number of characters currently in the line.
+ Line_Len : Natural;
+
+ -- Current tabulation.
+ Tab : Natural;
+ -- Tabulation to be used for the next line.
+ Next_Tab : Natural;
+
+ Mark : Natural;
+ end record;
+ end Formated_Output;
+
+ package body Formated_Output is
+ -- The current context.
+ Ctx : Disp_Context;
+
+ procedure Init_Context (File : FILEs) is
+ begin
+ Ctx.File := File;
+ Ctx.Lineno := 1;
+ Ctx.Line_Len := 0;
+ Ctx.Tab := 0;
+ Ctx.Next_Tab := 0;
+ Ctx.Mark := 0;
+ end Init_Context;
+
+ procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context)
+ is
+ begin
+ Prev_Ctx := Ctx;
+ Init_Context (File);
+ end Push_Context;
+
+ -- Restore a previous context, saved by Push_Context.
+ procedure Pop_Context (Prev_Ctx : Disp_Context) is
+ begin
+ Flush;
+ Ctx := Prev_Ctx;
+ end Pop_Context;
+
+ procedure Flush
+ is
+ Status : size_t;
+ Res : int;
+ pragma Unreferenced (Status, Res);
+ begin
+ if Ctx.Line_Len > 0 then
+ Status := fwrite (Ctx.Line'Address, size_t (Ctx.Line_Len), 1,
+ Ctx.File);
+ Res := fputc (Character'Pos (ASCII.Lf), Ctx.File);
+ Ctx.Line_Len := 0;
+ end if;
+ Ctx.Mark := 0;
+ end Flush;
+
+ function Is_Top return Boolean is
+ begin
+ return Ctx.Tab = 0;
+ end Is_Top;
+
+ procedure Put_Tab
+ is
+ Tab : Natural := Ctx.Next_Tab;
+ Max_Tab : constant Natural := 40;
+ begin
+ if Tab > Max_Tab then
+ -- Limit indentation length, to limit line length.
+ Tab := Max_Tab;
+ end if;
+
+ Ctx.Line (1 .. Tab) := (others => ' ');
+ Ctx.Line_Len := Tab;
+ Ctx.Next_Tab := Ctx.Tab + 2;
+ end Put_Tab;
+
+ procedure Put (Str : String) is
+ Saved : String (1 .. 80);
+ Len : Natural;
+ begin
+ if Ctx.Line_Len + Str'Length >= 80 then
+ if Ctx.Mark > 0 then
+ Len := Ctx.Line_Len - Ctx.Mark + 1;
+ Saved (1 .. Len) := Ctx.Line (Ctx.Mark .. Ctx.Line_Len);
+ Ctx.Line_Len := Ctx.Mark - 1;
+ Flush;
+ Put_Tab;
+ Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Len) :=
+ Saved (1 .. Len);
+ Ctx.Line_Len := Ctx.Line_Len + Len;
+ else
+ Flush;
+ end if;
+ end if;
+ if Ctx.Line_Len = 0 then
+ Put_Tab;
+ end if;
+ Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Str'Length) := Str;
+ Ctx.Line_Len := Ctx.Line_Len + Str'Length;
+ end Put;
+
+ procedure Put_Trim (Str : String) is
+ begin
+ for I in Str'Range loop
+ if Str (I) /= ' ' then
+ Put (Str (I .. Str'Last));
+ return;
+ end if;
+ end loop;
+ end Put_Trim;
+
+ procedure Put_Line (Str : String) is
+ begin
+ Put (Str);
+ Flush;
+ Ctx.Next_Tab := Ctx.Tab;
+ end Put_Line;
+
+ procedure New_Line
+ is
+ Status : int;
+ pragma Unreferenced (Status);
+ begin
+ if Ctx.Line_Len > 0 then
+ Flush;
+ else
+ Status := fputc (Character'Pos (ASCII.LF), Ctx.File);
+ end if;
+ Ctx.Next_Tab := Ctx.Tab;
+ end New_Line;
+
+ procedure Put (C : Character)
+ is
+ S : constant String (1 .. 1) := (1 => C);
+ begin
+ Put (S);
+ end Put;
+
+ -- Add a tabulation.
+ -- Every new line will start at this tabulation.
+ procedure Add_Tab is
+ begin
+ Ctx.Tab := Ctx.Tab + 2;
+ Ctx.Next_Tab := Ctx.Tab;
+ end Add_Tab;
+
+ -- Removed a tabulation.
+ -- The next new line will start at the previous tabulation.
+ procedure Rem_Tab is
+ begin
+ Ctx.Tab := Ctx.Tab - 2;
+ Ctx.Next_Tab := Ctx.Tab;
+ end Rem_Tab;
+
+ procedure Set_Mark is
+ begin
+ Ctx.Mark := Ctx.Line_Len;
+ end Set_Mark;
+
+ procedure Flush_File is
+ Status : int;
+ pragma Unreferenced (Status);
+ begin
+ Flush;
+ Status := fflush (Ctx.File);
+ end Flush_File;
+ end Formated_Output;
+
+ use Formated_Output;
+
+ procedure Init_Context (File : Interfaces.C_Streams.FILEs) is
+ begin
+ Formated_Output.Init_Context (File);
+ end Init_Context;
+
+ procedure Disp_Enode (E : O_Enode; Etype : O_Tnode);
+ procedure Disp_Lnode (Node : O_Lnode);
+ procedure Disp_Snode (First, Last : O_Snode);
+ procedure Disp_Dnode (Decl : O_Dnode);
+ procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean);
+
+ procedure Disp_Ident (Id : O_Ident) is
+ begin
+ Put (Get_String (Id));
+ end Disp_Ident;
+
+ procedure Disp_Tnode_Name (Atype : O_Tnode) is
+ begin
+ Disp_Tnode (Atype, False);
+ end Disp_Tnode_Name;
+
+ procedure Disp_Dnode_Name (Decl : O_Dnode) is
+ begin
+ Disp_Ident (Decl.Name);
+ end Disp_Dnode_Name;
+
+ procedure Disp_Loop_Name (Stmt : O_Snode) is
+ begin
+ Put ("loop" & Natural'Image (Stmt.Loop_Level));
+ end Disp_Loop_Name;
+
+ function Get_Enode_Name (Kind : OE_Kind) return String
+ is
+ begin
+ case Kind is
+-- when OE_Boolean_Lit =>
+-- return "boolean_lit";
+-- when OE_Unsigned_Lit =>
+-- return "unsigned_lit";
+-- when OE_Signed_Lit =>
+-- return "signed lit";
+-- when OE_Float_Lit =>
+-- return "float lit";
+-- when OE_Null_Lit =>
+-- return "null lit";
+-- when OE_Enum_Lit =>
+-- return "enum lit";
+
+-- when OE_Sizeof_Lit =>
+-- return "sizeof lit";
+-- when OE_Offsetof_Lit =>
+-- return "offsetof lit";
+-- when OE_Aggregate =>
+-- return "aggregate";
+-- when OE_Aggr_Element =>
+-- return "aggr_element";
+-- when OE_Union_Aggr =>
+-- return "union aggr";
+
+ when OE_Lit =>
+ return "lit";
+ when OE_Add_Ov =>
+ return "+#";
+ when OE_Sub_Ov =>
+ return "-#";
+ when OE_Mul_Ov =>
+ return "*#";
+ when OE_Div_Ov =>
+ return "/#";
+ when OE_Rem_Ov =>
+ return "rem#";
+ when OE_Mod_Ov =>
+ return "mod#";
+ when OE_Exp_Ov =>
+ return "**#";
+
+ when OE_And =>
+ return "and";
+ when OE_Or =>
+ return "or";
+ when OE_Xor =>
+ return "xor";
+ when OE_And_Then =>
+ return "and_then";
+ when OE_Or_Else =>
+ return "or_else";
+
+ when OE_Not =>
+ return "not";
+ when OE_Neg_Ov =>
+ return "-";
+ when OE_Abs_Ov =>
+ return "abs";
+
+ when OE_Eq =>
+ return "=";
+ when OE_Neq =>
+ return "/=";
+ when OE_Le =>
+ return "<=";
+ when OE_Lt =>
+ return "<";
+ when OE_Ge =>
+ return ">=";
+ when OE_Gt =>
+ return ">";
+
+ when OE_Function_Call =>
+ return "function call";
+ when OE_Convert_Ov =>
+ return "convert_ov";
+ when OE_Address =>
+ return "address";
+ when OE_Unchecked_Address =>
+ return "unchecked_address";
+-- when OE_Subprogram_Address =>
+-- return "subprg_address";
+ when OE_Alloca =>
+ return "alloca";
+ when OE_Value =>
+ return "value";
+ when OE_Nil =>
+ return "??";
+ end case;
+ end Get_Enode_Name;
+
+ function Get_Lnode_Name (Kind : OL_Kind) return String
+ is
+ begin
+ case Kind is
+ when OL_Obj =>
+ return "obj";
+ when OL_Indexed_Element =>
+ return "indexed_element";
+ when OL_Slice =>
+ return "slice";
+ when OL_Selected_Element =>
+ return "selected_element";
+ when OL_Access_Element =>
+ return "access_element";
+-- when OL_Param_Ref =>
+-- return "param_ref";
+-- when OL_Var_Ref =>
+-- return "var_ref";
+-- when OL_Const_Ref =>
+-- return "const_ref";
+ end case;
+ end Get_Lnode_Name;
+
+ pragma Unreferenced (Get_Lnode_Name);
+
+ procedure Disp_Enode_Name (Kind : OE_Kind) is
+ begin
+ Put (Get_Enode_Name (Kind));
+ end Disp_Enode_Name;
+
+ procedure Disp_Assoc_List (Head : O_Anode)
+ is
+ El : O_Anode;
+ begin
+ El := Head;
+ Put ("(");
+ if El /= null then
+ loop
+ Disp_Enode (El.Actual, El.Formal.Dtype);
+ El := El.Next;
+ exit when El = null;
+ Put (", ");
+ end loop;
+ end if;
+ Put (")");
+ end Disp_Assoc_List;
+
+ function Image (Lit : Integer) return String
+ is
+ S : constant String := Integer'Image (Lit);
+ begin
+ if S (1) = ' ' then
+ return S (2 .. S'Length);
+ else
+ return S;
+ end if;
+ end Image;
+
+ -- Disp STR as a literal for scalar type LIT_TYPE.
+ procedure Disp_Lit (Lit_Type : O_Tnode; Known : Boolean; Str : String) is
+ begin
+ if Known and not Disp_All_Types then
+ Put_Trim (Str);
+ else
+ Disp_Tnode_Name (Lit_Type);
+ Put ("'[");
+ Put_Trim (Str);
+ Put (']');
+ end if;
+ end Disp_Lit;
+
+ -- Display C. If CTYPE is set, this is the known type of C.
+ procedure Disp_Cnode (C : O_Cnode; Ctype : O_Tnode)
+ is
+ Known : constant Boolean := Ctype /= O_Tnode_Null;
+ begin
+ -- Sanity check.
+ if Known then
+ if Ctype /= C.Ctype then
+ raise Program_Error;
+ end if;
+ end if;
+
+ case C.Kind is
+ when OC_Unsigned_Lit =>
+ if False and then (C.U_Val >= Character'Pos(' ')
+ and C.U_Val <= Character'Pos ('~'))
+ then
+ Put (''');
+ Put (Character'Val (C.U_Val));
+ Put (''');
+ else
+ Disp_Lit (C.Ctype, Known, Unsigned_64'Image (C.U_Val));
+ end if;
+ when OC_Signed_Lit =>
+ Disp_Lit (C.Ctype, Known, Integer_64'Image (C.S_Val));
+ when OC_Float_Lit =>
+ Disp_Lit (C.Ctype, Known, IEEE_Float_64'Image (C.F_Val));
+ when OC_Boolean_Lit =>
+ -- Always disp the type of boolean literals.
+ Disp_Lit (C.Ctype, False, Get_String (C.B_Id));
+ when OC_Null_Lit =>
+ -- Always disp the type of null literals.
+ Disp_Lit (C.Ctype, False, "null");
+ when OC_Enum_Lit =>
+ -- Always disp the type of enum literals.
+ Disp_Lit (C.Ctype, False, Get_String (C.E_Name));
+ when OC_Sizeof_Lit =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'sizeof (");
+ Disp_Tnode_Name (C.S_Type);
+ Put (")");
+ when OC_Alignof_Lit =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'alignof (");
+ Disp_Tnode_Name (C.S_Type);
+ Put (")");
+ when OC_Offsetof_Lit =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'offsetof (");
+ Disp_Tnode_Name (C.Off_Field.Parent);
+ Put (".");
+ Disp_Ident (C.Off_Field.Ident);
+ Put (")");
+ when OC_Aggregate =>
+ declare
+ El : O_Cnode;
+ El_Type : O_Tnode;
+ Field : O_Fnode;
+ begin
+ Put ('{');
+ El := C.Aggr_Els;
+ case C.Ctype.Kind is
+ when ON_Record_Type =>
+ Field := C.Ctype.Elements;
+ El_Type := Field.Ftype;
+ when ON_Array_Sub_Type =>
+ Field := null;
+ El_Type := C.Ctype.Base_Type.El_Type;
+ when others =>
+ raise Program_Error;
+ end case;
+ if El /= null then
+ loop
+ Set_Mark;
+ if Field /= null then
+ if Disp_All_Types then
+ Put ('.');
+ Disp_Ident (Field.Ident);
+ Put (" = ");
+ end if;
+ El_Type := Field.Ftype;
+ Field := Field.Next;
+ end if;
+ Disp_Cnode (El.Aggr_Value, El_Type);
+ El := El.Aggr_Next;
+ exit when El = null;
+ Put (", ");
+ end loop;
+ end if;
+ Put ('}');
+ end;
+ when OC_Aggr_Element =>
+ Disp_Cnode (C.Aggr_Value, Ctype);
+ when OC_Union_Aggr =>
+ Put ('{');
+ Put ('.');
+ Disp_Ident (C.Uaggr_Field.Ident);
+ Put (" = ");
+ Disp_Cnode (C.Uaggr_Value, C.Uaggr_Field.Ftype);
+ Put ('}');
+ when OC_Address =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'address (");
+ Disp_Dnode_Name (C.Decl);
+ Put (")");
+ when OC_Unchecked_Address =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'unchecked_address (");
+ Disp_Dnode_Name (C.Decl);
+ Put (")");
+ when OC_Subprogram_Address =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'subprg_addr (");
+ Disp_Dnode_Name (C.Decl);
+ Put (")");
+ end case;
+ end Disp_Cnode;
+
+ -- Disp E whose expected type is ETYPE (may not be set).
+ procedure Disp_Enode (E : O_Enode; Etype : O_Tnode)
+ is
+ begin
+ case E.Kind is
+ when OE_Lit =>
+ Disp_Cnode (E.Lit, Etype);
+ when OE_Dyadic_Expr_Kind =>
+ Put ("(");
+ Disp_Enode (E.Left, O_Tnode_Null);
+ Put (' ');
+ Disp_Enode_Name (E.Kind);
+ Put (' ');
+ Disp_Enode (E.Right, E.Left.Rtype);
+ Put (')');
+ when OE_Compare_Expr_Kind =>
+ Disp_Tnode_Name (E.Rtype);
+ Put ("'(");
+ Disp_Enode (E.Left, O_Tnode_Null);
+ Put (' ');
+ Disp_Enode_Name (E.Kind);
+ Put (' ');
+ Disp_Enode (E.Right, E.Left.Rtype);
+ Put (')');
+ when OE_Monadic_Expr_Kind =>
+ Disp_Enode_Name (E.Kind);
+ if E.Kind /= OE_Neg_Ov then
+ Put (' ');
+ end if;
+ Disp_Enode (E.Operand, Etype);
+ when OE_Address =>
+ Disp_Tnode_Name (E.Rtype);
+ Put ("'address (");
+ Disp_Lnode (E.Lvalue);
+ Put (")");
+ when OE_Unchecked_Address =>
+ Disp_Tnode_Name (E.Rtype);
+ Put ("'unchecked_address (");
+ Disp_Lnode (E.Lvalue);
+ Put (")");
+ when OE_Convert_Ov =>
+ Disp_Tnode_Name (E.Rtype);
+ Put ("'conv (");
+ Disp_Enode (E.Conv, O_Tnode_Null);
+ Put (')');
+ when OE_Function_Call =>
+ Disp_Dnode_Name (E.Func);
+ Put (' ');
+ Disp_Assoc_List (E.Assoc);
+ when OE_Alloca =>
+ Disp_Tnode_Name (E.Rtype);
+ Put ("'alloca (");
+ Disp_Enode (E.A_Size, O_Tnode_Null);
+ Put (')');
+ when OE_Value =>
+ Disp_Lnode (E.Value);
+ when OE_Nil =>
+ null;
+ end case;
+ end Disp_Enode;
+
+ procedure Disp_Lnode (Node : O_Lnode) is
+ begin
+ case Node.Kind is
+ when OL_Obj =>
+ Disp_Dnode_Name (Node.Obj);
+ when OL_Access_Element =>
+ Disp_Enode (Node.Acc_Base, O_Tnode_Null);
+ Put (".all");
+ when OL_Indexed_Element =>
+ Disp_Lnode (Node.Array_Base);
+ Put ('[');
+ Disp_Enode (Node.Index, O_Tnode_Null);
+ Put (']');
+ when OL_Slice =>
+ Disp_Lnode (Node.Slice_Base);
+ Put ('[');
+ Disp_Enode (Node.Slice_Index, O_Tnode_Null);
+ Put ("...]");
+ when OL_Selected_Element =>
+ Disp_Lnode (Node.Rec_Base);
+ Put ('.');
+ Disp_Ident (Node.Rec_El.Ident);
+-- when OL_Var_Ref
+-- | OL_Const_Ref
+-- | OL_Param_Ref =>
+-- Disp_Dnode_Name (Node.Decl);
+ end case;
+ end Disp_Lnode;
+
+ procedure Disp_Fnodes (First : O_Fnode)
+ is
+ El : O_Fnode;
+ begin
+ Add_Tab;
+ El := First;
+ while El /= null loop
+ Disp_Ident (El.Ident);
+ Put (": ");
+ Disp_Tnode (El.Ftype, False);
+ Put_Line ("; ");
+ El := El.Next;
+ end loop;
+ Rem_Tab;
+ end Disp_Fnodes;
+
+ procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean) is
+ begin
+ if not Full and Atype.Decl /= null then
+ Disp_Ident (Atype.Decl.Name);
+ return;
+ end if;
+ case Atype.Kind is
+ when ON_Boolean_Type =>
+ Put ("boolean {");
+ Disp_Ident (Atype.False_N.B_Id);
+ Put (", ");
+ Disp_Ident (Atype.True_N.B_Id);
+ Put ("}");
+ when ON_Unsigned_Type =>
+ Put ("unsigned (");
+ Put_Trim (Natural'Image (Atype.Int_Size));
+ Put (")");
+ when ON_Signed_Type =>
+ Put ("signed (");
+ Put_Trim (Natural'Image (Atype.Int_Size));
+ Put (")");
+ when ON_Float_Type =>
+ Put ("float");
+ when ON_Enum_Type =>
+ declare
+ El : O_Cnode;
+ begin
+ Put ("enum {");
+ El := Atype.Literals;
+ while El /= O_Cnode_Null loop
+ Set_Mark;
+ Disp_Ident (El.E_Name);
+ Put (" = ");
+ Put (Image (El.E_Val));
+ El := El.E_Next;
+ exit when El = O_Cnode_Null;
+ Put (", ");
+ end loop;
+ Put ("}");
+ end;
+ when ON_Array_Type =>
+ Put ("array [");
+ Disp_Tnode (Atype.Index_Type, False);
+ Put ("] of ");
+ Disp_Tnode (Atype.El_Type, False);
+ when ON_Access_Type =>
+ Put ("access ");
+ if Atype.D_Type /= O_Tnode_Null then
+ Disp_Tnode (Atype.D_Type, False);
+ end if;
+ when ON_Record_Type =>
+ Put_Line ("record ");
+ Disp_Fnodes (Atype.Elements);
+ Put ("end record");
+ when ON_Union_Type =>
+ Put_Line ("union ");
+ Disp_Fnodes (Atype.Elements);
+ Put ("end union");
+ when ON_Array_Sub_Type =>
+ Put ("subarray ");
+ Disp_Tnode_Name (Atype.Base_Type);
+ Put ("[");
+ Disp_Cnode (Atype.Length, Atype.Base_Type.Index_Type);
+ Put ("]");
+ end case;
+ end Disp_Tnode;
+
+ procedure Disp_Storage_Name (Storage : O_Storage) is
+ begin
+ case Storage is
+ when O_Storage_External =>
+ Put ("external");
+ when O_Storage_Public =>
+ Put ("public");
+ when O_Storage_Private =>
+ Put ("private");
+ when O_Storage_Local =>
+ Put ("local");
+ end case;
+ end Disp_Storage_Name;
+
+ procedure Disp_Decls (Decls : O_Dnode)
+ is
+ El : O_Dnode;
+ begin
+ El := Decls;
+ while El /= null loop
+ Disp_Dnode (El);
+ El := El.Next;
+ if Is_Top then
+ -- NOTE: some declaration does not disp anything, so there may be
+ -- double new line.
+ New_Line;
+ end if;
+ end loop;
+ end Disp_Decls;
+
+ procedure Disp_Function_Decl (Decl : O_Dnode) is
+ begin
+ Disp_Storage_Name (Decl.Storage);
+ Put (" ");
+ if Decl.Dtype = null then
+ Put ("procedure ");
+ else
+ Put ("function ");
+ end if;
+ Disp_Ident (Decl.Name);
+ Put_Line (" (");
+ Add_Tab;
+ declare
+ El : O_Dnode;
+ begin
+ El := Decl.Interfaces;
+ if El /= null then
+ loop
+ Disp_Dnode (El);
+ El := El.Next;
+ exit when El = null;
+ Put_Line (";");
+ end loop;
+ end if;
+ Put (")");
+ end;
+ if Decl.Dtype /= null then
+ New_Line;
+ Put ("return ");
+ Disp_Tnode (Decl.Dtype, False);
+ end if;
+ Rem_Tab;
+ end Disp_Function_Decl;
+
+ procedure Disp_Dnode (Decl : O_Dnode) is
+ begin
+ case Decl.Kind is
+ when ON_Type_Decl =>
+ Put ("type ");
+ Disp_Ident (Decl.Name);
+ Put (" is ");
+ if not Decl.Dtype.Uncomplete then
+ Disp_Tnode (Decl.Dtype, True);
+ else
+ case Decl.Dtype.Kind is
+ when ON_Record_Type =>
+ Put ("record");
+ when ON_Access_Type =>
+ Put ("access");
+ when others =>
+ raise Program_Error;
+ end case;
+ end if;
+ Put_Line (";");
+ when ON_Completed_Type_Decl =>
+ Put ("type ");
+ Disp_Ident (Decl.Name);
+ Put (" is ");
+ Disp_Tnode (Decl.Dtype, True);
+ Put_Line (";");
+ when ON_Const_Decl =>
+ Disp_Storage_Name (Decl.Storage);
+ Put (" ");
+ Put ("constant ");
+ Disp_Ident (Decl.Name);
+ Put (" : ");
+ Disp_Tnode_Name (Decl.Dtype);
+ Put_Line (";");
+ when ON_Const_Value =>
+ Put ("constant ");
+ Disp_Ident (Decl.Name);
+ Put (" := ");
+ Disp_Cnode (Decl.Value, Decl.Dtype);
+ Put_Line (";");
+ when ON_Var_Decl =>
+ Disp_Storage_Name (Decl.Storage);
+ Put (" ");
+ Put ("var ");
+ Disp_Ident (Decl.Name);
+ Put (" : ");
+ Disp_Tnode_Name (Decl.Dtype);
+ Put_Line (";");
+ when ON_Function_Decl =>
+ if Decl.Next = null or Decl.Next /= Decl.Func_Body then
+ -- This is a forward/external declaration.
+ Disp_Function_Decl (Decl);
+ Put_Line (";");
+ end if;
+ when ON_Function_Body =>
+ Disp_Function_Decl (Decl.Func_Decl);
+ New_Line;
+ Disp_Snode (Decl.Func_Stmt, Decl.Func_Stmt);
+ when ON_Interface_Decl =>
+ Disp_Ident (Decl.Name);
+ Put (": ");
+ Disp_Tnode (Decl.Dtype, False);
+ when ON_Debug_Line_Decl =>
+ Put_Line ("--#" & Natural'Image (Decl.Line));
+ when ON_Debug_Comment_Decl =>
+ Put_Line ("-- " & Decl.Comment.all);
+ when ON_Debug_Filename_Decl =>
+ Put_Line ("--F " & Decl.Filename.all);
+ end case;
+ end Disp_Dnode;
+
+ procedure Disp_Snode (First : O_Snode; Last : O_Snode) is
+ Stmt : O_Snode;
+ begin
+ Stmt := First;
+ loop
+ --if Stmt.Kind = ON_Elsif_Stmt or Stmt.Kind = ON_When_Stmt then
+ -- Put_Indent (Tab - 1);
+ --else
+ -- Put_Indent (Tab);
+ --end if;
+ case Stmt.Kind is
+ when ON_Declare_Stmt =>
+ Put_Line ("declare");
+ Add_Tab;
+ Disp_Decls (Stmt.Decls);
+ Rem_Tab;
+ Put_Line ("begin");
+ Add_Tab;
+ if Stmt.Stmts /= null then
+ Disp_Snode (Stmt.Stmts, null);
+ end if;
+ Rem_Tab;
+ Put_Line ("end;");
+ when ON_Assign_Stmt =>
+ Disp_Lnode (Stmt.Target);
+ Put (" := ");
+ Disp_Enode (Stmt.Value, Stmt.Target.Rtype);
+ Put_Line (";");
+ when ON_Return_Stmt =>
+ Put ("return ");
+ if Stmt.Ret_Val /= null then
+ Disp_Enode (Stmt.Ret_Val, O_Tnode_Null);
+ end if;
+ Put_Line (";");
+ when ON_If_Stmt =>
+ Add_Tab;
+ Disp_Snode (Stmt.Next, Stmt.If_Last);
+ Stmt := Stmt.If_Last;
+ Rem_Tab;
+ Put_Line ("end if;");
+ when ON_Elsif_Stmt =>
+ Rem_Tab;
+ if Stmt.Cond = null then
+ Put_Line ("else");
+ else
+ if First = Stmt then
+ Put ("if ");
+ else
+ Put ("elsif ");
+ end if;
+ Disp_Enode (Stmt.Cond, O_Tnode_Null);
+ Put_Line (" then");
+ end if;
+ Add_Tab;
+ when ON_Loop_Stmt =>
+ Disp_Loop_Name (Stmt);
+ Put_Line (":");
+ Add_Tab;
+ Disp_Snode (Stmt.Next, Stmt.Loop_Last);
+ Stmt := Stmt.Loop_Last;
+ Rem_Tab;
+ Put_Line ("end loop;");
+ when ON_Exit_Stmt =>
+ Put ("exit ");
+ Disp_Loop_Name (Stmt.Loop_Id);
+ Put_Line (";");
+ when ON_Next_Stmt =>
+ Put ("next ");
+ Disp_Loop_Name (Stmt.Loop_Id);
+ Put_Line (";");
+ when ON_Case_Stmt =>
+ Put ("case ");
+ Disp_Enode (Stmt.Selector, O_Tnode_Null);
+ Put_Line (" is");
+ Add_Tab;
+ Disp_Snode (Stmt.Next, Stmt.Case_Last);
+ Stmt := Stmt.Case_Last;
+ Rem_Tab;
+ Put_Line ("end case;");
+ when ON_When_Stmt =>
+ declare
+ Choice: O_Choice;
+ Choice_Type : constant O_Tnode :=
+ Stmt.Branch_Parent.Selector.Rtype;
+ begin
+ Rem_Tab;
+ Choice := Stmt.Choice_List;
+ Put ("when ");
+ loop
+ case Choice.Kind is
+ when ON_Choice_Expr =>
+ Disp_Cnode (Choice.Expr, Choice_Type);
+ when ON_Choice_Range =>
+ Disp_Cnode (Choice.Low, Choice_Type);
+ Put (" ... ");
+ Disp_Cnode (Choice.High, Choice_Type);
+ when ON_Choice_Default =>
+ Put ("default");
+ end case;
+ Choice := Choice.Next;
+ exit when Choice = null;
+ Put_Line (",");
+ Put (" ");
+ end loop;
+ Put_Line (" =>");
+ Add_Tab;
+ end;
+ when ON_Call_Stmt =>
+ Disp_Dnode_Name (Stmt.Proc);
+ Put (' ');
+ Disp_Assoc_List (Stmt.Assoc);
+ Put_Line (";");
+ when ON_Debug_Line_Stmt =>
+ Put_Line ("--#" & Natural'Image (Stmt.Line));
+ when ON_Debug_Comment_Stmt =>
+ Put_Line ("-- " & Stmt.Comment.all);
+ end case;
+ exit when Stmt = Last;
+ Stmt := Stmt.Next;
+ exit when Stmt = null and Last = null;
+ end loop;
+ end Disp_Snode;
+
+ procedure Disp_Ortho (Decls : O_Snode) is
+ begin
+ Disp_Decls (Decls.Decls);
+ Flush;
+ end Disp_Ortho;
+
+ procedure Disp_Tnode_Decl (N : O_Tnode) is
+ begin
+ Disp_Ident (N.Decl.Name);
+ Put (" : ");
+ Disp_Tnode (N, True);
+ end Disp_Tnode_Decl;
+
+ procedure Debug_Tnode (N : O_Tnode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Tnode_Decl (N);
+ Pop_Context (Ctx);
+ end Debug_Tnode;
+
+ procedure Debug_Enode (N : O_Enode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Enode (N, O_Tnode_Null);
+ Put (" : ");
+ Disp_Tnode_Decl (N.Rtype);
+ Pop_Context (Ctx);
+ end Debug_Enode;
+
+ procedure Debug_Fnode (N : O_Fnode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Ident (N.Ident);
+ Put (": ");
+ Disp_Tnode (N.Ftype, False);
+ Pop_Context (Ctx);
+ end Debug_Fnode;
+
+ procedure Debug_Dnode (N : O_Dnode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Dnode (N);
+ Pop_Context (Ctx);
+ end Debug_Dnode;
+
+ procedure Debug_Lnode (N : O_Lnode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Lnode (N);
+ Put (" : ");
+ Disp_Tnode_Decl (N.Rtype);
+ Pop_Context (Ctx);
+ end Debug_Lnode;
+
+ procedure Debug_Snode (N : O_Snode)
+ is
+ Ctx : Disp_Context;
+ begin
+ Push_Context (Interfaces.C_Streams.stdout, Ctx);
+ Disp_Snode (N, null);
+ Pop_Context (Ctx);
+ end Debug_Snode;
+
+ pragma Unreferenced (Debug_Tnode, Debug_Enode, Debug_Fnode,
+ Debug_Dnode, Debug_Lnode, Debug_Snode);
+end Ortho_Debug.Disp;
diff --git a/src/ortho/debug/ortho_debug-disp.ads b/src/ortho/debug/ortho_debug-disp.ads
new file mode 100644
index 000000000..c365a3530
--- /dev/null
+++ b/src/ortho/debug/ortho_debug-disp.ads
@@ -0,0 +1,29 @@
+-- Display the ortho codes from a tree.
+-- 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 Interfaces.C_Streams;
+
+package Ortho_Debug.Disp is
+ -- Initialize the current context.
+ -- Must be called before any use of the DISP_* subprograms.
+ procedure Init_Context (File : Interfaces.C_Streams.FILEs);
+
+ -- Disp nodes in a pseudo-language.
+ procedure Disp_Ortho (Decls : O_Snode);
+
+private
+end Ortho_Debug.Disp;
diff --git a/src/ortho/debug/ortho_debug-main.adb b/src/ortho/debug/ortho_debug-main.adb
new file mode 100644
index 000000000..b470deaab
--- /dev/null
+++ b/src/ortho/debug/ortho_debug-main.adb
@@ -0,0 +1,151 @@
+-- Main procedure of ortho debug back-end.
+-- 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 Ada.Command_Line; use Ada.Command_Line;
+with Ada.Unchecked_Deallocation;
+with Ada.Text_IO; use Ada.Text_IO;
+with Ortho_Debug; use Ortho_Debug;
+with Ortho_Debug_Front; use Ortho_Debug_Front;
+with Ortho_Debug.Disp;
+with System; use System;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+
+procedure Ortho_Debug.Main is
+ -- Do not output the ortho code.
+ Flag_Silent : Boolean := False;
+
+ -- Force output, even in case of crash.
+ Flag_Force : Boolean := False;
+
+ I : Natural;
+ Argc : Natural;
+ Arg : String_Acc;
+ Opt : String_Acc;
+ Res : Natural;
+ File : String_Acc;
+ Output : FILEs;
+ R : Boolean;
+
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Name => String_Acc, Object => String);
+begin
+ Ortho_Debug_Front.Init;
+ Output := NULL_Stream;
+
+ Set_Exit_Status (Failure);
+
+ -- Decode options.
+ Argc := Argument_Count;
+ I := 1;
+ loop
+ exit when I > Argc;
+ exit when Argument (I) (1) /= '-';
+ if Argument (I) = "--silent" or else Argument (I) = "-quiet" then
+ Flag_Silent := True;
+ I := I + 1;
+ elsif Argument (I) = "--force" then
+ Flag_Force := True;
+ I := I + 1;
+ elsif Argument (I)'Length >= 2 and then Argument (I)(2) = 'g' then
+ -- Skip -g[XXX] flags.
+ I := I + 1;
+ elsif Argument (I) = "-o" and then I + 1 <= Argc then
+ -- TODO: write the output to the file ?
+ if Output /= NULL_Stream then
+ Put_Line (Command_Name & ": only one output allowed");
+ return;
+ end if;
+ declare
+ Name : String := Argument (I + 1) & ASCII.Nul;
+ Mode : String := 'w' & ASCII.Nul;
+ begin
+ Output := fopen (Name'Address, Mode'Address);
+ if Output = NULL_Stream then
+ Put_Line (Command_Name & ": cannot open " & Argument (I + 1));
+ return;
+ end if;
+ end;
+ I := I + 2;
+ else
+ Opt := new String'(Argument (I));
+ if I < Argc then
+ Arg := new String'(Argument (I + 1));
+ else
+ Arg := null;
+ end if;
+ Res := Ortho_Debug_Front.Decode_Option (Opt, Arg);
+ Unchecked_Deallocation (Opt);
+ Unchecked_Deallocation (Arg);
+ if Res = 0 then
+ Put_Line (Argument (I) & ": unknown option");
+ return;
+ else
+ I := I + Res;
+ end if;
+ end if;
+ end loop;
+
+ -- Initialize tree.
+ begin
+ Ortho_Debug.Init;
+
+ if I <= Argc then
+ R := True;
+ for J in I .. Argc loop
+ File := new String'(Argument (J));
+ R := R and Ortho_Debug_Front.Parse (File);
+ Unchecked_Deallocation (File);
+ end loop;
+ else
+ R := Ortho_Debug_Front.Parse (null);
+ end if;
+ Ortho_Debug.Finish;
+ exception
+ when others =>
+ if not Flag_Force then
+ raise;
+ else
+ R := False;
+ end if;
+ end;
+
+ -- Write down the result.
+ if (R and (Output /= NULL_Stream or not Flag_Silent))
+ or Flag_Force
+ then
+ if Output = NULL_Stream then
+ Ortho_Debug.Disp.Init_Context (stdout);
+ else
+ Ortho_Debug.Disp.Init_Context (Output);
+ end if;
+ Ortho_Debug.Disp.Disp_Ortho (Ortho_Debug.Top);
+ if Output /= NULL_Stream then
+ declare
+ Status : int;
+ pragma Unreferenced (Status);
+ begin
+ Status := fclose (Output);
+ end;
+ end if;
+ end if;
+
+ if R then
+ Set_Exit_Status (Success);
+ else
+ Set_Exit_Status (Failure);
+ end if;
+end Ortho_Debug.Main;
diff --git a/src/ortho/debug/ortho_debug.adb b/src/ortho/debug/ortho_debug.adb
new file mode 100644
index 000000000..8285a6473
--- /dev/null
+++ b/src/ortho/debug/ortho_debug.adb
@@ -0,0 +1,1931 @@
+-- Ortho debug back-end.
+-- 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 Ada.Unchecked_Deallocation;
+
+package body Ortho_Debug is
+ -- If True, disable some checks so that the output can be generated.
+ Disable_Checks : constant Boolean := False;
+
+ type ON_Op_To_OE_Type is array (ON_Op_Kind) of OE_Kind;
+ ON_Op_To_OE : constant ON_Op_To_OE_Type :=
+ (
+ ON_Nil => OE_Nil,
+
+ -- Dyadic operations.
+ ON_Add_Ov => OE_Add_Ov,
+ ON_Sub_Ov => OE_Sub_Ov,
+ ON_Mul_Ov => OE_Mul_Ov,
+ ON_Div_Ov => OE_Div_Ov,
+ ON_Rem_Ov => OE_Rem_Ov,
+ ON_Mod_Ov => OE_Mod_Ov,
+
+ -- Binary operations.
+ ON_And => OE_And,
+ ON_Or => OE_Or,
+ ON_Xor => OE_Xor,
+
+ -- Monadic operations.
+ ON_Not => OE_Not,
+ ON_Neg_Ov => OE_Neg_Ov,
+ ON_Abs_Ov => OE_Abs_Ov,
+
+ -- Comparaisons
+ ON_Eq => OE_Eq,
+ ON_Neq => OE_Neq,
+ ON_Le => OE_Le,
+ ON_Lt => OE_Lt,
+ ON_Ge => OE_Ge,
+ ON_Gt => OE_Gt
+ );
+
+ type Decl_Scope_Type is record
+ -- Declarations are chained.
+ Parent : O_Snode;
+ Last_Decl : O_Dnode;
+ Last_Stmt : O_Snode;
+
+ -- If this scope corresponds to a function, PREV_FUNCTION contains
+ -- the previous function.
+ Prev_Function : O_Dnode;
+
+ -- Declaration scopes are chained.
+ Prev : Decl_Scope_Acc;
+ end record;
+
+ type Stmt_Kind is
+ (Stmt_Function, Stmt_Declare, Stmt_If, Stmt_Loop, Stmt_Case);
+ type Stmt_Scope_Type (Kind : Stmt_Kind);
+ type Stmt_Scope_Acc is access Stmt_Scope_Type;
+ type Stmt_Scope_Type (Kind : Stmt_Kind) is record
+ -- Statement which created this scope.
+ Parent : O_Snode;
+ -- Previous (parent) scope.
+ Prev : Stmt_Scope_Acc;
+ case Kind is
+ when Stmt_Function =>
+ Prev_Function : Stmt_Scope_Acc;
+ -- Declaration for the function.
+ Decl : O_Dnode;
+ when Stmt_Declare =>
+ null;
+ when Stmt_If =>
+ Last_Elsif : O_Snode;
+ when Stmt_Loop =>
+ null;
+ when Stmt_Case =>
+ Last_Branch : O_Snode;
+ Last_Choice : O_Choice;
+ Case_Type : O_Tnode;
+ end case;
+ end record;
+ subtype Stmt_Function_Scope_Type is Stmt_Scope_Type (Stmt_Function);
+ subtype Stmt_Declare_Scope_Type is Stmt_Scope_Type (Stmt_Declare);
+ subtype Stmt_If_Scope_Type is Stmt_Scope_Type (Stmt_If);
+ subtype Stmt_Loop_Scope_Type is Stmt_Scope_Type (Stmt_Loop);
+ subtype Stmt_Case_Scope_Type is Stmt_Scope_Type (Stmt_Case);
+
+ Current_Stmt_Scope : Stmt_Scope_Acc := null;
+ Current_Function : Stmt_Scope_Acc := null;
+ Current_Decl_Scope : Decl_Scope_Acc := null;
+ Current_Loop_Level : Natural := 0;
+
+ procedure Push_Decl_Scope (Parent : O_Snode)
+ is
+ Res : Decl_Scope_Acc;
+ begin
+ Res := new Decl_Scope_Type'(Parent => Parent,
+ Last_Decl => null,
+ Last_Stmt => null,
+ Prev_Function => null,
+ Prev => Current_Decl_Scope);
+ Parent.Alive := True;
+ Current_Decl_Scope := Res;
+ end Push_Decl_Scope;
+
+ procedure Pop_Decl_Scope
+ is
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Object => Decl_Scope_Type, Name => Decl_Scope_Acc);
+ Old : Decl_Scope_Acc;
+ begin
+ Old := Current_Decl_Scope;
+ Old.Parent.Alive := False;
+ Current_Decl_Scope := Old.Prev;
+ Unchecked_Deallocation (Old);
+ end Pop_Decl_Scope;
+
+ procedure Add_Decl (El : O_Dnode; Check_Dup : Boolean := True) is
+ begin
+ if Current_Decl_Scope = null then
+ -- Not yet initialized, or after compilation.
+ raise Program_Error;
+ end if;
+
+ -- Note: this requires an hashed ident table.
+ -- Use ortho_ident_hash.
+ if False and then Check_Dup
+ and then not Is_Nul (El.Name)
+ then
+ -- Check the name is not already defined.
+ declare
+ E : O_Dnode;
+ begin
+ E := Current_Decl_Scope.Parent.Decls;
+ while E /= O_Dnode_Null loop
+ if Is_Equal (E.Name, El.Name) then
+ raise Syntax_Error;
+ end if;
+ E := E.Next;
+ end loop;
+ end;
+ end if;
+
+ if Current_Decl_Scope.Last_Decl = null then
+ if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then
+ Current_Decl_Scope.Parent.Decls := El;
+ else
+ raise Type_Error;
+ end if;
+ else
+ Current_Decl_Scope.Last_Decl.Next := El;
+ end if;
+ El.Next := null;
+ Current_Decl_Scope.Last_Decl := El;
+ end Add_Decl;
+
+ procedure Add_Stmt (Stmt : O_Snode)
+ is
+ begin
+ if Current_Decl_Scope = null or Current_Function = null then
+ -- You are adding a statement at the global level, ie not inside
+ -- a function.
+ raise Syntax_Error;
+ end if;
+
+ Stmt.Next := null;
+ if Current_Decl_Scope.Last_Stmt = null then
+ if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then
+ Current_Decl_Scope.Parent.Stmts := Stmt;
+ else
+ raise Syntax_Error;
+ end if;
+ else
+ Current_Decl_Scope.Last_Stmt.Next := Stmt;
+ end if;
+ Current_Decl_Scope.Last_Stmt := Stmt;
+ end Add_Stmt;
+
+ procedure Push_Stmt_Scope (Scope : Stmt_Scope_Acc)
+ is
+ begin
+ if Scope.Prev /= Current_Stmt_Scope then
+ -- SCOPE was badly initialized.
+ raise Program_Error;
+ end if;
+ Current_Stmt_Scope := Scope;
+ end Push_Stmt_Scope;
+
+ procedure Pop_Stmt_Scope (Kind : Stmt_Kind)
+ is
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Object => Stmt_Scope_Type, Name => Stmt_Scope_Acc);
+ Old : Stmt_Scope_Acc;
+ begin
+ Old := Current_Stmt_Scope;
+ if Old.Kind /= Kind then
+ raise Syntax_Error;
+ end if;
+ --Old.Parent.Last_Stmt := Current_Decl_Scope.Last_Stmt;
+ Current_Stmt_Scope := Old.Prev;
+ Unchecked_Deallocation (Old);
+ end Pop_Stmt_Scope;
+
+ -- Check declaration DECL is reachable, ie its scope is in the current
+ -- stack of scopes.
+ procedure Check_Scope (Decl : O_Dnode)
+ is
+ Res : Boolean;
+ begin
+ case Decl.Kind is
+ when ON_Interface_Decl =>
+ Res := Decl.Func_Scope.Alive;
+ when others =>
+ Res := Decl.Scope.Alive;
+ end case;
+ if not Res then
+ raise Syntax_Error;
+ end if;
+ end Check_Scope;
+
+ -- Raise SYNTAX_ERROR if OBJ is not at a constant address.
+-- procedure Check_Const_Address (Obj : O_Lnode) is
+-- begin
+-- case Obj.Kind is
+-- when OL_Const_Ref
+-- | OL_Var_Ref =>
+-- case Obj.Decl.Storage is
+-- when O_Storage_External
+-- | O_Storage_Public
+-- | O_Storage_Private =>
+-- null;
+-- when O_Storage_Local =>
+-- raise Syntax_Error;
+-- end case;
+-- when others =>
+-- -- FIXME: constant indexed element, selected element maybe
+-- -- of const address.
+-- raise Syntax_Error;
+-- end case;
+-- end Check_Const_Address;
+
+ procedure Check_Type (T1, T2 : O_Tnode) is
+ begin
+ if T1 = T2 then
+ return;
+ end if;
+ if T1.Kind = ON_Array_Sub_Type and then T2.Kind = ON_Array_Sub_Type
+ and then T1.Base_Type = T2.Base_Type
+ and then T1.Length.all = T2.Length.all
+ then
+ return;
+ end if;
+ raise Type_Error;
+ end Check_Type;
+
+ procedure Check_Ref (N : O_Enode) is
+ begin
+ if N.Ref then
+ -- Already referenced.
+ raise Syntax_Error;
+ end if;
+ N.Ref := True;
+ end Check_Ref;
+
+ procedure Check_Ref (N : O_Lnode) is
+ begin
+ if N.Ref then
+ raise Syntax_Error;
+ end if;
+ N.Ref := True;
+ end Check_Ref;
+
+ procedure Check_Complete_Type (T : O_Tnode) is
+ begin
+ if not T.Complete then
+ -- Uncomplete type cannot be used here (since its size is required,
+ -- for example).
+ raise Syntax_Error;
+ end if;
+ end Check_Complete_Type;
+
+ function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
+ return O_Enode
+ is
+ K : constant OE_Kind := ON_Op_To_OE (Kind);
+ Res : O_Enode;
+ begin
+ Check_Type (Left.Rtype, Right.Rtype);
+ Check_Ref (Left);
+ Check_Ref (Right);
+ Res := new O_Enode_Type (K);
+ Res.Rtype := Left.Rtype;
+ Res.Ref := False;
+ Res.Left := Left;
+ Res.Right := Right;
+ return Res;
+ end New_Dyadic_Op;
+
+ function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode)
+ return O_Enode
+ is
+ Res : O_Enode;
+ begin
+ Check_Ref (Operand);
+ Res := new O_Enode_Type (ON_Op_To_OE (Kind));
+ Res.Ref := False;
+ Res.Operand := Operand;
+ Res.Rtype := Operand.Rtype;
+ return Res;
+ end New_Monadic_Op;
+
+ function New_Compare_Op
+ (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode)
+ return O_Enode
+ is
+ Res : O_Enode;
+ begin
+ if Ntype.Kind /= ON_Boolean_Type then
+ raise Type_Error;
+ end if;
+ if Left.Rtype /= Right.Rtype then
+ raise Type_Error;
+ end if;
+ Check_Ref (Left);
+ Check_Ref (Right);
+ Res := new O_Enode_Type (ON_Op_To_OE (Kind));
+ Res.Ref := False;
+ Res.Left := Left;
+ Res.Right := Right;
+ Res.Rtype := Ntype;
+ return Res;
+ end New_Compare_Op;
+
+
+ function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64)
+ return O_Cnode
+ is
+ subtype O_Cnode_Signed_Lit is O_Cnode_Type (OC_Signed_Lit);
+ begin
+ if Ltype.Kind = ON_Signed_Type then
+ return new O_Cnode_Signed_Lit'(Kind => OC_Signed_Lit,
+ Ctype => Ltype,
+ Ref => False,
+ S_Val => Value);
+ else
+ raise Type_Error;
+ end if;
+ end New_Signed_Literal;
+
+ function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64)
+ return O_Cnode
+ is
+ subtype O_Cnode_Unsigned_Lit is O_Cnode_Type (OC_Unsigned_Lit);
+ begin
+ if Ltype.Kind = ON_Unsigned_Type then
+ return new O_Cnode_Unsigned_Lit'(Kind => OC_Unsigned_Lit,
+ Ctype => Ltype,
+ Ref => False,
+ U_Val => Value);
+ else
+ raise Type_Error;
+ end if;
+ end New_Unsigned_Literal;
+
+ function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64)
+ return O_Cnode
+ is
+ subtype O_Cnode_Float_Lit is O_Cnode_Type (OC_Float_Lit);
+ begin
+ if Ltype.Kind = ON_Float_Type then
+ return new O_Cnode_Float_Lit'(Kind => OC_Float_Lit,
+ Ctype => Ltype,
+ Ref => False,
+ F_Val => Value);
+ else
+ raise Type_Error;
+ end if;
+ end New_Float_Literal;
+
+ function New_Null_Access (Ltype : O_Tnode) return O_Cnode
+ is
+ subtype O_Cnode_Null_Lit_Type is O_Cnode_Type (OC_Null_Lit);
+ begin
+ if Ltype.Kind /= ON_Access_Type then
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Null_Lit_Type'(Kind => OC_Null_Lit,
+ Ctype => Ltype,
+ Ref => False);
+ end New_Null_Access;
+
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode
+ is
+ subtype O_Cnode_Sizeof_Type is O_Cnode_Type (OC_Sizeof_Lit);
+ begin
+ if Rtype.Kind /= ON_Unsigned_Type
+ and then Rtype.Kind /= ON_Access_Type
+ then
+ raise Type_Error;
+ end if;
+ Check_Complete_Type (Atype);
+ if Atype.Kind = ON_Array_Type then
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Sizeof_Type'(Kind => OC_Sizeof_Lit,
+ Ctype => Rtype,
+ Ref => False,
+ S_Type => Atype);
+ end New_Sizeof;
+
+ function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode
+ is
+ subtype O_Cnode_Alignof_Type is O_Cnode_Type (OC_Alignof_Lit);
+ begin
+ if Rtype.Kind /= ON_Unsigned_Type then
+ raise Type_Error;
+ end if;
+ Check_Complete_Type (Atype);
+ return new O_Cnode_Alignof_Type'(Kind => OC_Alignof_Lit,
+ Ctype => Rtype,
+ Ref => False,
+ S_Type => Atype);
+ end New_Alignof;
+
+ function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode)
+ return O_Cnode
+ is
+ subtype O_Cnode_Offsetof_Type is O_Cnode_Type (OC_Offsetof_Lit);
+ begin
+ if Rtype.Kind /= ON_Unsigned_Type
+ and then Rtype.Kind /= ON_Access_Type
+ then
+ raise Type_Error;
+ end if;
+ if Field.Parent /= Atype then
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Offsetof_Type'(Kind => OC_Offsetof_Lit,
+ Ctype => Rtype,
+ Ref => False,
+ Off_Field => Field);
+ end New_Offsetof;
+
+ function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode
+ is
+ subtype O_Enode_Alloca_Type is O_Enode_Type (OE_Alloca);
+ Res : O_Enode;
+ begin
+ if Rtype.Kind /= ON_Access_Type then
+ raise Type_Error;
+ end if;
+ if Size.Rtype.Kind /= ON_Unsigned_Type then
+ raise Type_Error;
+ end if;
+ Res := new O_Enode_Alloca_Type'(Kind => OE_Alloca,
+ Rtype => Rtype,
+ Ref => False,
+ A_Size => Size);
+ return Res;
+ end New_Alloca;
+
+ procedure Check_Constrained_Type (Atype : O_Tnode) is
+ begin
+ case Atype.Kind is
+ when ON_Array_Type =>
+ raise Type_Error;
+ when ON_Unsigned_Type
+ | ON_Signed_Type
+ | ON_Boolean_Type
+ | ON_Record_Type
+ | ON_Union_Type
+ | ON_Access_Type
+ | ON_Float_Type
+ | ON_Array_Sub_Type
+ | ON_Enum_Type =>
+ null;
+ end case;
+ end Check_Constrained_Type;
+
+ procedure New_Completed_Type_Decl (Atype : O_Tnode)
+ is
+ N : O_Dnode;
+ begin
+ if Atype.Decl = null then
+ -- The uncompleted type must have been declared.
+ raise Type_Error;
+ end if;
+ N := new O_Dnode_Type (ON_Completed_Type_Decl);
+ N.Name := Atype.Decl.Name;
+ N.Dtype := Atype;
+ Add_Decl (N, False);
+ end New_Completed_Type_Decl;
+
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode)
+ is
+ subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type);
+ begin
+ Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => True,
+ Complete => False,
+ Elements => O_Fnode_Null);
+ end New_Uncomplete_Record_Type;
+
+ procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
+ Elements : out O_Element_List) is
+ begin
+ if not Res.Uncomplete then
+ -- RES record type is not an uncomplete record type.
+ raise Syntax_Error;
+ end if;
+ if Res.Elements /= O_Fnode_Null then
+ -- RES record type already has elements...
+ raise Syntax_Error;
+ end if;
+ Elements.Res := Res;
+ Elements.Last := null;
+ end Start_Uncomplete_Record_Type;
+
+ procedure Start_Record_Type (Elements : out O_Element_List)
+ is
+ subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type);
+ begin
+ Elements.Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => False,
+ Elements => O_Fnode_Null);
+ Elements.Last := null;
+ end Start_Record_Type;
+
+ procedure New_Record_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident; Etype : O_Tnode)
+ is
+ begin
+ Check_Complete_Type (Etype);
+ Check_Constrained_Type (Etype);
+ El := new O_Fnode_Type'(Parent => Elements.Res,
+ Next => null,
+ Ident => Ident,
+ Ftype => Etype,
+ Offset => 0);
+ -- Append EL.
+ if Elements.Last = null then
+ Elements.Res.Elements := El;
+ else
+ Elements.Last.Next := El;
+ end if;
+ Elements.Last := El;
+ end New_Record_Field;
+
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode) is
+ begin
+ -- Align the structure.
+ Res := Elements.Res;
+ if Res.Uncomplete then
+ New_Completed_Type_Decl (Res);
+ end if;
+ Res.Complete := True;
+ end Finish_Record_Type;
+
+ procedure Start_Union_Type (Elements : out O_Element_List)
+ is
+ subtype O_Tnode_Union_Type is O_Tnode_Type (ON_Union_Type);
+ begin
+ Elements.Res := new O_Tnode_Union_Type'(Kind => ON_Union_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => False,
+ Elements => O_Fnode_Null);
+ Elements.Last := null;
+ end Start_Union_Type;
+
+ procedure New_Union_Field
+ (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident; Etype : O_Tnode)
+ is
+ begin
+ New_Record_Field (Elements, El, Ident, Etype);
+ end New_Union_Field;
+
+ procedure Finish_Union_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode) is
+ begin
+ Res := Elements.Res;
+ Res.Complete := True;
+ end Finish_Union_Type;
+
+ function New_Access_Type (Dtype : O_Tnode) return O_Tnode
+ is
+ subtype O_Tnode_Access is O_Tnode_Type (ON_Access_Type);
+ Res : O_Tnode;
+ begin
+ if Dtype /= O_Tnode_Null
+ and then Dtype.Kind = ON_Array_Sub_Type
+ then
+ -- Access to sub array are not allowed, use access to array.
+ raise Type_Error;
+ end if;
+ Res := new O_Tnode_Access'(Kind => ON_Access_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => Dtype = O_Tnode_Null,
+ Complete => True,
+ D_Type => Dtype);
+ return Res;
+ end New_Access_Type;
+
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode)
+ is
+ begin
+ if Dtype.Kind = ON_Array_Sub_Type then
+ -- Access to sub array are not allowed, use access to array.
+ raise Type_Error;
+ end if;
+ if Atype.D_Type /= O_Tnode_Null
+ or Atype.Uncomplete = False
+ then
+ -- Type already completed.
+ raise Syntax_Error;
+ end if;
+ Atype.D_Type := Dtype;
+ New_Completed_Type_Decl (Atype);
+ end Finish_Access_Type;
+
+ function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
+ return O_Tnode
+ is
+ subtype O_Tnode_Array is O_Tnode_Type (ON_Array_Type);
+ begin
+ Check_Constrained_Type (El_Type);
+ Check_Complete_Type (El_Type);
+ return new O_Tnode_Array'(Kind => ON_Array_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => True,
+ El_Type => El_Type,
+ Index_Type => Index_Type);
+ end New_Array_Type;
+
+ function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
+ return O_Tnode
+ is
+ subtype O_Tnode_Sub_Array is O_Tnode_Type (ON_Array_Sub_Type);
+ begin
+ if Atype.Kind /= ON_Array_Type then
+ raise Type_Error;
+ end if;
+ return new O_Tnode_Sub_Array'(Kind => ON_Array_Sub_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => True,
+ Base_Type => Atype,
+ Length => Length);
+ end New_Constrained_Array_Type;
+
+ function New_Unsigned_Type (Size : Natural) return O_Tnode
+ is
+ subtype O_Tnode_Unsigned is O_Tnode_Type (ON_Unsigned_Type);
+ begin
+ return new O_Tnode_Unsigned'(Kind => ON_Unsigned_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => True,
+ Int_Size => Size);
+ end New_Unsigned_Type;
+
+ function New_Signed_Type (Size : Natural) return O_Tnode
+ is
+ subtype O_Tnode_Signed is O_Tnode_Type (ON_Signed_Type);
+ begin
+ return new O_Tnode_Signed'(Kind => ON_Signed_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => True,
+ Int_Size => Size);
+ end New_Signed_Type;
+
+ function New_Float_Type return O_Tnode
+ is
+ subtype O_Tnode_Float is O_Tnode_Type (ON_Float_Type);
+ begin
+ return new O_Tnode_Float'(Kind => ON_Float_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => True);
+ end New_Float_Type;
+
+ procedure New_Boolean_Type (Res : out O_Tnode;
+ False_Id : O_Ident;
+ False_E : out O_Cnode;
+ True_Id : O_Ident;
+ True_E : out O_Cnode)
+ is
+ subtype O_Tnode_Boolean is O_Tnode_Type (ON_Boolean_Type);
+ subtype O_Cnode_Boolean_Lit is O_Cnode_Type (OC_Boolean_Lit);
+ begin
+ Res := new O_Tnode_Boolean'(Kind => ON_Boolean_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => True,
+ True_N => O_Cnode_Null,
+ False_N => O_Cnode_Null);
+ True_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit,
+ Ctype => Res,
+ Ref => False,
+ B_Val => True,
+ B_Id => True_Id);
+ False_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit,
+ Ctype => Res,
+ Ref => False,
+ B_Val => False,
+ B_Id => False_Id);
+ Res.True_N := True_E;
+ Res.False_N := False_E;
+ end New_Boolean_Type;
+
+ procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural)
+ is
+ pragma Unreferenced (Size);
+ subtype O_Tnode_Enum is O_Tnode_Type (ON_Enum_Type);
+ Res : O_Tnode;
+ begin
+ Res := new O_Tnode_Enum'(Kind => ON_Enum_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => False,
+ Nbr => 0,
+ Literals => O_Cnode_Null);
+ List.Res := Res;
+ List.Last := O_Cnode_Null;
+ end Start_Enum_Type;
+
+ procedure New_Enum_Literal (List : in out O_Enum_List;
+ Ident : O_Ident;
+ Res : out O_Cnode)
+ is
+ subtype O_Cnode_Enum_Lit is O_Cnode_Type (OC_Enum_Lit);
+ begin
+ Res := new O_Cnode_Enum_Lit'(Kind => OC_Enum_Lit,
+ Ctype => List.Res,
+ Ref => False,
+ E_Val => List.Res.Nbr,
+ E_Name => Ident,
+ E_Next => O_Cnode_Null);
+ -- Link it.
+ if List.Last = O_Cnode_Null then
+ List.Res.Literals := Res;
+ else
+ List.Last.E_Next := Res;
+ end if;
+ List.Last := Res;
+
+ List.Res.Nbr := List.Res.Nbr + 1;
+ end New_Enum_Literal;
+
+ procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is
+ begin
+ Res := List.Res;
+ Res.Complete := True;
+ end Finish_Enum_Type;
+
+ function Get_Base_Type (Atype : O_Tnode) return O_Tnode
+ is
+ begin
+ case Atype.Kind is
+ when ON_Array_Sub_Type =>
+ return Atype.Base_Type;
+ when others =>
+ return Atype;
+ end case;
+ end Get_Base_Type;
+
+ procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode)
+ is
+ subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate);
+ Res : O_Cnode;
+ begin
+ if Atype.Kind /= ON_Record_Type then
+ raise Type_Error;
+ end if;
+ Check_Complete_Type (Atype);
+ Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate,
+ Ctype => Atype,
+ Ref => False,
+ Aggr_Els => null);
+ List.Res := Res;
+ List.Last := null;
+ List.Field := Atype.Elements;
+ end Start_Record_Aggr;
+
+ procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
+ Value : O_Cnode)
+ is
+ subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element);
+ El : O_Cnode;
+ begin
+ if List.Field = O_Fnode_Null then
+ -- No more element in the aggregate.
+ raise Syntax_Error;
+ end if;
+ Check_Type (Value.Ctype, List.Field.Ftype);
+ El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element,
+ Ctype => Value.Ctype,
+ Ref => False,
+ Aggr_Value => Value,
+ Aggr_Next => null);
+ if List.Last = null then
+ List.Res.Aggr_Els := El;
+ else
+ List.Last.Aggr_Next := El;
+ end if;
+ List.Last := El;
+ List.Field := List.Field.Next;
+ end New_Record_Aggr_El;
+
+ procedure Finish_Record_Aggr
+ (List : in out O_Record_Aggr_List; Res : out O_Cnode)
+ is
+ begin
+ if List.Field /= null then
+ -- Not enough elements in aggregate.
+ raise Type_Error;
+ end if;
+ Res := List.Res;
+ end Finish_Record_Aggr;
+
+ procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode)
+ is
+ subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate);
+ Res : O_Cnode;
+ begin
+ if Atype.Kind /= ON_Array_Sub_Type then
+ raise Type_Error;
+ end if;
+ Check_Complete_Type (Atype);
+ Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate,
+ Ctype => Atype,
+ Ref => False,
+ Aggr_Els => null);
+ List.Res := Res;
+ List.Last := null;
+ List.El_Type := Atype.Base_Type.El_Type;
+ end Start_Array_Aggr;
+
+ procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List;
+ Value : O_Cnode)
+ is
+ subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element);
+ El : O_Cnode;
+ begin
+ Check_Type (Value.Ctype, List.El_Type);
+ El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element,
+ Ctype => Value.Ctype,
+ Ref => False,
+ Aggr_Value => Value,
+ Aggr_Next => null);
+ if List.Last = null then
+ List.Res.Aggr_Els := El;
+ else
+ List.Last.Aggr_Next := El;
+ end if;
+ List.Last := El;
+ end New_Array_Aggr_El;
+
+ procedure Finish_Array_Aggr
+ (List : in out O_Array_Aggr_List; Res : out O_Cnode) is
+ begin
+ Res := List.Res;
+ end Finish_Array_Aggr;
+
+ function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode)
+ return O_Cnode
+ is
+ subtype O_Cnode_Union_Aggr is O_Cnode_Type (OC_Union_Aggr);
+ Res : O_Cnode;
+ begin
+ if Atype.Kind /= ON_Union_Type then
+ raise Type_Error;
+ end if;
+ Check_Type (Value.Ctype, Field.Ftype);
+
+ Res := new O_Cnode_Union_Aggr'(Kind => OC_Union_Aggr,
+ Ctype => Atype,
+ Ref => False,
+ Uaggr_Field => Field,
+ Uaggr_Value => Value);
+ return Res;
+ end New_Union_Aggr;
+
+ function New_Obj (Obj : O_Dnode) return O_Lnode
+ is
+ subtype O_Lnode_Obj is O_Lnode_Type (OL_Obj);
+ begin
+ case Obj.Kind is
+ when ON_Const_Decl
+ | ON_Var_Decl
+ | ON_Interface_Decl =>
+ null;
+ when others =>
+ raise Program_Error;
+ end case;
+ Check_Scope (Obj);
+ return new O_Lnode_Obj'(Kind => OL_Obj,
+ Rtype => Obj.Dtype,
+ Ref => False,
+ Obj => Obj);
+ end New_Obj;
+
+ function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
+ return O_Lnode
+ is
+ subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element);
+ Res : O_Lnode;
+ begin
+ Check_Ref (Arr);
+ Res := new O_Lnode_Indexed'(Kind => OL_Indexed_Element,
+ Rtype => Get_Base_Type (Arr.Rtype).El_Type,
+ Ref => False,
+ Array_Base => Arr,
+ Index => Index);
+ return Res;
+ end New_Indexed_Element;
+
+ function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
+ return O_Lnode
+ is
+ subtype O_Lnode_Slice is O_Lnode_Type (OL_Slice);
+ Res : O_Lnode;
+ begin
+ if Res_Type.Kind /= ON_Array_Type
+ and then Res_Type.Kind /= ON_Array_Sub_Type
+ then
+ raise Type_Error;
+ end if;
+ Check_Ref (Arr);
+ Check_Ref (Index);
+ -- FIXME: check type.
+ Res := new O_Lnode_Slice'(Kind => OL_Slice,
+ Rtype => Res_Type,
+ Ref => False,
+ Slice_Base => Arr,
+ Slice_Index => Index);
+ return Res;
+ end New_Slice;
+
+ function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
+ return O_Lnode
+ is
+ subtype O_Lnode_Selected_Element is O_Lnode_Type (OL_Selected_Element);
+ begin
+ if Rec.Rtype.Kind /= ON_Record_Type then
+ raise Type_Error;
+ end if;
+ if Rec.Rtype /= El.Parent then
+ raise Type_Error;
+ end if;
+ Check_Ref (Rec);
+ return new O_Lnode_Selected_Element'(Kind => OL_Selected_Element,
+ Rtype => El.Ftype,
+ Ref => False,
+ Rec_Base => Rec,
+ Rec_El => El);
+ end New_Selected_Element;
+
+ function New_Access_Element (Acc : O_Enode) return O_Lnode
+ is
+ subtype O_Lnode_Access_Element is O_Lnode_Type (OL_Access_Element);
+ begin
+ if Acc.Rtype.Kind /= ON_Access_Type then
+ raise Type_Error;
+ end if;
+ Check_Ref (Acc);
+ return new O_Lnode_Access_Element'(Kind => OL_Access_Element,
+ Rtype => Acc.Rtype.D_Type,
+ Ref => False,
+ Acc_Base => Acc);
+ end New_Access_Element;
+
+ function Check_Conv (Source : ON_Type_Kind; Target : ON_Type_Kind)
+ return Boolean
+ is
+ type Conv_Array is array (ON_Type_Kind, ON_Type_Kind) of Boolean;
+ T : constant Boolean := True;
+ F : constant Boolean := False;
+ Conv_Allowed : constant Conv_Array :=
+ (ON_Boolean_Type => (T, F, T, T, F, F, F, F, F, F),
+ ON_Enum_Type => (F, F, T, T, F, F, F, F, F, F),
+ ON_Unsigned_Type => (T, T, T, T, F, F, F, F, F, F),
+ ON_Signed_Type => (T, T, T, T, T, F, F, F, F, F),
+ ON_Float_Type => (F, F, F, T, T, F, F, F, F, F),
+ ON_Array_Type => (F, F, F, F, F, F, T, F, F, F),
+ ON_Array_Sub_Type =>(F, F, F, F, F, T, T, F, F, F),
+ ON_Record_Type => (F, F, F, F, F, F, F, F, F, F),
+ ON_Union_Type => (F, F, F, F, F, F, F, F, F, F),
+ ON_Access_Type => (F, F, F, F, F, F, F, F, F, T));
+ begin
+ if Source = Target then
+ return True;
+ else
+ return Conv_Allowed (Source, Target);
+ end if;
+ end Check_Conv;
+
+ function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode
+ is
+ subtype O_Enode_Convert is O_Enode_Type (OE_Convert_Ov);
+ Res : O_Enode;
+ begin
+ Check_Ref (Val);
+ if not Check_Conv (Val.Rtype.Kind, Rtype.Kind) then
+ raise Type_Error;
+ end if;
+ Res := new O_Enode_Convert'(Kind => OE_Convert_Ov,
+ Rtype => Rtype,
+ Ref => False,
+ Conv => Val);
+ return Res;
+ end New_Convert_Ov;
+
+ function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode)
+ return O_Enode
+ is
+ subtype O_Enode_Address is O_Enode_Type (OE_Unchecked_Address);
+ begin
+ Check_Ref (Lvalue);
+ if Atype.Kind /= ON_Access_Type then
+ -- An address is of type access.
+ raise Type_Error;
+ end if;
+ return new O_Enode_Address'(Kind => OE_Unchecked_Address,
+ Rtype => Atype,
+ Ref => False,
+ Lvalue => Lvalue);
+ end New_Unchecked_Address;
+
+ function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode
+ is
+ subtype O_Enode_Address is O_Enode_Type (OE_Address);
+ begin
+ Check_Ref (Lvalue);
+ if Atype.Kind /= ON_Access_Type then
+ -- An address is of type access.
+ raise Type_Error;
+ end if;
+ if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then
+ if not Disable_Checks then
+ raise Type_Error;
+ end if;
+ end if;
+ return new O_Enode_Address'(Kind => OE_Address,
+ Rtype => Atype,
+ Ref => False,
+ Lvalue => Lvalue);
+ end New_Address;
+
+ function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ return O_Cnode
+ is
+ subtype O_Cnode_Address is O_Cnode_Type (OC_Unchecked_Address);
+ begin
+ Check_Scope (Decl);
+ if Atype.Kind /= ON_Access_Type then
+ -- An address is of type access.
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Address'(Kind => OC_Unchecked_Address,
+ Ctype => Atype,
+ Ref => False,
+ Decl => Decl);
+ end New_Global_Unchecked_Address;
+
+ function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode
+ is
+ subtype O_Cnode_Address is O_Cnode_Type (OC_Address);
+ begin
+ Check_Scope (Decl);
+ if Atype.Kind /= ON_Access_Type then
+ -- An address is of type access.
+ raise Type_Error;
+ end if;
+ if Get_Base_Type (Decl.Dtype) /= Get_Base_Type (Atype.D_Type) then
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Address'(Kind => OC_Address,
+ Ctype => Atype,
+ Ref => False,
+ Decl => Decl);
+ end New_Global_Address;
+
+ function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
+ return O_Cnode
+ is
+ subtype O_Cnode_Subprg_Address is O_Cnode_Type (OC_Subprogram_Address);
+ begin
+ if Atype.Kind /= ON_Access_Type then
+ -- An address is of type access.
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Subprg_Address'(Kind => OC_Subprogram_Address,
+ Ctype => Atype,
+ Ref => False,
+ Decl => Subprg);
+ end New_Subprogram_Address;
+
+ -- Raise TYPE_ERROR is ATYPE is a composite type.
+ procedure Check_Not_Composite (Atype : O_Tnode) is
+ begin
+ case Atype.Kind is
+ when ON_Boolean_Type
+ | ON_Unsigned_Type
+ | ON_Signed_Type
+ | ON_Float_Type
+ | ON_Enum_Type
+ | ON_Access_Type=>
+ return;
+ when ON_Array_Type
+ | ON_Record_Type
+ | ON_Union_Type
+ | ON_Array_Sub_Type =>
+ raise Type_Error;
+ end case;
+ end Check_Not_Composite;
+
+ function New_Value (Lvalue : O_Lnode) return O_Enode is
+ subtype O_Enode_Value is O_Enode_Type (OE_Value);
+ begin
+ Check_Not_Composite (Lvalue.Rtype);
+ Check_Ref (Lvalue);
+ return new O_Enode_Value'(Kind => OE_Value,
+ Rtype => Lvalue.Rtype,
+ Ref => False,
+ Value => Lvalue);
+ end New_Value;
+
+ function New_Obj_Value (Obj : O_Dnode) return O_Enode is
+ begin
+ return New_Value (New_Obj (Obj));
+ end New_Obj_Value;
+
+ function New_Lit (Lit : O_Cnode) return O_Enode is
+ subtype O_Enode_Lit is O_Enode_Type (OE_Lit);
+ begin
+ Check_Not_Composite (Lit.Ctype);
+ return new O_Enode_Lit'(Kind => OE_Lit,
+ Rtype => Lit.Ctype,
+ Ref => False,
+ Lit => Lit);
+ end New_Lit;
+
+ ---------------------
+ -- Declarations. --
+ ---------------------
+
+ procedure New_Debug_Filename_Decl (Filename : String)
+ is
+ subtype O_Dnode_Filename_Decl is O_Dnode_Type (ON_Debug_Filename_Decl);
+ N : O_Dnode;
+ begin
+ N := new O_Dnode_Filename_Decl;
+ N.Filename := new String'(Filename);
+ Add_Decl (N, False);
+ end New_Debug_Filename_Decl;
+
+ procedure New_Debug_Line_Decl (Line : Natural)
+ is
+ subtype O_Dnode_Line_Decl is O_Dnode_Type (ON_Debug_Line_Decl);
+ N : O_Dnode;
+ begin
+ N := new O_Dnode_Line_Decl;
+ N.Line := Line;
+ Add_Decl (N, False);
+ end New_Debug_Line_Decl;
+
+ procedure New_Debug_Comment_Decl (Comment : String)
+ is
+ subtype O_Dnode_Comment_Decl is O_Dnode_Type (ON_Debug_Comment_Decl);
+ N : O_Dnode;
+ begin
+ N := new O_Dnode_Comment_Decl;
+ N.Comment := new String'(Comment);
+ Add_Decl (N, False);
+ end New_Debug_Comment_Decl;
+
+ procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode)
+ is
+ N : O_Dnode;
+ begin
+ if Atype.Decl /= null then
+ -- Type was already declared.
+ raise Type_Error;
+ end if;
+ N := new O_Dnode_Type (ON_Type_Decl);
+ N.Name := Ident;
+ N.Dtype := Atype;
+ Atype.Decl := N;
+ Add_Decl (N);
+ end New_Type_Decl;
+
+ procedure Check_Object_Storage (Storage : O_Storage) is
+ begin
+ if Current_Function /= null then
+ -- Inside a subprogram.
+ case Storage is
+ when O_Storage_Public =>
+ -- Cannot create public variables inside a subprogram.
+ raise Syntax_Error;
+ when O_Storage_Private
+ | O_Storage_Local
+ | O_Storage_External =>
+ null;
+ end case;
+ else
+ -- Global scope.
+ case Storage is
+ when O_Storage_Public
+ | O_Storage_Private
+ | O_Storage_External =>
+ null;
+ when O_Storage_Local =>
+ -- Cannot create a local variables outside a subprogram.
+ raise Syntax_Error;
+ end case;
+ end if;
+ end Check_Object_Storage;
+
+ procedure New_Const_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode)
+ is
+ subtype O_Dnode_Const is O_Dnode_Type (ON_Const_Decl);
+ begin
+ Check_Complete_Type (Atype);
+ if Storage = O_Storage_Local then
+ -- A constant cannot be local.
+ raise Syntax_Error;
+ end if;
+ Check_Object_Storage (Storage);
+ Res := new O_Dnode_Const'(Kind => ON_Const_Decl,
+ Name => Ident,
+ Next => null,
+ Dtype => Atype,
+ Storage => Storage,
+ Scope => Current_Decl_Scope.Parent,
+ Lineno => 0,
+ Const_Value => O_Dnode_Null);
+ Add_Decl (Res);
+ end New_Const_Decl;
+
+ procedure Start_Const_Value (Const : in out O_Dnode)
+ is
+ subtype O_Dnode_Const_Value is O_Dnode_Type (ON_Const_Value);
+ N : O_Dnode;
+ begin
+ if Const.Const_Value /= O_Dnode_Null then
+ -- Constant already has a value.
+ raise Syntax_Error;
+ end if;
+
+ if Const.Storage = O_Storage_External then
+ -- An external constant must not have a value.
+ raise Syntax_Error;
+ end if;
+
+ -- FIXME: check scope is the same.
+
+ N := new O_Dnode_Const_Value'(Kind => ON_Const_Value,
+ Name => Const.Name,
+ Next => null,
+ Dtype => Const.Dtype,
+ Storage => Const.Storage,
+ Scope => Current_Decl_Scope.Parent,
+ Lineno => 0,
+ Const_Decl => Const,
+ Value => O_Cnode_Null);
+ Const.Const_Value := N;
+ Add_Decl (N, False);
+ end Start_Const_Value;
+
+ procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode)
+ is
+ begin
+ if Const.Const_Value = O_Dnode_Null then
+ -- Start_Const_Value not called.
+ raise Syntax_Error;
+ end if;
+ if Const.Const_Value.Value /= O_Cnode_Null then
+ -- Finish_Const_Value already called.
+ raise Syntax_Error;
+ end if;
+ if Val = O_Cnode_Null then
+ -- No value or bad type.
+ raise Type_Error;
+ end if;
+ Check_Type (Val.Ctype, Const.Dtype);
+ Const.Const_Value.Value := Val;
+ end Finish_Const_Value;
+
+ procedure New_Var_Decl
+ (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode)
+ is
+ subtype O_Dnode_Var is O_Dnode_Type (ON_Var_Decl);
+ begin
+ Check_Complete_Type (Atype);
+ Check_Object_Storage (Storage);
+ Res := new O_Dnode_Var'(Kind => ON_Var_Decl,
+ Name => Ident,
+ Next => null,
+ Dtype => Atype,
+ Storage => Storage,
+ Lineno => 0,
+ Scope => Current_Decl_Scope.Parent);
+ Add_Decl (Res);
+ end New_Var_Decl;
+
+ procedure Start_Subprogram_Decl_1
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode)
+ is
+ subtype O_Dnode_Function is O_Dnode_Type (ON_Function_Decl);
+ N : O_Dnode;
+ begin
+ N := new O_Dnode_Function'(Kind => ON_Function_Decl,
+ Next => null,
+ Name => Ident,
+ Dtype => Rtype,
+ Storage => Storage,
+ Scope => Current_Decl_Scope.Parent,
+ Lineno => 0,
+ Interfaces => null,
+ Func_Body => null,
+ Alive => False);
+ Add_Decl (N);
+ Interfaces.Func := N;
+ Interfaces.Last := null;
+ end Start_Subprogram_Decl_1;
+
+ procedure Start_Function_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode)
+ is
+ begin
+ Check_Not_Composite (Rtype);
+ Check_Complete_Type (Rtype);
+ Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, Rtype);
+ end Start_Function_Decl;
+
+ procedure Start_Procedure_Decl
+ (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage) is
+ begin
+ Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, null);
+ end Start_Procedure_Decl;
+
+ procedure New_Interface_Decl
+ (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode;
+ Ident : O_Ident;
+ Atype : O_Tnode)
+ is
+ subtype O_Dnode_Interface is O_Dnode_Type (ON_Interface_Decl);
+ begin
+ Check_Not_Composite (Atype);
+ Check_Complete_Type (Atype);
+ Res := new O_Dnode_Interface'(Kind => ON_Interface_Decl,
+ Next => null,
+ Name => Ident,
+ Dtype => Atype,
+ Storage => O_Storage_Private,
+ Scope => Current_Decl_Scope.Parent,
+ Lineno => 0,
+ Func_Scope => Interfaces.Func);
+ if Interfaces.Last = null then
+ Interfaces.Func.Interfaces := Res;
+ else
+ Interfaces.Last.Next := Res;
+ end if;
+ Interfaces.Last := Res;
+ end New_Interface_Decl;
+
+ procedure Finish_Subprogram_Decl
+ (Interfaces : in out O_Inter_List; Res : out O_Dnode)
+ is
+ begin
+ Res := Interfaces.Func;
+ end Finish_Subprogram_Decl;
+
+ procedure Start_Subprogram_Body (Func : O_Dnode)
+ is
+ B : O_Dnode;
+ S : O_Snode;
+ begin
+ if Func.Func_Body /= null then
+ -- Function was already declared.
+ raise Syntax_Error;
+ end if;
+ S := new O_Snode_Type (ON_Declare_Stmt);
+ S.all := O_Snode_Type'(Kind => ON_Declare_Stmt,
+ Next => null,
+ Decls => null,
+ Stmts => null,
+ Lineno => 0,
+ Alive => True);
+ B := new O_Dnode_Type (ON_Function_Body);
+ B.all := O_Dnode_Type'(ON_Function_Body,
+ Name => Func.Name,
+ Dtype => Func.Dtype,
+ Storage => Func.Storage,
+ Scope => Current_Decl_Scope.Parent,
+ Lineno => 0,
+ Func_Decl => Func,
+ Func_Stmt => S,
+ Next => null);
+ Add_Decl (B, False);
+ Func.Func_Body := B;
+ Push_Decl_Scope (S);
+ Push_Stmt_Scope
+ (new Stmt_Function_Scope_Type'(Kind => Stmt_Function,
+ Parent => S,
+ Prev => Current_Stmt_Scope,
+ Prev_Function => Current_Function,
+ Decl => Func));
+ Current_Function := Current_Stmt_Scope;
+ Func.Alive := True;
+ end Start_Subprogram_Body;
+
+ procedure Finish_Subprogram_Body is
+ begin
+ Pop_Decl_Scope;
+ if Current_Function.Kind /= Stmt_Function then
+ -- Internal error.
+ raise Syntax_Error;
+ end if;
+ Current_Function.Decl.Alive := False;
+ Current_Function := Current_Function.Prev_Function;
+ Pop_Stmt_Scope (Stmt_Function);
+ end Finish_Subprogram_Body;
+
+ -------------------
+ -- Statements. --
+ -------------------
+
+ procedure New_Debug_Line_Stmt (Line : Natural)
+ is
+ subtype O_Snode_Line_Stmt is O_Snode_Type (ON_Debug_Line_Stmt);
+ begin
+ Add_Stmt (new O_Snode_Line_Stmt'(Kind => ON_Debug_Line_Stmt,
+ Next => null,
+ Lineno => 0,
+ Line => Line));
+ end New_Debug_Line_Stmt;
+
+ procedure New_Debug_Comment_Stmt (Comment : String)
+ is
+ subtype O_Snode_Comment_Stmt is O_Snode_Type (ON_Debug_Comment_Stmt);
+ begin
+ Add_Stmt (new O_Snode_Comment_Stmt'(Kind => ON_Debug_Comment_Stmt,
+ Next => null,
+ Lineno => 0,
+ Comment => new String'(Comment)));
+ end New_Debug_Comment_Stmt;
+
+ procedure Start_Declare_Stmt
+ is
+ N : O_Snode;
+ begin
+ N := new O_Snode_Type (ON_Declare_Stmt);
+ Add_Stmt (N);
+ Push_Decl_Scope (N);
+ Push_Stmt_Scope
+ (new Stmt_Declare_Scope_Type'(Kind => Stmt_Declare,
+ Parent => N,
+ Prev => Current_Stmt_Scope));
+ end Start_Declare_Stmt;
+
+ procedure Finish_Declare_Stmt is
+ begin
+ Pop_Decl_Scope;
+ Pop_Stmt_Scope (Stmt_Declare);
+ end Finish_Declare_Stmt;
+
+ procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode)
+ is
+ N : O_Snode;
+ begin
+ Check_Type (Target.Rtype, Value.Rtype);
+ Check_Not_Composite (Target.Rtype);
+ Check_Ref (Target);
+ Check_Ref (Value);
+ N := new O_Snode_Type (ON_Assign_Stmt);
+ N.all := O_Snode_Type'(Kind => ON_Assign_Stmt,
+ Next => null,
+ Lineno => 0,
+ Target => Target,
+ Value => Value);
+ Add_Stmt (N);
+ end New_Assign_Stmt;
+
+ procedure New_Return_Stmt_1 (Value : O_Enode)
+ is
+ subtype O_Snode_Return_Stmt is O_Snode_Type (ON_Return_Stmt);
+ N : O_Snode;
+ begin
+ N := new O_Snode_Return_Stmt'(Kind => ON_Return_Stmt,
+ Next => null,
+ Lineno => 0,
+ Ret_Val => Value);
+ Add_Stmt (N);
+ end New_Return_Stmt_1;
+
+ procedure New_Return_Stmt (Value : O_Enode)
+ is
+ begin
+ if Current_Function = null
+ or else Current_Function.Decl.Dtype = O_Tnode_Null
+ then
+ -- Either not in a function or in a procedure.
+ raise Syntax_Error;
+ end if;
+ Check_Type (Value.Rtype, Current_Function.Decl.Dtype);
+ Check_Ref (Value);
+ New_Return_Stmt_1 (Value);
+ end New_Return_Stmt;
+
+ procedure New_Return_Stmt is
+ begin
+ if Current_Function = null
+ or else Current_Function.Decl.Dtype /= O_Tnode_Null
+ then
+ -- Not in a procedure.
+ raise Syntax_Error;
+ end if;
+ New_Return_Stmt_1 (null);
+ end New_Return_Stmt;
+
+ procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode)
+ is
+ begin
+ Check_Scope (Subprg);
+ Assocs.Subprg := Subprg;
+ Assocs.Interfaces := Subprg.Interfaces;
+ Assocs.First := null;
+ Assocs.Last := null;
+ end Start_Association;
+
+ procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode)
+ is
+ N : O_Anode;
+ begin
+ Check_Type (Assocs.Interfaces.Dtype, Val.Rtype);
+ Check_Ref (Val);
+ N := new O_Anode_Type'(Next => null,
+ Formal => Assocs.Interfaces, Actual => Val);
+ Assocs.Interfaces := Assocs.Interfaces.Next;
+ if Assocs.Last = null then
+ Assocs.First := N;
+ else
+ Assocs.Last.Next := N;
+ end if;
+ Assocs.Last := N;
+ end New_Association;
+
+ function New_Function_Call (Assocs : O_Assoc_List) return O_Enode
+ is
+ subtype O_Enode_Call is O_Enode_Type (OE_Function_Call);
+ Res : O_Enode;
+ begin
+ if Assocs.Interfaces /= null then
+ -- Not enough arguments.
+ raise Syntax_Error;
+ end if;
+ if Assocs.Subprg.Dtype = null then
+ -- This is a procedure.
+ raise Syntax_Error;
+ end if;
+
+ Res := new O_Enode_Call'(Kind => OE_Function_Call,
+ Rtype => Assocs.Subprg.Dtype,
+ Ref => False,
+ Func => Assocs.Subprg,
+ Assoc => Assocs.First);
+ return Res;
+ end New_Function_Call;
+
+ procedure New_Procedure_Call (Assocs : in out O_Assoc_List)
+ is
+ N : O_Snode;
+ begin
+ if Assocs.Interfaces /= null then
+ -- Not enough arguments.
+ raise Syntax_Error;
+ end if;
+ if Assocs.Subprg.Dtype /= null then
+ -- This is a function.
+ raise Syntax_Error;
+ end if;
+ N := new O_Snode_Type (ON_Call_Stmt);
+ N.Proc := Assocs.Subprg;
+ N.Assoc := Assocs.First;
+ Add_Stmt (N);
+ end New_Procedure_Call;
+
+ procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode);
+
+ procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode)
+ is
+ subtype O_Snode_If is O_Snode_Type (ON_If_Stmt);
+ N : O_Snode;
+ begin
+ -- Note: no checks are performed here, since they are done in
+ -- new_elsif_stmt.
+ N := new O_Snode_If'(Kind => ON_If_Stmt,
+ Next => null,
+ Lineno => 0,
+ Elsifs => null,
+ If_Last => null);
+ Add_Stmt (N);
+ Push_Stmt_Scope (new Stmt_If_Scope_Type'(Kind => Stmt_If,
+ Parent => N,
+ Prev => Current_Stmt_Scope,
+ Last_Elsif => null));
+ New_Elsif_Stmt (Block, Cond);
+ end Start_If_Stmt;
+
+ procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode)
+ is
+ pragma Unreferenced (Block);
+ N : O_Snode;
+ begin
+ if Cond /= null then
+ if Cond.Rtype.Kind /= ON_Boolean_Type then
+ raise Type_Error;
+ end if;
+ Check_Ref (Cond);
+ end if;
+ N := new O_Snode_Type (ON_Elsif_Stmt);
+ N.all := O_Snode_Type'(Kind => ON_Elsif_Stmt,
+ Next => null,
+ Lineno => 0,
+ Cond => Cond,
+ Next_Elsif => null);
+ if Current_Stmt_Scope.Kind /= Stmt_If then
+ raise Syntax_Error;
+ end if;
+ Add_Stmt (N);
+ if Current_Stmt_Scope.Last_Elsif = null then
+ Current_Stmt_Scope.Parent.Elsifs := N;
+ else
+ -- Check for double 'else'
+ if Current_Stmt_Scope.Last_Elsif.Cond = null then
+ raise Syntax_Error;
+ end if;
+ Current_Stmt_Scope.Last_Elsif.Next_Elsif := N;
+ end if;
+ Current_Stmt_Scope.Last_Elsif := N;
+ end New_Elsif_Stmt;
+
+ procedure New_Else_Stmt (Block : in out O_If_Block) is
+ begin
+ New_Elsif_Stmt (Block, null);
+ end New_Else_Stmt;
+
+ procedure Finish_If_Stmt (Block : in out O_If_Block)
+ is
+ pragma Unreferenced (Block);
+ Parent : O_Snode;
+ begin
+ Parent := Current_Stmt_Scope.Parent;
+ Pop_Stmt_Scope (Stmt_If);
+ Parent.If_Last := Current_Decl_Scope.Last_Stmt;
+ end Finish_If_Stmt;
+
+ procedure Start_Loop_Stmt (Label : out O_Snode)
+ is
+ subtype O_Snode_Loop_Type is O_Snode_Type (ON_Loop_Stmt);
+ begin
+ Current_Loop_Level := Current_Loop_Level + 1;
+ Label := new O_Snode_Loop_Type'(Kind => ON_Loop_Stmt,
+ Next => null,
+ Lineno => 0,
+ Loop_Last => null,
+ Loop_Level => Current_Loop_Level);
+ Add_Stmt (Label);
+ Push_Stmt_Scope (new Stmt_Loop_Scope_Type'(Kind => Stmt_Loop,
+ Parent => Label,
+ Prev => Current_Stmt_Scope));
+ end Start_Loop_Stmt;
+
+ procedure Finish_Loop_Stmt (Label : in out O_Snode)
+ is
+ pragma Unreferenced (Label);
+ Parent : O_Snode;
+ begin
+ Parent := Current_Stmt_Scope.Parent;
+ Pop_Stmt_Scope (Stmt_Loop);
+ Parent.Loop_Last := Current_Decl_Scope.Last_Stmt;
+ Current_Loop_Level := Current_Loop_Level - 1;
+ end Finish_Loop_Stmt;
+
+ procedure New_Exit_Next_Stmt (Kind : ON_Stmt_Kind; L : O_Snode)
+ is
+ N : O_Snode;
+ begin
+ N := new O_Snode_Type (Kind);
+ N.Next := null;
+ N.Loop_Id := L;
+ Add_Stmt (N);
+ end New_Exit_Next_Stmt;
+
+ procedure New_Exit_Stmt (L : O_Snode) is
+ begin
+ New_Exit_Next_Stmt (ON_Exit_Stmt, L);
+ end New_Exit_Stmt;
+
+ procedure New_Next_Stmt (L : O_Snode) is
+ begin
+ New_Exit_Next_Stmt (ON_Next_Stmt, L);
+ end New_Next_Stmt;
+
+ procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode)
+ is
+ subtype O_Snode_Case_Type is O_Snode_Type (ON_Case_Stmt);
+ N : O_Snode;
+ begin
+ case Value.Rtype.Kind is
+ when ON_Boolean_Type
+ | ON_Unsigned_Type
+ | ON_Signed_Type
+ | ON_Enum_Type =>
+ null;
+ when others =>
+ raise Type_Error;
+ end case;
+ Check_Ref (Value);
+ N := new O_Snode_Case_Type'(Kind => ON_Case_Stmt,
+ Next => null,
+ Lineno => 0,
+ Case_Last => null,
+ Selector => Value,
+ Branches => null);
+ Block.Case_Stmt := N;
+ Add_Stmt (N);
+ Push_Stmt_Scope (new Stmt_Case_Scope_Type'(Kind => Stmt_Case,
+ Parent => N,
+ Prev => Current_Stmt_Scope,
+ Last_Branch => null,
+ Last_Choice => null,
+ Case_Type => Value.Rtype));
+ end Start_Case_Stmt;
+
+ procedure Start_Choice (Block : in out O_Case_Block)
+ is
+ N : O_Snode;
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are adding a branch outside a case statment.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Last_Choice /= null then
+ -- You are creating branch while the previous one was not finished.
+ raise Syntax_Error;
+ end if;
+
+ N := new O_Snode_Type (ON_When_Stmt);
+ N.all := O_Snode_Type'(Kind => ON_When_Stmt,
+ Next => null,
+ Lineno => 0,
+ Branch_Parent => Block.Case_Stmt,
+ Choice_List => null,
+ Next_Branch => null);
+ if Current_Stmt_Scope.Last_Branch = null then
+ Current_Stmt_Scope.Parent.Branches := N;
+ else
+ Current_Stmt_Scope.Last_Branch.Next_Branch := N;
+ end if;
+ Current_Stmt_Scope.Last_Branch := N;
+ Current_Stmt_Scope.Last_Choice := null;
+ Add_Stmt (N);
+ end Start_Choice;
+
+ procedure Add_Choice (Block : in out O_Case_Block; Choice : O_Choice)
+ is
+ pragma Unreferenced (Block);
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are adding a choice not inside a case statement.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Last_Branch = null then
+ -- You are not inside a branch.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Last_Choice = null then
+ if Current_Stmt_Scope.Last_Branch.Choice_List /= null then
+ -- The branch was already closed.
+ raise Syntax_Error;
+ end if;
+ Current_Stmt_Scope.Last_Branch.Choice_List := Choice;
+ else
+ Current_Stmt_Scope.Last_Choice.Next := Choice;
+ end if;
+ Current_Stmt_Scope.Last_Choice := Choice;
+ end Add_Choice;
+
+ procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode)
+ is
+ N : O_Choice;
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are creating a choice not inside a case statement.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Case_Type /= Expr.Ctype then
+ -- Expr type is not the same as choice type.
+ raise Type_Error;
+ end if;
+
+ N := new O_Choice_Type (ON_Choice_Expr);
+ N.all := O_Choice_Type'(Kind => ON_Choice_Expr,
+ Next => null,
+ Expr => Expr);
+ Add_Choice (Block, N);
+ end New_Expr_Choice;
+
+ procedure New_Range_Choice (Block : in out O_Case_Block;
+ Low, High : O_Cnode)
+ is
+ N : O_Choice;
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are creating a choice not inside a case statement.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Case_Type /= Low.Ctype
+ or Current_Stmt_Scope.Case_Type /= High.Ctype
+ then
+ -- Low/High type is not the same as choice type.
+ raise Type_Error;
+ end if;
+
+ N := new O_Choice_Type (ON_Choice_Range);
+ N.all := O_Choice_Type'(Kind => ON_Choice_Range,
+ Next => null,
+ Low => Low,
+ High => High);
+ Add_Choice (Block, N);
+ end New_Range_Choice;
+
+ procedure New_Default_Choice (Block : in out O_Case_Block)
+ is
+ N : O_Choice;
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are creating a choice not inside a case statement.
+ raise Syntax_Error;
+ end if;
+
+ N := new O_Choice_Type (ON_Choice_Default);
+ N.all := O_Choice_Type'(Kind => ON_Choice_Default,
+ Next => null);
+ Add_Choice (Block, N);
+ end New_Default_Choice;
+
+ procedure Finish_Choice (Block : in out O_Case_Block)
+ is
+ pragma Unreferenced (Block);
+ begin
+ if Current_Stmt_Scope.Kind /= Stmt_Case then
+ -- You are adding a choice not inside a case statement.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Last_Branch = null then
+ -- You are not inside a branch.
+ raise Syntax_Error;
+ end if;
+ if Current_Stmt_Scope.Last_Choice = null then
+ -- The branch is empty or you are not inside a branch.
+ raise Syntax_Error;
+ end if;
+ Current_Stmt_Scope.Last_Choice := null;
+ end Finish_Choice;
+
+ procedure Finish_Case_Stmt (Block : in out O_Case_Block)
+ is
+ pragma Unreferenced (Block);
+ Parent : O_Snode;
+ begin
+ Parent := Current_Stmt_Scope.Parent;
+ Pop_Stmt_Scope (Stmt_Case);
+ Parent.Case_Last := Current_Decl_Scope.Last_Stmt;
+ end Finish_Case_Stmt;
+
+ procedure Init is
+ begin
+ Top := new O_Snode_Type (ON_Declare_Stmt);
+ Push_Decl_Scope (Top);
+ end Init;
+
+ procedure Finish is
+ begin
+ Pop_Decl_Scope;
+ end Finish;
+end Ortho_Debug;
diff --git a/src/ortho/debug/ortho_debug.private.ads b/src/ortho/debug/ortho_debug.private.ads
new file mode 100644
index 000000000..69ee16cf7
--- /dev/null
+++ b/src/ortho/debug/ortho_debug.private.ads
@@ -0,0 +1,467 @@
+-- Ortho debug back-end declarations.
+-- 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.
+
+with Interfaces; use Interfaces;
+with Ortho_Ident;
+use Ortho_Ident;
+
+-- Interface to create nodes.
+package Ortho_Debug is
+ procedure Init;
+ procedure Finish;
+
+private
+ -- This back-end supports nested subprograms.
+ Has_Nested_Subprograms : constant Boolean := True;
+
+ -- A node for a type.
+ type O_Tnode_Type (<>);
+ type O_Tnode is access O_Tnode_Type;
+
+ -- A node for a statement.
+ type O_Snode_Type (<>);
+ type O_Snode is access O_Snode_Type;
+
+ Top : O_Snode;
+
+ type Str_Acc is access String;
+
+ type Decl_Scope_Type;
+ type Decl_Scope_Acc is access Decl_Scope_Type;
+
+ type On_Decl_Kind is
+ (ON_Type_Decl, ON_Completed_Type_Decl,
+ ON_Const_Decl, ON_Var_Decl, ON_Interface_Decl,
+ ON_Function_Decl, ON_Function_Body,
+ ON_Const_Value,
+ ON_Debug_Line_Decl, ON_Debug_Comment_Decl, ON_Debug_Filename_Decl);
+
+ type O_Dnode_Type (<>);
+ type O_Dnode is access O_Dnode_Type;
+
+ O_Dnode_Null : constant O_Dnode := null;
+
+ type O_Dnode_Type (Kind : On_Decl_Kind) is record
+ Next : O_Dnode;
+ Name : O_Ident;
+ Dtype : O_Tnode;
+ Storage : O_Storage;
+ -- Declare statement in which the declaration appears.
+ Scope : O_Snode;
+ -- Line number, for regen.
+ Lineno : Natural;
+ case Kind is
+ when ON_Type_Decl =>
+ null;
+ when ON_Completed_Type_Decl =>
+ null;
+ when ON_Const_Decl =>
+ Const_Value : O_Dnode;
+ when ON_Const_Value =>
+ Const_Decl : O_Dnode;
+ Value : O_Cnode;
+ when ON_Var_Decl =>
+ null;
+ when ON_Function_Decl =>
+ Interfaces : O_Dnode;
+ Func_Body : O_Dnode;
+ Alive : Boolean;
+ when ON_Function_Body =>
+ Func_Decl : O_Dnode;
+ Func_Stmt : O_Snode;
+ when ON_Interface_Decl =>
+ Func_Scope : O_Dnode;
+ when ON_Debug_Line_Decl =>
+ Line : Natural;
+ when ON_Debug_Comment_Decl =>
+ Comment : Str_Acc;
+ when ON_Debug_Filename_Decl =>
+ Filename : Str_Acc;
+ end case;
+ end record;
+
+ -- A node for a record element.
+ type O_Fnode_Type;
+ type O_Fnode is access O_Fnode_Type;
+
+ O_Fnode_Null : constant O_Fnode := null;
+
+ type O_Fnode_Type is record
+ -- Record type.
+ Parent : O_Tnode;
+ -- Next field in the record.
+ Next : O_Fnode;
+ -- Name of the record field.
+ Ident : O_Ident;
+ -- Type of the record field.
+ Ftype : O_Tnode;
+ -- Offset in the field.
+ Offset : Unsigned_32;
+ end record;
+
+ type O_Anode_Type;
+ type O_Anode is access O_Anode_Type;
+ type O_Anode_Type is record
+ Next : O_Anode;
+ Formal : O_Dnode;
+ Actual : O_Enode;
+ end record;
+
+ type OC_Kind is
+ (
+ OC_Boolean_Lit,
+ OC_Unsigned_Lit,
+ OC_Signed_Lit,
+ OC_Float_Lit,
+ OC_Enum_Lit,
+ OC_Null_Lit,
+ OC_Sizeof_Lit,
+ OC_Alignof_Lit,
+ OC_Offsetof_Lit,
+ OC_Aggregate,
+ OC_Aggr_Element,
+ OC_Union_Aggr,
+ OC_Address,
+ OC_Unchecked_Address,
+ OC_Subprogram_Address
+ );
+ type O_Cnode_Type (Kind : OC_Kind) is record
+ -- Type of the constant.
+ Ctype : O_Tnode;
+ -- True if referenced.
+ Ref : Boolean;
+ case Kind is
+ when OC_Unsigned_Lit =>
+ U_Val : Unsigned_64;
+ when OC_Signed_Lit =>
+ S_Val : Integer_64;
+ when OC_Float_Lit =>
+ F_Val : IEEE_Float_64;
+ when OC_Boolean_Lit =>
+ B_Val : Boolean;
+ B_Id : O_Ident;
+ when OC_Enum_Lit =>
+ E_Val : Integer;
+ E_Next : O_Cnode;
+ E_Name : O_Ident;
+ when OC_Null_Lit =>
+ null;
+ when OC_Sizeof_Lit
+ | OC_Alignof_Lit =>
+ S_Type : O_Tnode;
+ when OC_Offsetof_Lit =>
+ Off_Field : O_Fnode;
+ when OC_Aggregate =>
+ Aggr_Els : O_Cnode;
+ when OC_Union_Aggr =>
+ Uaggr_Field : O_Fnode;
+ Uaggr_Value : O_Cnode;
+ when OC_Aggr_Element =>
+ Aggr_Value : O_Cnode;
+ Aggr_Next : O_Cnode;
+ when OC_Address
+ | OC_Unchecked_Address
+ | OC_Subprogram_Address =>
+ Decl : O_Dnode;
+ end case;
+ end record;
+
+ type O_Cnode is access O_Cnode_Type;
+ O_Cnode_Null : constant O_Cnode := null;
+
+ type OE_Kind is
+ (
+ -- Literals.
+ OE_Lit,
+
+ -- Dyadic operations.
+ OE_Add_Ov, -- OE_Dyadic_Op_Kind
+ OE_Sub_Ov, -- OE_Dyadic_Op_Kind
+ OE_Mul_Ov, -- OE_Dyadic_Op_Kind
+ OE_Div_Ov, -- OE_Dyadic_Op_Kind
+ OE_Rem_Ov, -- OE_Dyadic_Op_Kind
+ OE_Mod_Ov, -- OE_Dyadic_Op_Kind
+ OE_Exp_Ov, -- OE_Dyadic_Op_Kind
+
+ -- Binary operations.
+ OE_And, -- OE_Dyadic_Op_Kind
+ OE_Or, -- OE_Dyadic_Op_Kind
+ OE_Xor, -- OE_Dyadic_Op_Kind
+ OE_And_Then, -- OE_Dyadic_Op_Kind
+ OE_Or_Else, -- OE_Dyadic_Op_Kind
+
+ -- Monadic operations.
+ OE_Not, -- OE_Monadic_Op_Kind
+ OE_Neg_Ov, -- OE_Monadic_Op_Kind
+ OE_Abs_Ov, -- OE_Monadic_Op_Kind
+
+ -- Comparaisons
+ OE_Eq, -- OE_Compare_Op_Kind
+ OE_Neq, -- OE_Compare_Op_Kind
+ OE_Le, -- OE_Compare_Op_Kind
+ OE_Lt, -- OE_Compare_Op_Kind
+ OE_Ge, -- OE_Compare_Op_Kind
+ OE_Gt, -- OE_Compare_Op_Kind
+
+ -- Misc.
+ OE_Convert_Ov,
+ OE_Address,
+ OE_Unchecked_Address,
+ OE_Alloca,
+ OE_Function_Call,
+
+ OE_Value,
+ OE_Nil
+ );
+
+ subtype OE_Dyadic_Expr_Kind is OE_Kind range OE_Add_Ov .. OE_Or_Else;
+ subtype OE_Monadic_Expr_Kind is OE_Kind range OE_Not .. OE_Abs_Ov;
+ subtype OE_Compare_Expr_Kind is OE_Kind range OE_Eq .. OE_Gt;
+
+ type O_Enode_Type (Kind : OE_Kind);
+ type O_Enode is access O_Enode_Type;
+ O_Enode_Null : constant O_Enode := null;
+
+ type O_Enode_Type (Kind : OE_Kind) is record
+ -- Type of the result.
+ Rtype : O_Tnode;
+ -- True if referenced.
+ Ref : Boolean;
+ case Kind is
+ when OE_Dyadic_Expr_Kind
+ | OE_Compare_Expr_Kind =>
+ Left : O_Enode;
+ Right : O_Enode;
+ when OE_Monadic_Expr_Kind =>
+ Operand : O_Enode;
+ when OE_Lit =>
+ Lit : O_Cnode;
+ when OE_Address
+ | OE_Unchecked_Address =>
+ Lvalue : O_Lnode;
+ when OE_Convert_Ov =>
+ Conv : O_Enode;
+ when OE_Function_Call =>
+ Func : O_Dnode;
+ Assoc : O_Anode;
+ when OE_Value =>
+ Value : O_Lnode;
+ when OE_Alloca =>
+ A_Size : O_Enode;
+ when OE_Nil =>
+ null;
+ end case;
+ end record;
+ type O_Enode_Array is array (Natural range <>) of O_Enode;
+ type O_Enode_Array_Acc is access O_Enode_Array;
+
+ type OL_Kind is
+ (
+ -- Name.
+ OL_Obj,
+ OL_Indexed_Element,
+ OL_Slice,
+ OL_Selected_Element,
+ OL_Access_Element
+
+ -- Variable, constant, parameter reference.
+ -- This allows to read/write a declaration.
+ --OL_Var_Ref,
+ --OL_Const_Ref,
+ --OL_Param_Ref
+ );
+
+ type O_Lnode_Type (Kind : OL_Kind);
+ type O_Lnode is access O_Lnode_Type;
+ O_Lnode_Null : constant O_Lnode := null;
+
+ type O_Lnode_Type (Kind : OL_Kind) is record
+ -- Type of the result.
+ Rtype : O_Tnode;
+ -- True if referenced.
+ Ref : Boolean;
+ case Kind is
+ when OL_Obj =>
+ Obj : O_Dnode;
+ when OL_Indexed_Element =>
+ Array_Base : O_Lnode;
+ Index : O_Enode;
+ when OL_Slice =>
+ Slice_Base : O_Lnode;
+ Slice_Index : O_Enode;
+ when OL_Selected_Element =>
+ Rec_Base : O_Lnode;
+ Rec_El : O_Fnode;
+ when OL_Access_Element =>
+ Acc_Base : O_Enode;
+-- when OL_Var_Ref
+-- | OL_Const_Ref
+-- | OL_Param_Ref =>
+-- Decl : O_Dnode;
+ end case;
+ end record;
+
+ O_Tnode_Null : constant O_Tnode := null;
+ type ON_Type_Kind is
+ (ON_Boolean_Type, ON_Enum_Type,
+ ON_Unsigned_Type, ON_Signed_Type, ON_Float_Type, ON_Array_Type,
+ ON_Array_Sub_Type, ON_Record_Type, ON_Union_Type, ON_Access_Type);
+ type O_Tnode_Type (Kind : ON_Type_Kind) is record
+ Decl : O_Dnode;
+ -- True if the type was first created as an uncomplete type.
+ Uncomplete : Boolean;
+ -- True if the type is complete.
+ Complete : Boolean;
+ case Kind is
+ when ON_Boolean_Type =>
+ True_N : O_Cnode;
+ False_N : O_Cnode;
+ when ON_Unsigned_Type
+ | ON_Signed_Type =>
+ Int_Size : Natural;
+ when ON_Float_Type =>
+ null;
+ when ON_Enum_Type =>
+ Nbr : Natural;
+ Literals: O_Cnode;
+ when ON_Array_Type =>
+ El_Type : O_Tnode;
+ Index_Type : O_Tnode;
+ when ON_Access_Type =>
+ D_Type : O_Tnode;
+ when ON_Record_Type
+ | ON_Union_Type =>
+ Elements : O_Fnode;
+ when ON_Array_Sub_Type =>
+ Length : O_Cnode;
+ Base_Type : O_Tnode;
+ end case;
+ end record;
+
+ type ON_Choice_Kind is (ON_Choice_Expr, ON_Choice_Range, ON_Choice_Default);
+ type O_Choice_Type (Kind : ON_Choice_Kind);
+ type O_Choice is access O_Choice_Type;
+ type O_Choice_Type (Kind : ON_Choice_Kind) is record
+ Next : O_Choice;
+ case Kind is
+ when ON_Choice_Expr =>
+ Expr : O_Cnode;
+ when ON_Choice_Range =>
+ Low, High : O_Cnode;
+ when ON_Choice_Default =>
+ null;
+ end case;
+ end record;
+
+ O_Snode_Null : constant O_Snode := null;
+ type ON_Stmt_Kind is
+ (ON_Declare_Stmt, ON_Assign_Stmt, ON_Return_Stmt, ON_If_Stmt,
+ ON_Elsif_Stmt, ON_Loop_Stmt, ON_Exit_Stmt, ON_Next_Stmt,
+ ON_Case_Stmt, ON_When_Stmt, ON_Call_Stmt,
+ ON_Debug_Line_Stmt, ON_Debug_Comment_Stmt);
+ type O_Snode_Type (Kind : ON_Stmt_Kind) is record
+ Next : O_Snode;
+ Lineno : Natural;
+ case Kind is
+ when ON_Declare_Stmt =>
+ Decls : O_Dnode;
+ Stmts : O_Snode;
+ -- True if the statement is currently open.
+ Alive : Boolean;
+ when ON_Assign_Stmt =>
+ Target : O_Lnode;
+ Value : O_Enode;
+ when ON_Return_Stmt =>
+ Ret_Val : O_Enode;
+ when ON_If_Stmt =>
+ Elsifs : O_Snode;
+ If_Last : O_Snode;
+ when ON_Elsif_Stmt =>
+ Cond : O_Enode;
+ Next_Elsif : O_Snode;
+ when ON_Loop_Stmt =>
+ Loop_Last : O_Snode;
+ Loop_Level : Natural;
+ when ON_Exit_Stmt
+ | ON_Next_Stmt =>
+ Loop_Id : O_Snode;
+ when ON_Case_Stmt =>
+ Selector : O_Enode;
+ -- Simply linked list of branches
+ Branches : O_Snode;
+ Case_Last : O_Snode;
+ when ON_When_Stmt =>
+ -- The corresponding 'case'
+ Branch_Parent : O_Snode;
+ Choice_List : O_Choice;
+ Next_Branch : O_Snode;
+ when ON_Call_Stmt =>
+ Proc : O_Dnode;
+ Assoc : O_Anode;
+ when ON_Debug_Line_Stmt =>
+ Line : Natural;
+ when ON_Debug_Comment_Stmt =>
+ Comment : Str_Acc;
+ end case;
+ end record;
+
+ type O_Inter_List is record
+ Func : O_Dnode;
+ Last : O_Dnode;
+ end record;
+
+ type O_Element_List is record
+ -- The type definition.
+ Res : O_Tnode;
+ -- The last element added.
+ Last : O_Fnode;
+ end record;
+
+ type O_Record_Aggr_List is record
+ Res : O_Cnode;
+ Last : O_Cnode;
+ Field : O_Fnode;
+ end record;
+
+ type O_Array_Aggr_List is record
+ Res : O_Cnode;
+ Last : O_Cnode;
+ El_Type : O_Tnode;
+ end record;
+
+ type O_Assoc_List is record
+ Subprg : O_Dnode;
+ Interfaces : O_Dnode;
+ First, Last : O_Anode;
+ end record;
+
+ type O_Enum_List is record
+ -- The type built.
+ Res : O_Tnode;
+
+ -- the chain of declarations.
+ Last : O_Cnode;
+ end record;
+ type O_Case_Block is record
+ Case_Stmt : O_Snode;
+ end record;
+
+ type O_If_Block is record
+ null;
+ end record;
+end Ortho_Debug;
diff --git a/src/ortho/debug/ortho_debug_front.ads b/src/ortho/debug/ortho_debug_front.ads
new file mode 100644
index 000000000..17e32c9ed
--- /dev/null
+++ b/src/ortho/debug/ortho_debug_front.ads
@@ -0,0 +1,20 @@
+-- Ortho debug interface with front-end.
+-- 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 Ortho_Front;
+package Ortho_Debug_Front renames Ortho_Front;
diff --git a/src/ortho/debug/ortho_ident.ads b/src/ortho/debug/ortho_ident.ads
new file mode 100644
index 000000000..46aa8854d
--- /dev/null
+++ b/src/ortho/debug/ortho_ident.ads
@@ -0,0 +1,20 @@
+-- Ortho debug back-end interface with identifiers package.
+-- 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 Ortho_Ident_Simple;
+package Ortho_Ident renames Ortho_Ident_Simple;
diff --git a/src/ortho/debug/ortho_ident_hash.adb b/src/ortho/debug/ortho_ident_hash.adb
new file mode 100644
index 000000000..60ab89586
--- /dev/null
+++ b/src/ortho/debug/ortho_ident_hash.adb
@@ -0,0 +1,72 @@
+-- Ortho debug hashed identifiers implementation.
+-- 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.
+
+package body Ortho_Ident_Hash is
+ type O_Ident_Array is array (Hash_Type range <>) of O_Ident;
+ Hash_Max : constant Hash_Type := 511;
+ Symtable : O_Ident_Array (0 .. Hash_Max - 1) := (others => null);
+
+ function Get_Identifier (Str : String) return O_Ident
+ is
+ Hash : Hash_Type;
+ Ent : Hash_Type;
+ Res : O_Ident;
+ begin
+ -- 1. Compute Hash.
+ Hash := 0;
+ for I in Str'Range loop
+ Hash := Hash * 31 + Character'Pos (Str (I));
+ end loop;
+
+ -- 2. Search.
+ Ent := Hash mod Hash_Max;
+ Res := Symtable (Ent);
+ while Res /= null loop
+ if Res.Hash = Hash and then Res.Ident.all = Str then
+ return Res;
+ end if;
+ Res := Res.Next;
+ end loop;
+
+ -- Not found: add.
+ Res := new Ident_Type'(Hash => Hash,
+ Ident => new String'(Str),
+ Next => Symtable (Ent));
+ Symtable (Ent) := Res;
+ return Res;
+ end Get_Identifier;
+
+ function Get_String (Id : O_Ident) return String is
+ begin
+ if Id = null then
+ return "?ANON?";
+ else
+ return Id.Ident.all;
+ end if;
+ end Get_String;
+
+ function Is_Nul (Id : O_Ident) return Boolean is
+ begin
+ return Id = null;
+ end Is_Nul;
+
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean is
+ begin
+ return Id.Ident.all = Str;
+ end Is_Equal;
+end Ortho_Ident_Hash;
diff --git a/src/ortho/debug/ortho_ident_hash.ads b/src/ortho/debug/ortho_ident_hash.ads
new file mode 100644
index 000000000..a6e4a56cc
--- /dev/null
+++ b/src/ortho/debug/ortho_ident_hash.ads
@@ -0,0 +1,46 @@
+-- Ortho debug hashed identifiers implementation.
+-- 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.
+
+package Ortho_Ident_Hash is
+ type O_Ident is private;
+ O_Ident_Nul : constant O_Ident;
+
+ function Get_Identifier (Str : String) return O_Ident;
+ function Get_String (Id : O_Ident) return String;
+ function Is_Equal (L, R : O_Ident) return Boolean renames "=";
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean;
+ function Is_Nul (Id : O_Ident) return Boolean;
+private
+ type Hash_Type is mod 2**32;
+
+ type String_Acc is access constant String;
+
+ -- Symbol table.
+ type Ident_Type;
+ type O_Ident is access Ident_Type;
+ type Ident_type is record
+ -- The hash for the symbol.
+ Hash : Hash_Type;
+ -- Identification of the symbol.
+ Ident : String_Acc;
+ -- Next symbol with the same collision.
+ Next : O_Ident;
+ end record;
+
+ O_Ident_Nul : constant O_Ident := null;
+end Ortho_Ident_Hash;
diff --git a/src/ortho/debug/ortho_ident_simple.adb b/src/ortho/debug/ortho_ident_simple.adb
new file mode 100644
index 000000000..83b9756f8
--- /dev/null
+++ b/src/ortho/debug/ortho_ident_simple.adb
@@ -0,0 +1,44 @@
+-- Ortho debug identifiers simple implementation.
+-- 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.
+
+package body Ortho_Ident_Simple is
+ function Get_Identifier (Str : String) return O_Ident
+ is
+ begin
+ return new String'(Str);
+ end Get_Identifier;
+
+ function Get_String (Id : O_Ident) return String is
+ begin
+ if Id = null then
+ return "?ANON?";
+ else
+ return Id.all;
+ end if;
+ end Get_String;
+
+ function Is_Nul (Id : O_Ident) return Boolean is
+ begin
+ return Id = null;
+ end Is_Nul;
+
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean is
+ begin
+ return Id.all = Str;
+ end Is_Equal;
+end Ortho_Ident_Simple;
diff --git a/src/ortho/debug/ortho_ident_simple.ads b/src/ortho/debug/ortho_ident_simple.ads
new file mode 100644
index 000000000..f94fe1938
--- /dev/null
+++ b/src/ortho/debug/ortho_ident_simple.ads
@@ -0,0 +1,31 @@
+-- Ortho debug identifiers simple implementation.
+-- 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.
+
+package Ortho_Ident_Simple is
+ type O_Ident is private;
+ O_Ident_Nul : constant O_Ident;
+
+ function Get_Identifier (Str : String) return O_Ident;
+ function Get_String (Id : O_Ident) return String;
+ function Is_Equal (L, R : O_Ident) return Boolean renames "=";
+ function Is_Equal (Id : O_Ident; Str : String) return Boolean;
+ function Is_Nul (Id : O_Ident) return Boolean;
+private
+ type O_Ident is access String;
+ O_Ident_Nul : constant O_Ident := null;
+end Ortho_Ident_Simple;
diff --git a/src/ortho/debug/ortho_nodes.ads b/src/ortho/debug/ortho_nodes.ads
new file mode 100644
index 000000000..8ade66722
--- /dev/null
+++ b/src/ortho/debug/ortho_nodes.ads
@@ -0,0 +1,21 @@
+-- Ortho debug back-end interface with front-end.
+-- 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 Ortho_Debug;
+
+package Ortho_Nodes renames Ortho_Debug;
diff --git a/src/ortho/gcc/Makefile b/src/ortho/gcc/Makefile
new file mode 100644
index 000000000..5aafb31c7
--- /dev/null
+++ b/src/ortho/gcc/Makefile
@@ -0,0 +1,86 @@
+ortho_srcdir=..
+orthobe_srcdir=$(ortho_srcdir)/gcc
+agcc_objdir=.
+agcc_srcdir=$(ortho_srcdir)/gcc
+SED=sed
+BE=gcc
+GNATMAKE=gnatmake
+CC=gcc
+CXX=g++
+COMPILER=$(CXX)
+LINKER=$(CXX)
+
+# Modify AGCC_GCCSRC_DIR and AGCC_GCCOBJ_DIR for your environment
+AGCC_GCCSRC_DIR:=$(HOME)/Projects/gcc4.9.2/source/gcc-4.9.2/
+AGCC_GCCOBJ_DIR:=$(HOME)/Projects/gcc4.9.2/build/
+
+# Supplied by main GCC Makefile, copied here for compatibility with same
+GMPLIBS = -L$(AGCC_GCCOBJ_DIR)./gmp/.libs -L$(AGCC_GCCOBJ_DIR)./mpfr/.libs \
+ -L$(AGCC_GCCOBJ_DIR)./mpc/src/.libs -lmpc -lmpfr -lgmp
+GMPINC = -I$(AGCC_GCCOBJ_DIR)./gmp -I$(AGCC_GCCSRC_DIR)/gmp \
+ -I$(AGCC_GCCOBJ_DIR)./mpfr -I$(AGCC_GCCSRC_DIR)/mpfr \
+ -I$(AGCC_GCCSRC_DIR)/mpc/src
+
+HOST_LIBS =
+ZLIB=-lz
+
+# Override variables in Makefile.conf for your environment
+-include $(orthobe_srcdir)/Makefile.conf
+
+all: $(ortho_exec)
+
+ORTHO_BASENAME=ortho_gcc
+include $(ortho_srcdir)/Makefile.inc
+
+AGCC_INC_FLAGS=-I$(AGCC_GCCOBJ_DIR)/gcc -I$(AGCC_GCCSRC_DIR)/include \
+ -I$(AGCC_GCCSRC_DIR)/gcc -I$(AGCC_GCCSRC_DIR)/gcc/config \
+ -I$(AGCC_GCCSRC_DIR)/libcpp/include $(GMPINC)
+AGCC_CFLAGS=-g -Wall -DIN_GCC $(AGCC_INC_FLAGS)
+
+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)
+
+AGCC_LOCAL_OBJS=ortho-lang.o
+
+AGCC_DEPS := $(AGCC_LOCAL_OBJS)
+AGCC_OBJS := $(AGCC_LOCAL_OBJS) \
+ $(AGCC_GCCOBJ_DIR)gcc/attribs.o \
+ $(AGCC_GCCOBJ_DIR)libcpp/libcpp.a \
+ $(AGCC_GCCOBJ_DIR)libiberty/libiberty.a
+
+LIBBACKTRACE = $(AGCC_GCCOBJ_DIR)/libbacktrace/.libs/libbacktrace.a
+LIBDECNUMBER = $(AGCC_GCCOBJ_DIR)/libdecnumber/libdecnumber.a
+LIBIBERTY = $(AGCC_GCCOBJ_DIR)/libiberty/libiberty.a
+CPPLIB= # Not needed for GHDL
+
+BACKEND = $(AGCC_GCCOBJ_DIR)/gcc/libbackend.a \
+ $(AGCC_GCCOBJ_DIR)/gcc/libcommon-target.a
+
+BACKENDLIBS = $(CLOOGLIBS) $(GMPLIBS) $(PLUGINLIBS) $(HOST_LIBS) \
+ $(ZLIB)
+LIBS = $(AGCC_GCCOBJ_DIR)/gcc/libcommon.a \
+ $(CPPLIB) $(LIBINTL) $(LIBICONV) $(LIBBACKTRACE) \
+ $(LIBIBERTY) $(LIBDECNUMBER) $(HOST_LIBS)
+
+$(ortho_exec): $(AGCC_DEPS) $(orthobe_srcdir)/ortho_gcc.ads force
+ $(GNATMAKE) -m -o $@ -g -aI$(ortho_srcdir) \
+ -aI$(ortho_srcdir)/gcc $(GNAT_FLAGS) ortho_gcc-main \
+ -bargs -E -largs --LINK=$(LINKER) $(AGCC_OBJS) \
+ $(BACKEND) $(LIBS) $(BACKENDLIBS)
+
+agcc-clean: force
+ $(RM) -f $(agcc_objdir)/*.o
+ $(RM) -f $(agcc_srcdir)/*~
+
+clean: agcc-clean
+ $(RM) -f *.o *.ali ortho_nodes-main
+ $(RM) b~*.ad? *~
+
+distclean: clean agcc-clean
+
+
+force:
+
+.PHONY: force all clean agcc-clean
diff --git a/src/ortho/gcc/Makefile.conf.linux b/src/ortho/gcc/Makefile.conf.linux
new file mode 100644
index 000000000..00ea91728
--- /dev/null
+++ b/src/ortho/gcc/Makefile.conf.linux
@@ -0,0 +1,4 @@
+# Example Makefile.conf
+# Copy this file to Makefile.conf and edit as necessary for your platform
+
+HOST_LIBS = -ldl -lstdc++
diff --git a/src/ortho/gcc/lang.opt b/src/ortho/gcc/lang.opt
new file mode 100644
index 000000000..562fbe08d
--- /dev/null
+++ b/src/ortho/gcc/lang.opt
@@ -0,0 +1,96 @@
+Language
+vhdl
+
+-std=
+vhdl Joined
+Select the vhdl standard
+
+-compile-standard
+vhdl
+Used during compiler build to compile the std.standard package
+
+-bootstrap
+vhdl
+Used during compiler build to compile std packages
+
+-work=
+vhdl Joined
+Set the name of the work library
+
+-workdir=
+vhdl Joined
+Set the directory of the work library
+
+P
+vhdl JoinedOrMissing
+;-P Add to the end of the vhdl library path
+
+-elab
+vhdl Separate
+--elab Used internally during elaboration of
+
+-anaelab
+vhdl Separate
+--anaelab Used internally during elaboration of
+
+; -c is a driver option for gcc. --ghdl-source is used instead.
+;c
+;vhdl Separate
+;-c Analyze for --anaelab
+
+;v
+;vhdl
+;Verbose
+
+-warn-
+vhdl Joined
+--warn- Warn about
+
+-ghdl
+vhdl Joined
+--ghdl-
");
+ Put_Line ("");
+
+ -- TODO: list of design units.
+
+ Put_Line ("
list of files referenced but not available:");
+ Put_Line ("
");
+ for I in No_Source_File_Entry + 1 .. Filexref_Info'Last loop
+ if Filexref_Info (I).Output = null
+ and then Filexref_Info (I).Referenced
+ then
+ Put ("
");
+ New_Line;
+ end if;
+ end loop;
+ 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
new file mode 100644
index 000000000..82c3e6072
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlprint.ads
@@ -0,0 +1,20 @@
+-- GHDL driver - print commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ghdlprint is
+ procedure Register_Commands;
+end Ghdlprint;
diff --git a/src/translate/ghdldrv/ghdlrun.adb b/src/translate/ghdldrv/ghdlrun.adb
new file mode 100644
index 000000000..f6237214e
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlrun.adb
@@ -0,0 +1,661 @@
+-- GHDL driver - JIT commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with Interfaces.C;
+
+with Ghdlmain; use Ghdlmain;
+with Ghdllocal; use Ghdllocal;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with Ada.Unchecked_Conversion;
+with Ada.Command_Line;
+with Ada.Text_IO;
+
+with Ortho_Jit;
+with Ortho_Nodes; use Ortho_Nodes;
+with Interfaces;
+with System; use System;
+with Trans_Decls;
+with Iirs; use Iirs;
+with Flags;
+with Errorout; use Errorout;
+with Libraries;
+with Canon;
+with Trans_Be;
+with Translation;
+with Ieee.Std_Logic_1164;
+
+with Lists;
+with Str_Table;
+with Nodes;
+with Files_Map;
+with Name_Table;
+
+with Grt.Main;
+with Grt.Modules;
+with Grt.Lib;
+with Grt.Processes;
+with Grt.Rtis;
+with Grt.Files;
+with Grt.Signals;
+with Grt.Options;
+with Grt.Types;
+with Grt.Images;
+with Grt.Values;
+with Grt.Names;
+with Grt.Std_Logic_1164;
+
+with Ghdlcomp;
+with Foreigns;
+with Grtlink;
+
+package body Ghdlrun is
+ procedure Foreign_Hook (Decl : Iir;
+ Info : Translation.Foreign_Info_Type;
+ Ortho : O_Dnode);
+
+ procedure Compile_Init (Analyze_Only : Boolean) is
+ begin
+ if Analyze_Only then
+ return;
+ end if;
+
+ Translation.Foreign_Hook := Foreign_Hook'Access;
+
+ -- FIXME: add a flag to force unnesting.
+ -- Translation.Flag_Unnest_Subprograms := True;
+
+ -- The design is always analyzed in whole.
+ Flags.Flag_Whole_Analyze := True;
+
+ Setup_Libraries (False);
+ Libraries.Load_Std_Library;
+
+ Ortho_Jit.Init;
+
+ Translation.Initialize;
+ Canon.Canon_Flag_Add_Labels := True;
+ end Compile_Init;
+
+ procedure Compile_Elab
+ (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural)
+ is
+ begin
+ Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg);
+ if Sec_Name = null then
+ Sec_Name := new String'("");
+ end if;
+
+ Flags.Flag_Elaborate := True;
+ Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True);
+
+ if Errorout.Nbr_Errors > 0 then
+ -- This may happen (bad entity for example).
+ raise Compilation_Error;
+ end if;
+ end Compile_Elab;
+
+ -- Set options.
+ -- This is a little bit over-kill: from C to Ada and then again to C...
+ procedure Set_Run_Options (Args : Argument_List)
+ is
+ use Interfaces.C;
+ use Grt.Options;
+ use Grt.Types;
+
+ function Malloc (Size : size_t) return Argv_Type;
+ pragma Import (C, Malloc);
+
+ function Strdup (Str : String) return Ghdl_C_String;
+ pragma Import (C, Strdup);
+-- is
+-- T : Grt.Types.String_Access;
+-- begin
+-- T := new String'(Str & Ghdllocal.Nul);
+-- return To_Ghdl_C_String (T.all'Address);
+-- end Strdup;
+ begin
+ Argc := 1 + Args'Length;
+ Argv := Malloc
+ (size_t (Argc * (Ghdl_C_String'Size / System.Storage_Unit)));
+ Argv (0) := Strdup (Ada.Command_Line.Command_Name & Ghdllocal.Nul);
+ Progname := Argv (0);
+ for I in Args'Range loop
+ Argv (1 + I - Args'First) := Strdup (Args (I).all & Ghdllocal.Nul);
+ end loop;
+ end Set_Run_Options;
+
+ procedure Ghdl_Elaborate;
+ pragma Export (C, Ghdl_Elaborate, "__ghdl_ELABORATE");
+
+ type Elaborate_Acc is access procedure;
+ pragma Convention (C, Elaborate_Acc);
+ Elaborate_Proc : Elaborate_Acc := null;
+
+ procedure Ghdl_Elaborate is
+ begin
+ --Ada.Text_IO.Put_Line (Standard_Error, "ghdl_elaborate");
+ Elaborate_Proc.all;
+ end Ghdl_Elaborate;
+
+ procedure Def (Decl : O_Dnode; Addr : Address)
+ renames Ortho_Jit.Set_Address;
+
+ procedure Foreign_Hook (Decl : Iir;
+ Info : Translation.Foreign_Info_Type;
+ Ortho : O_Dnode)
+ is
+ use Translation;
+ Res : Address;
+ begin
+ case Info.Kind is
+ when Foreign_Vhpidirect =>
+ declare
+ Name : constant String :=
+ Name_Table.Name_Buffer (Info.Subprg_First
+ .. Info.Subprg_Last);
+ begin
+ Res := Foreigns.Find_Foreign (Name);
+ if Res /= Null_Address then
+ Def (Ortho, Res);
+ else
+ Error_Msg_Sem ("unknown foreign VHPIDIRECT '" & Name & "'",
+ Decl);
+ end if;
+ end;
+ when Foreign_Intrinsic =>
+ Name_Table.Image (Get_Identifier (Decl));
+ declare
+ Name : constant String :=
+ Name_Table.Name_Buffer (1 .. Name_Table.Name_Length);
+ begin
+ if Name = "untruncated_text_read" then
+ Def (Ortho, Grt.Files.Ghdl_Untruncated_Text_Read'Address);
+ elsif Name = "control_simulation" then
+ Def (Ortho, Grt.Lib.Ghdl_Control_Simulation'Address);
+ elsif Name = "get_resolution_limit" then
+ Def (Ortho, Grt.Lib.Ghdl_Get_Resolution_Limit'Address);
+ else
+ Error_Msg_Sem ("unknown foreign intrinsic '" & Name & "'",
+ Decl);
+ end if;
+ end;
+ when Foreign_Unknown =>
+ null;
+ end case;
+ end Foreign_Hook;
+
+ procedure Run
+ is
+ use Interfaces;
+ --use Ortho_Code.Binary;
+
+ function Conv is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Elaborate_Acc);
+ Err : Boolean;
+ Decl : O_Dnode;
+ begin
+ if Flag_Verbose then
+ Ada.Text_IO.Put_Line ("Linking in memory");
+ end if;
+
+ Def (Trans_Decls.Ghdl_Memcpy,
+ Grt.Lib.Ghdl_Memcpy'Address);
+ Def (Trans_Decls.Ghdl_Bound_Check_Failed_L1,
+ Grt.Lib.Ghdl_Bound_Check_Failed_L1'Address);
+ Def (Trans_Decls.Ghdl_Malloc0,
+ Grt.Lib.Ghdl_Malloc0'Address);
+ Def (Trans_Decls.Ghdl_Std_Ulogic_To_Boolean_Array,
+ Grt.Lib.Ghdl_Std_Ulogic_To_Boolean_Array'Address);
+
+ Def (Trans_Decls.Ghdl_Report,
+ Grt.Lib.Ghdl_Report'Address);
+ Def (Trans_Decls.Ghdl_Assert_Failed,
+ Grt.Lib.Ghdl_Assert_Failed'Address);
+ Def (Trans_Decls.Ghdl_Ieee_Assert_Failed,
+ Grt.Lib.Ghdl_Ieee_Assert_Failed'Address);
+ Def (Trans_Decls.Ghdl_Psl_Assert_Failed,
+ Grt.Lib.Ghdl_Psl_Assert_Failed'Address);
+ Def (Trans_Decls.Ghdl_Psl_Cover,
+ Grt.Lib.Ghdl_Psl_Cover'Address);
+ Def (Trans_Decls.Ghdl_Psl_Cover_Failed,
+ Grt.Lib.Ghdl_Psl_Cover_Failed'Address);
+ Def (Trans_Decls.Ghdl_Program_Error,
+ Grt.Lib.Ghdl_Program_Error'Address);
+ Def (Trans_Decls.Ghdl_Malloc,
+ Grt.Lib.Ghdl_Malloc'Address);
+ Def (Trans_Decls.Ghdl_Deallocate,
+ Grt.Lib.Ghdl_Deallocate'Address);
+ Def (Trans_Decls.Ghdl_Real_Exp,
+ Grt.Lib.Ghdl_Real_Exp'Address);
+ Def (Trans_Decls.Ghdl_Integer_Exp,
+ Grt.Lib.Ghdl_Integer_Exp'Address);
+
+ Def (Trans_Decls.Ghdl_Sensitized_Process_Register,
+ Grt.Processes.Ghdl_Sensitized_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Process_Register,
+ Grt.Processes.Ghdl_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Postponed_Sensitized_Process_Register,
+ Grt.Processes.Ghdl_Postponed_Sensitized_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Postponed_Process_Register,
+ Grt.Processes.Ghdl_Postponed_Process_Register'Address);
+ Def (Trans_Decls.Ghdl_Finalize_Register,
+ Grt.Processes.Ghdl_Finalize_Register'Address);
+
+ Def (Trans_Decls.Ghdl_Stack2_Allocate,
+ Grt.Processes.Ghdl_Stack2_Allocate'Address);
+ Def (Trans_Decls.Ghdl_Stack2_Mark,
+ Grt.Processes.Ghdl_Stack2_Mark'Address);
+ Def (Trans_Decls.Ghdl_Stack2_Release,
+ Grt.Processes.Ghdl_Stack2_Release'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Exit,
+ Grt.Processes.Ghdl_Process_Wait_Exit'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Suspend,
+ Grt.Processes.Ghdl_Process_Wait_Suspend'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Timeout,
+ Grt.Processes.Ghdl_Process_Wait_Timeout'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Set_Timeout,
+ Grt.Processes.Ghdl_Process_Wait_Set_Timeout'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Add_Sensitivity,
+ Grt.Processes.Ghdl_Process_Wait_Add_Sensitivity'Address);
+ Def (Trans_Decls.Ghdl_Process_Wait_Close,
+ Grt.Processes.Ghdl_Process_Wait_Close'Address);
+
+ Def (Trans_Decls.Ghdl_Process_Add_Sensitivity,
+ Grt.Processes.Ghdl_Process_Add_Sensitivity'Address);
+
+ Def (Trans_Decls.Ghdl_Now,
+ Grt.Types.Current_Time'Address);
+
+ Def (Trans_Decls.Ghdl_Process_Add_Driver,
+ Grt.Signals.Ghdl_Process_Add_Driver'Address);
+ Def (Trans_Decls.Ghdl_Signal_Add_Direct_Driver,
+ Grt.Signals.Ghdl_Signal_Add_Direct_Driver'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Add_Source,
+ Grt.Signals.Ghdl_Signal_Add_Source'Address);
+ Def (Trans_Decls.Ghdl_Signal_In_Conversion,
+ Grt.Signals.Ghdl_Signal_In_Conversion'Address);
+ Def (Trans_Decls.Ghdl_Signal_Out_Conversion,
+ Grt.Signals.Ghdl_Signal_Out_Conversion'Address);
+ Def (Trans_Decls.Ghdl_Signal_Effective_Value,
+ Grt.Signals.Ghdl_Signal_Effective_Value'Address);
+ Def (Trans_Decls.Ghdl_Signal_Create_Resolution,
+ Grt.Signals.Ghdl_Signal_Create_Resolution'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Disconnect,
+ Grt.Signals.Ghdl_Signal_Disconnect'Address);
+ Def (Trans_Decls.Ghdl_Signal_Set_Disconnect,
+ Grt.Signals.Ghdl_Signal_Set_Disconnect'Address);
+ Def (Trans_Decls.Ghdl_Signal_Merge_Rti,
+ Grt.Signals.Ghdl_Signal_Merge_Rti'Address);
+ Def (Trans_Decls.Ghdl_Signal_Name_Rti,
+ Grt.Signals.Ghdl_Signal_Name_Rti'Address);
+ Def (Trans_Decls.Ghdl_Signal_Read_Port,
+ Grt.Signals.Ghdl_Signal_Read_Port'Address);
+ Def (Trans_Decls.Ghdl_Signal_Read_Driver,
+ Grt.Signals.Ghdl_Signal_Read_Driver'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Driving,
+ Grt.Signals.Ghdl_Signal_Driving'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_B1,
+ Grt.Signals.Ghdl_Signal_Driving_Value_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_E8,
+ Grt.Signals.Ghdl_Signal_Driving_Value_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_E32,
+ Grt.Signals.Ghdl_Signal_Driving_Value_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_I32,
+ Grt.Signals.Ghdl_Signal_Driving_Value_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_I64,
+ Grt.Signals.Ghdl_Signal_Driving_Value_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Driving_Value_F64,
+ Grt.Signals.Ghdl_Signal_Driving_Value_F64'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Create_Guard,
+ Grt.Signals.Ghdl_Signal_Create_Guard'Address);
+ Def (Trans_Decls.Ghdl_Signal_Guard_Dependence,
+ Grt.Signals.Ghdl_Signal_Guard_Dependence'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_Error,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_Error'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_Error,
+ Grt.Signals.Ghdl_Signal_Start_Assign_Error'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_Error,
+ Grt.Signals.Ghdl_Signal_Next_Assign_Error'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_Null,
+ Grt.Signals.Ghdl_Signal_Start_Assign_Null'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Direct_Assign,
+ Grt.Signals.Ghdl_Signal_Direct_Assign'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_B1,
+ Grt.Signals.Ghdl_Create_Signal_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_B1,
+ Grt.Signals.Ghdl_Signal_Init_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_B1,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_B1,
+ Grt.Signals.Ghdl_Signal_Start_Assign_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_B1,
+ Grt.Signals.Ghdl_Signal_Next_Assign_B1'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_B1,
+ Grt.Signals.Ghdl_Signal_Associate_B1'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_E8,
+ Grt.Signals.Ghdl_Create_Signal_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_E8,
+ Grt.Signals.Ghdl_Signal_Init_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E8,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_E8,
+ Grt.Signals.Ghdl_Signal_Start_Assign_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_E8,
+ Grt.Signals.Ghdl_Signal_Next_Assign_E8'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_E8,
+ Grt.Signals.Ghdl_Signal_Associate_E8'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_E32,
+ Grt.Signals.Ghdl_Create_Signal_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_E32,
+ Grt.Signals.Ghdl_Signal_Init_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_E32,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_E32,
+ Grt.Signals.Ghdl_Signal_Start_Assign_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_E32,
+ Grt.Signals.Ghdl_Signal_Next_Assign_E32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_E32,
+ Grt.Signals.Ghdl_Signal_Associate_E32'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_I32,
+ Grt.Signals.Ghdl_Create_Signal_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_I32,
+ Grt.Signals.Ghdl_Signal_Init_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I32,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_I32,
+ Grt.Signals.Ghdl_Signal_Start_Assign_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_I32,
+ Grt.Signals.Ghdl_Signal_Next_Assign_I32'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_I32,
+ Grt.Signals.Ghdl_Signal_Associate_I32'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_I64,
+ Grt.Signals.Ghdl_Create_Signal_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_I64,
+ Grt.Signals.Ghdl_Signal_Init_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_I64,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_I64,
+ Grt.Signals.Ghdl_Signal_Start_Assign_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_I64,
+ Grt.Signals.Ghdl_Signal_Next_Assign_I64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_I64,
+ Grt.Signals.Ghdl_Signal_Associate_I64'Address);
+
+ Def (Trans_Decls.Ghdl_Create_Signal_F64,
+ Grt.Signals.Ghdl_Create_Signal_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Init_F64,
+ Grt.Signals.Ghdl_Signal_Init_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Simple_Assign_F64,
+ Grt.Signals.Ghdl_Signal_Simple_Assign_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Start_Assign_F64,
+ Grt.Signals.Ghdl_Signal_Start_Assign_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Next_Assign_F64,
+ Grt.Signals.Ghdl_Signal_Next_Assign_F64'Address);
+ Def (Trans_Decls.Ghdl_Signal_Associate_F64,
+ Grt.Signals.Ghdl_Signal_Associate_F64'Address);
+
+ Def (Trans_Decls.Ghdl_Signal_Attribute_Register_Prefix,
+ Grt.Signals.Ghdl_Signal_Attribute_Register_Prefix'Address);
+ Def (Trans_Decls.Ghdl_Create_Stable_Signal,
+ Grt.Signals.Ghdl_Create_Stable_Signal'Address);
+ Def (Trans_Decls.Ghdl_Create_Quiet_Signal,
+ Grt.Signals.Ghdl_Create_Quiet_Signal'Address);
+ Def (Trans_Decls.Ghdl_Create_Transaction_Signal,
+ Grt.Signals.Ghdl_Create_Transaction_Signal'Address);
+ Def (Trans_Decls.Ghdl_Create_Delayed_Signal,
+ Grt.Signals.Ghdl_Create_Delayed_Signal'Address);
+
+ Def (Trans_Decls.Ghdl_Rti_Add_Package,
+ Grt.Rtis.Ghdl_Rti_Add_Package'Address);
+ Def (Trans_Decls.Ghdl_Rti_Add_Top,
+ Grt.Rtis.Ghdl_Rti_Add_Top'Address);
+
+ Def (Trans_Decls.Ghdl_Protected_Enter,
+ Grt.Processes.Ghdl_Protected_Enter'Address);
+ Def (Trans_Decls.Ghdl_Protected_Leave,
+ Grt.Processes.Ghdl_Protected_Leave'Address);
+ Def (Trans_Decls.Ghdl_Protected_Init,
+ Grt.Processes.Ghdl_Protected_Init'Address);
+ Def (Trans_Decls.Ghdl_Protected_Fini,
+ Grt.Processes.Ghdl_Protected_Fini'Address);
+
+ Def (Trans_Decls.Ghdl_Text_File_Elaborate,
+ Grt.Files.Ghdl_Text_File_Elaborate'Address);
+ Def (Trans_Decls.Ghdl_Text_File_Finalize,
+ Grt.Files.Ghdl_Text_File_Finalize'Address);
+ Def (Trans_Decls.Ghdl_Text_File_Open,
+ Grt.Files.Ghdl_Text_File_Open'Address);
+ Def (Trans_Decls.Ghdl_Text_File_Open_Status,
+ Grt.Files.Ghdl_Text_File_Open_Status'Address);
+ Def (Trans_Decls.Ghdl_Text_Write,
+ Grt.Files.Ghdl_Text_Write'Address);
+ Def (Trans_Decls.Ghdl_Text_Read_Length,
+ Grt.Files.Ghdl_Text_Read_Length'Address);
+ Def (Trans_Decls.Ghdl_Text_File_Close,
+ Grt.Files.Ghdl_Text_File_Close'Address);
+
+ Def (Trans_Decls.Ghdl_File_Elaborate,
+ Grt.Files.Ghdl_File_Elaborate'Address);
+ Def (Trans_Decls.Ghdl_File_Finalize,
+ Grt.Files.Ghdl_File_Finalize'Address);
+ Def (Trans_Decls.Ghdl_File_Open,
+ Grt.Files.Ghdl_File_Open'Address);
+ Def (Trans_Decls.Ghdl_File_Open_Status,
+ Grt.Files.Ghdl_File_Open_Status'Address);
+ Def (Trans_Decls.Ghdl_File_Close,
+ Grt.Files.Ghdl_File_Close'Address);
+ Def (Trans_Decls.Ghdl_File_Flush,
+ Grt.Files.Ghdl_File_Flush'Address);
+ Def (Trans_Decls.Ghdl_Write_Scalar,
+ Grt.Files.Ghdl_Write_Scalar'Address);
+ Def (Trans_Decls.Ghdl_Read_Scalar,
+ Grt.Files.Ghdl_Read_Scalar'Address);
+
+ Def (Trans_Decls.Ghdl_File_Endfile,
+ Grt.Files.Ghdl_File_Endfile'Address);
+
+ Def (Trans_Decls.Ghdl_Image_B1,
+ Grt.Images.Ghdl_Image_B1'Address);
+ Def (Trans_Decls.Ghdl_Image_E8,
+ Grt.Images.Ghdl_Image_E8'Address);
+ Def (Trans_Decls.Ghdl_Image_E32,
+ Grt.Images.Ghdl_Image_E32'Address);
+ Def (Trans_Decls.Ghdl_Image_I32,
+ Grt.Images.Ghdl_Image_I32'Address);
+ Def (Trans_Decls.Ghdl_Image_F64,
+ Grt.Images.Ghdl_Image_F64'Address);
+ Def (Trans_Decls.Ghdl_Image_P64,
+ Grt.Images.Ghdl_Image_P64'Address);
+ Def (Trans_Decls.Ghdl_Image_P32,
+ Grt.Images.Ghdl_Image_P32'Address);
+
+ Def (Trans_Decls.Ghdl_Value_B1,
+ Grt.Values.Ghdl_Value_B1'Address);
+ Def (Trans_Decls.Ghdl_Value_E8,
+ Grt.Values.Ghdl_Value_E8'Address);
+ Def (Trans_Decls.Ghdl_Value_E32,
+ Grt.Values.Ghdl_Value_E32'Address);
+ Def (Trans_Decls.Ghdl_Value_I32,
+ Grt.Values.Ghdl_Value_I32'Address);
+ Def (Trans_Decls.Ghdl_Value_F64,
+ Grt.Values.Ghdl_Value_F64'Address);
+ Def (Trans_Decls.Ghdl_Value_P32,
+ Grt.Values.Ghdl_Value_P32'Address);
+ Def (Trans_Decls.Ghdl_Value_P64,
+ Grt.Values.Ghdl_Value_P64'Address);
+
+ Def (Trans_Decls.Ghdl_Get_Path_Name,
+ Grt.Names.Ghdl_Get_Path_Name'Address);
+ Def (Trans_Decls.Ghdl_Get_Instance_Name,
+ Grt.Names.Ghdl_Get_Instance_Name'Address);
+
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Eq,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Eq'Address);
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Ne,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Ne'Address);
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Lt,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Lt'Address);
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Le,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Le'Address);
+
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Eq,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Eq'Address);
+ Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Ne,
+ Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Ne'Address);
+
+ Def (Trans_Decls.Ghdl_To_String_I32,
+ Grt.Images.Ghdl_To_String_I32'Address);
+ Def (Trans_Decls.Ghdl_To_String_F64,
+ Grt.Images.Ghdl_To_String_F64'Address);
+ Def (Trans_Decls.Ghdl_To_String_F64_Digits,
+ Grt.Images.Ghdl_To_String_F64_Digits'Address);
+ Def (Trans_Decls.Ghdl_To_String_F64_Format,
+ Grt.Images.Ghdl_To_String_F64_Format'Address);
+ Def (Trans_Decls.Ghdl_To_String_B1,
+ Grt.Images.Ghdl_To_String_B1'Address);
+ Def (Trans_Decls.Ghdl_To_String_E8,
+ Grt.Images.Ghdl_To_String_E8'Address);
+ Def (Trans_Decls.Ghdl_To_String_E32,
+ Grt.Images.Ghdl_To_String_E32'Address);
+ Def (Trans_Decls.Ghdl_To_String_Char,
+ Grt.Images.Ghdl_To_String_Char'Address);
+ Def (Trans_Decls.Ghdl_To_String_P32,
+ Grt.Images.Ghdl_To_String_P32'Address);
+ Def (Trans_Decls.Ghdl_To_String_P64,
+ Grt.Images.Ghdl_To_String_P64'Address);
+ Def (Trans_Decls.Ghdl_Time_To_String_Unit,
+ Grt.Images.Ghdl_Time_To_String_Unit'Address);
+ Def (Trans_Decls.Ghdl_BV_To_Ostring,
+ Grt.Images.Ghdl_BV_To_Ostring'Address);
+ Def (Trans_Decls.Ghdl_BV_To_Hstring,
+ Grt.Images.Ghdl_BV_To_Hstring'Address);
+ Def (Trans_Decls.Ghdl_Array_Char_To_String_B1,
+ Grt.Images.Ghdl_Array_Char_To_String_B1'Address);
+ Def (Trans_Decls.Ghdl_Array_Char_To_String_E8,
+ Grt.Images.Ghdl_Array_Char_To_String_E8'Address);
+ Def (Trans_Decls.Ghdl_Array_Char_To_String_E32,
+ Grt.Images.Ghdl_Array_Char_To_String_E32'Address);
+
+ Ortho_Jit.Link (Err);
+ if Err then
+ raise Compile_Error;
+ end if;
+
+ Grtlink.Std_Standard_Boolean_RTI_Ptr :=
+ Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Boolean_Rti);
+ Grtlink.Std_Standard_Bit_RTI_Ptr :=
+ Ortho_Jit.Get_Address (Trans_Decls.Std_Standard_Bit_Rti);
+ if Ieee.Std_Logic_1164.Resolved /= Null_Iir then
+ Decl := Translation.Get_Resolv_Ortho_Decl
+ (Ieee.Std_Logic_1164.Resolved);
+ if Decl /= O_Dnode_Null then
+ Grtlink.Ieee_Std_Logic_1164_Resolved_Resolv_Ptr :=
+ Ortho_Jit.Get_Address (Decl);
+ end if;
+ end if;
+
+ Grtlink.Flag_String := Flags.Flag_String;
+
+ Elaborate_Proc :=
+ Conv (Ortho_Jit.Get_Address (Trans_Decls.Ghdl_Elaborate));
+
+ Ortho_Jit.Finish;
+
+ Translation.Finalize;
+ Lists.Initialize;
+ Str_Table.Initialize;
+ Nodes.Initialize;
+ Files_Map.Initialize;
+ Name_Table.Initialize;
+
+ if Flag_Verbose then
+ Ada.Text_IO.Put_Line ("Starting simulation");
+ end if;
+
+ Grt.Main.Run;
+ --V := Ghdl_Main (1, Gnat_Argv);
+ end Run;
+
+
+ -- Command run help.
+ type Command_Run_Help is new Command_Type with null record;
+ function Decode_Command (Cmd : Command_Run_Help; Name : String)
+ return Boolean;
+ function Get_Short_Help (Cmd : Command_Run_Help) return String;
+ procedure Perform_Action (Cmd : in out Command_Run_Help;
+ Args : Argument_List);
+
+ function Decode_Command (Cmd : Command_Run_Help; Name : String)
+ return Boolean
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return Name = "--run-help";
+ end Decode_Command;
+
+ function Get_Short_Help (Cmd : Command_Run_Help) return String
+ is
+ pragma Unreferenced (Cmd);
+ begin
+ return "--run-help Disp help for RUNOPTS options";
+ end Get_Short_Help;
+
+ procedure Perform_Action (Cmd : in out Command_Run_Help;
+ Args : Argument_List)
+ is
+ pragma Unreferenced (Cmd);
+ use Ada.Text_IO;
+ begin
+ if Args'Length /= 0 then
+ Error
+ ("warning: command '--run-help' does not accept any argument");
+ end if;
+ Put_Line ("These options can only be placed at [RUNOPTS]");
+ -- Register modules, since they add commands.
+ Grt.Modules.Register_Modules;
+ -- Bypass usual help header.
+ Grt.Options.Argc := 0;
+ Grt.Options.Help;
+ end Perform_Action;
+
+ procedure Register_Commands
+ is
+ begin
+ Ghdlcomp.Hooks := (Compile_Init'Access,
+ Compile_Elab'Access,
+ Set_Run_Options'Access,
+ Run'Access,
+ Ortho_Jit.Decode_Option'Access,
+ Ortho_Jit.Disp_Help'Access);
+ Ghdlcomp.Register_Commands;
+ Register_Command (new Command_Run_Help);
+ Trans_Be.Register_Translation_Back_End;
+ end Register_Commands;
+end Ghdlrun;
diff --git a/src/translate/ghdldrv/ghdlrun.ads b/src/translate/ghdldrv/ghdlrun.ads
new file mode 100644
index 000000000..07095bd5d
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlrun.ads
@@ -0,0 +1,20 @@
+-- GHDL driver - JIT commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ghdlrun is
+ procedure Register_Commands;
+end Ghdlrun;
diff --git a/src/translate/ghdldrv/ghdlsimul.adb b/src/translate/ghdldrv/ghdlsimul.adb
new file mode 100644
index 000000000..17cece726
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlsimul.adb
@@ -0,0 +1,209 @@
+-- GHDL driver - simulator commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Ada.Text_IO;
+with Ada.Command_Line;
+
+with Ghdllocal; use Ghdllocal;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with Types;
+with Iirs; use Iirs;
+with Flags;
+with Back_End;
+with Name_Table;
+with Errorout; use Errorout;
+with Std_Package;
+with Libraries;
+with Canon;
+with Configuration;
+with Iirs_Utils;
+with Annotations;
+with Elaboration;
+with Sim_Be;
+with Simulation;
+with Execution;
+
+with Ghdlcomp;
+
+with Grt.Vpi;
+pragma Unreferenced (Grt.Vpi);
+with Grt.Types;
+with Grt.Options;
+with Grtlink;
+
+package body Ghdlsimul is
+
+ -- FIXME: reuse simulation.top_config
+ Top_Conf : Iir;
+
+ procedure Compile_Init (Analyze_Only : Boolean) is
+ begin
+ if Analyze_Only then
+ return;
+ end if;
+
+ -- Initialize.
+ Back_End.Finish_Compilation := Sim_Be.Finish_Compilation'Access;
+ Back_End.Sem_Foreign := null;
+
+ Setup_Libraries (False);
+ Libraries.Load_Std_Library;
+
+ -- Here, time_base can be set.
+ Annotations.Annotate (Std_Package.Std_Standard_Unit);
+
+ Canon.Canon_Flag_Add_Labels := True;
+ Canon.Canon_Flag_Sequentials_Stmts := True;
+ Canon.Canon_Flag_Expressions := True;
+ Canon.Canon_Flag_All_Sensitivity := True;
+ end Compile_Init;
+
+ procedure Compile_Elab
+ (Cmd_Name : String; Args : Argument_List; Opt_Arg : out Natural)
+ is
+ use Name_Table;
+ use Types;
+
+ First_Id : Name_Id;
+ Sec_Id : Name_Id;
+ begin
+ Extract_Elab_Unit (Cmd_Name, Args, Opt_Arg);
+
+ Flags.Flag_Elaborate := True;
+ -- Translation.Chap12.Elaborate (Prim_Name.all, Sec_Name.all, "", True);
+
+ if Errorout.Nbr_Errors > 0 then
+ -- This may happen (bad entity for example).
+ raise Compilation_Error;
+ end if;
+
+ First_Id := Get_Identifier (Prim_Name.all);
+ if Sec_Name = null then
+ Sec_Id := Null_Identifier;
+ else
+ Sec_Id := Get_Identifier (Sec_Name.all);
+ end if;
+ Top_Conf := Configuration.Configure (First_Id, Sec_Id);
+ if Top_Conf = Null_Iir then
+ raise Compilation_Error;
+ end if;
+
+ -- Check (and possibly abandon) if entity can be at the top of the
+ -- hierarchy.
+ declare
+ Conf_Unit : constant Iir := Get_Library_Unit (Top_Conf);
+ Arch : constant Iir :=
+ Get_Block_Specification (Get_Block_Configuration (Conf_Unit));
+ Entity : constant Iir := Iirs_Utils.Get_Entity (Arch);
+ begin
+ Configuration.Check_Entity_Declaration_Top (Entity);
+ if Nbr_Errors > 0 then
+ raise Compilation_Error;
+ end if;
+ end;
+ end Compile_Elab;
+
+ -- Set options.
+ procedure Set_Run_Options (Args : Argument_List)
+ is
+ use Grt.Options;
+ use Types;
+ Arg : String_Access;
+ Status : Decode_Option_Status;
+ Argv0 : String_Acc;
+ begin
+ -- Set progname (used for grt error messages)
+ Argv0 := new String'(Ada.Command_Line.Command_Name & ASCII.Nul);
+ Grt.Options.Progname := Grt.Types.To_Ghdl_C_String (Argv0.all'Address);
+
+ for I in Args'Range loop
+ Arg := Args (I);
+ if Arg.all = "--disp-tree" then
+ Simulation.Disp_Tree := True;
+ elsif Arg.all = "--expect-failure" then
+ Decode_Option (Arg.all, Status);
+ pragma Assert (Status = Decode_Option_Ok);
+ elsif Arg.all = "--trace-elab" then
+ Elaboration.Trace_Elaboration := True;
+ elsif Arg.all = "--trace-drivers" then
+ Elaboration.Trace_Drivers := True;
+ elsif Arg.all = "--trace-annotation" then
+ Annotations.Trace_Annotation := True;
+ elsif Arg.all = "--trace-simu" then
+ Simulation.Trace_Simulation := True;
+ elsif Arg.all = "--trace-stmt" then
+ Execution.Trace_Statements := True;
+ elsif Arg.all = "--stats" then
+ Simulation.Disp_Stats := True;
+ elsif Arg.all = "-i" then
+ Simulation.Flag_Interractive := True;
+ else
+ Decode_Option (Arg.all, Status);
+ case Status is
+ when Decode_Option_Last =>
+ exit;
+ when Decode_Option_Help =>
+ -- FIXME: is that correct ?
+ exit;
+ when Decode_Option_Ok =>
+ null;
+ end case;
+ -- Ghdlmain.Error ("unknown run options '" & Arg.all & "'");
+ -- raise Option_Error;
+ end if;
+ end loop;
+ end Set_Run_Options;
+
+ procedure Run is
+ begin
+ Grtlink.Flag_String := Flags.Flag_String;
+
+ Simulation.Simulation_Entity (Top_Conf);
+ end Run;
+
+ function Decode_Option (Option : String) return Boolean
+ is
+ begin
+ if Option = "--debug" then
+ Simulation.Flag_Debugger := True;
+ else
+ return False;
+ end if;
+ return True;
+ end Decode_Option;
+
+ procedure Disp_Long_Help
+ is
+ use Ada.Text_IO;
+ begin
+ Put_Line (" --debug Run with debugger");
+ end Disp_Long_Help;
+
+ procedure Register_Commands
+ is
+ begin
+ Ghdlcomp.Hooks := (Compile_Init'Access,
+ Compile_Elab'Access,
+ Set_Run_Options'Access,
+ Run'Access,
+ Decode_Option'Access,
+ Disp_Long_Help'Access);
+ Ghdlcomp.Register_Commands;
+ end Register_Commands;
+end Ghdlsimul;
diff --git a/src/translate/ghdldrv/ghdlsimul.ads b/src/translate/ghdldrv/ghdlsimul.ads
new file mode 100644
index 000000000..264cbf8c6
--- /dev/null
+++ b/src/translate/ghdldrv/ghdlsimul.ads
@@ -0,0 +1,20 @@
+-- GHDL driver - simulator commands.
+-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+package Ghdlsimul is
+ procedure Register_Commands;
+end Ghdlsimul;
diff --git a/src/translate/ghdldrv/grtlink.ads b/src/translate/ghdldrv/grtlink.ads
new file mode 100644
index 000000000..4b3951e78
--- /dev/null
+++ b/src/translate/ghdldrv/grtlink.ads
@@ -0,0 +1,39 @@
+-- GHDL driver - shared variables with grt.
+-- Copyright (C) 2011 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+with System; use System;
+
+package Grtlink is
+
+ Flag_String : String (1 .. 5);
+ pragma Export (C, Flag_String, "__ghdl_flag_string");
+
+ Std_Standard_Bit_RTI_Ptr : Address := Null_Address;
+
+ Std_Standard_Boolean_RTI_Ptr : Address := Null_Address;
+
+ pragma Export (C, Std_Standard_Bit_RTI_Ptr,
+ "std__standard__bit__RTI_ptr");
+
+ pragma Export (C, Std_Standard_Boolean_RTI_Ptr,
+ "std__standard__boolean__RTI_ptr");
+
+ Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address := Null_Address;
+ pragma Export (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr,
+ "ieee__std_logic_1164__resolved_RESOLV_ptr");
+
+end Grtlink;
diff --git a/src/translate/grt/Makefile b/src/translate/grt/Makefile
new file mode 100644
index 000000000..107aef7bf
--- /dev/null
+++ b/src/translate/grt/Makefile
@@ -0,0 +1,56 @@
+# -*- Makefile -*- for the GHDL Run Time library.
+# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+#
+# GHDL is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any later
+# version.
+#
+# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING. If not, write to the Free
+# Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+GRT_FLAGS=-g -O
+GRT_ADAFLAGS=-gnatn
+
+ADAC=gcc
+CC=gcc
+GNATFLAGS=$(CFLAGS) -gnatf -gnaty3befhkmr -gnatwlu
+GHDL1=../ghdl1-gcc
+GRTSRCDIR=.
+GRT_RANLIB=ranlib
+
+INSTALL=install
+INSTALL_DATA=$(INSTALL) -m 644
+
+prefix=/usr/local
+exec_prefix=$(prefix)
+libdir=$(exec_prefix)/lib
+grt_libdir=$(libdir)
+
+target:=$(shell $(CC) -dumpmachine)
+
+all: grt-all
+install: grt-install
+clean: grt-clean
+ $(RM) *~
+
+show_target:
+ echo "Target is $(target)"
+
+include Makefile.inc
+
+
+GRT_CFLAGS=$(GRT_FLAGS) -Wall
+ghwdump: ghwdump.o ghwlib.o
+ $(CC) $(GRT_CFLAGS) -o $@ ghwdump.o ghwlib.o
+
+ghwlib.o: ghwlib.c ghwlib.h
+ $(CC) -c $(GRT_CFLAGS) -o $@ $<
+ghwdump.o: ghwdump.c ghwlib.h
+ $(CC) -c $(GRT_CFLAGS) -o $@ $<
diff --git a/src/translate/grt/Makefile.inc b/src/translate/grt/Makefile.inc
new file mode 100644
index 000000000..ec1b0df09
--- /dev/null
+++ b/src/translate/grt/Makefile.inc
@@ -0,0 +1,226 @@
+# -*- Makefile -*- for the GHDL Run Time library.
+# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+#
+# GHDL is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any later
+# version.
+#
+# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING. If not, write to the Free
+# Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+
+# Variables used:
+# AR: ar command
+# RM
+# CC
+# ADAC: the GNAT compiler
+# GHDL1: the ghdl compiler
+# GRT_RANLIB: the ranlib tool for the grt library.
+# grt_libdir: the place to put grt.
+# GRTSRCDIR: the source directory of grt.
+# target: GCC target
+# GRT_FLAGS: common (Ada + C + asm) compilation flags.
+# GRT_ADAFLAGS: compilation flags for Ada
+
+# Convert the target variable into a space separated list of architecture,
+# manufacturer, and operating system and assign each of those to its own
+# variable.
+
+target1:=$(subst -gnu,,$(target))
+targ:=$(subst -, ,$(target1))
+arch:=$(word 1,$(targ))
+ifeq ($(words $(targ)),2)
+ osys:=$(word 2,$(targ))
+else
+ osys:=$(word 3,$(targ))
+endif
+
+GRT_ELF_OPTS:=-Wl,--version-script=@/grt.ver -Wl,--export-dynamic
+
+# Set target files.
+ifeq ($(filter-out i%86 linux,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=i386.o linux.o times.o
+ GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS)
+endif
+ifeq ($(filter-out x86_64 linux,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=amd64.o linux.o times.o
+ GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS)
+endif
+ifeq ($(filter-out i%86 freebsd%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=i386.o linux.o times.o
+ GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS)
+ ADAC=ada
+endif
+ifeq ($(filter-out x86_64 freebsd%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=amd64.o linux.o times.o
+ GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS)
+ ADAC=ada
+endif
+ifeq ($(filter-out i%86 darwin%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=i386.o linux.o times.o
+ GRT_EXTRA_LIB=
+endif
+ifeq ($(filter-out x86_64 darwin%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=amd64.o linux.o times.o
+ GRT_EXTRA_LIB=
+endif
+ifeq ($(filter-out sparc solaris%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=sparc.o linux.o times.o
+ GRT_EXTRA_LIB=-ldl -lm
+endif
+ifeq ($(filter-out powerpc linux%,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=ppc.o linux.o times.o
+ GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS)
+endif
+ifeq ($(filter-out ia64 linux,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=ia64.o linux.o times.o
+ GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS)
+endif
+ifeq ($(filter-out i%86 mingw32,$(arch) $(osys)),)
+ GRT_TARGET_OBJS=win32.o clock.o
+endif
+# Doesn't work for unknown reasons.
+#ifeq ($(filter-out i%86 cygwin,$(arch) $(osys)),)
+# GRT_TARGET_OBJS=win32.o clock.o
+#endif
+# Fall-back: use a generic implementation based on pthreads.
+ifndef GRT_TARGET_OBJS
+ GRT_TARGET_OBJS=pthread.o times.o
+ GRT_EXTRA_LIB=-lpthread -ldl -lm
+endif
+
+# Additionnal object files (C or asm files).
+GRT_ADD_OBJS:=$(GRT_TARGET_OBJS) grt-cbinding.o grt-cvpi.o
+
+#GRT_USE_PTHREADS=y
+ifeq ($(GRT_USE_PTHREADS),y)
+ GRT_CFLAGS+=-DUSE_THREADS
+ GRT_ADD_OBJS+=grt-cthreads.o
+ GRT_EXTRA_LIB+=-lpthread
+endif
+
+GRT_ARCH?=None
+
+# Configuration pragmas.
+GRT_PRAGMA_FLAG=-gnatec$(GRTSRCDIR)/grt.adc -gnat05
+
+# Rule to compile an Ada file.
+GRT_ADACOMPILE=$(ADAC) -c $(GRT_FLAGS) $(GRT_PRAGMA_FLAG) -o $@ $<
+
+grt-all: libgrt.a grt.lst
+
+libgrt.a: $(GRT_ADD_OBJS) run-bind.o main.o grt-files # grt-arch.ads
+ $(RM) -f $@
+ $(AR) rcv $@ `sed -e "/^-/d" < grt-files` $(GRT_ADD_OBJS) \
+ run-bind.o main.o
+ $(GRT_RANLIB) $@
+
+run-bind.adb: grt-force
+ gnatmake -c $(GNATFLAGS) -aI$(GRTSRCDIR) $(GRT_PRAGMA_FLAG) \
+ ghdl_main $(GRT_ADAFLAGS) -cargs $(GRT_FLAGS)
+ gnatbind -Lgrt_ -o run-bind.adb -n ghdl_main.ali
+
+#system.ads:
+# sed -e "/Configurable_Run_Time/s/False/True/" \
+# -e "/Suppress_Standard_Library/s/False/True/" \
+# < `$(ADAC) -print-file-name=adainclude/system.ads` > $@
+
+run-bind.o: run-bind.adb
+ $(GRT_ADACOMPILE)
+
+main.o: $(GRTSRCDIR)/main.adb
+ $(GRT_ADACOMPILE)
+
+i386.o: $(GRTSRCDIR)/config/i386.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+chkstk.o: $(GRTSRCDIR)/config/chkstk.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+sparc.o: $(GRTSRCDIR)/config/sparc.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+ppc.o: $(GRTSRCDIR)/config/ppc.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+ia64.o: $(GRTSRCDIR)/config/ia64.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+amd64.o: $(GRTSRCDIR)/config/amd64.S
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+linux.o: $(GRTSRCDIR)/config/linux.c
+ $(CC) -c $(GRT_FLAGS) $(GRT_CFLAGS) -o $@ $<
+
+win32.o: $(GRTSRCDIR)/config/win32.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+win32thr.o: $(GRTSRCDIR)/config/win32thr.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+pthread.o: $(GRTSRCDIR)/config/pthread.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+times.o : $(GRTSRCDIR)/config/times.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+clock.o : $(GRTSRCDIR)/config/clock.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+grt-cbinding.o: $(GRTSRCDIR)/grt-cbinding.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+grt-cvpi.o: $(GRTSRCDIR)/grt-cvpi.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+grt-cthreads.o: $(GRTSRCDIR)/grt-cthreads.c
+ $(CC) -c $(GRT_FLAGS) -o $@ $<
+
+grt-disp-config:
+ @echo "target: $(target)"
+ @echo "targ: $(targ)"
+ @echo "arch: $(arch)"
+ @echo "osys: $(osys)"
+
+grt-files: run-bind.adb
+ sed -e "1,/-- *BEGIN/d" -e "/-- *END/,\$$d" \
+ -e "s/ -- //" < $< > $@
+
+grt-arch.ads:
+ echo "With Grt.Arch_$(GRT_ARCH);" > $@
+ echo "Package Grt.Arch renames Grt.Arch_$(GRT_ARCH);" >> $@
+
+# Remove local files (they are now in the libgrt library).
+# Also, remove the -shared option, in order not to build a shared library
+# instead of an executable.
+# Also remove -lgnat and its associated -L flags. This appears to be required
+# with GNAT GPL 2005.
+grt-files.in: grt-files
+ sed -e "\!^./!d" -e "/-shared/d" -e "/-static/d" -e "/-lgnat/d" \
+ -e "\X-L/Xd" < $< > $@
+
+grt.lst: grt-files.in
+ echo "@/libgrt.a" > $@
+ifdef GRT_EXTRA_LIB
+ for i in $(GRT_EXTRA_LIB); do echo $$i >> $@; done
+endif
+ cat $< >> $@
+
+grt-install: libgrt.a grt.lst
+ $(INSTALL_DATA) libgrt.a $(DESTDIR)$(grt_libdir)/libgrt.a
+ $(INSTALL_DATA) grt.lst $(DESTDIR)$(grt_libdir)/grt.lst
+
+grt-force:
+
+grt-clean: grt-force
+ $(RM) *.o *.ali run-bind.adb run-bind.ads *.a std_standard.s
+ $(RM) grt-files grt-files.in grt.lst
+
+.PHONY: grt-all grt-force grt-clean grt-install
diff --git a/src/translate/grt/config/Makefile b/src/translate/grt/config/Makefile
new file mode 100644
index 000000000..7d5f57def
--- /dev/null
+++ b/src/translate/grt/config/Makefile
@@ -0,0 +1,14 @@
+CFLAGS=-Wall -g
+
+#ARCH_OBJS=i386.o linux.o
+ARCH_OBJS=ppc.o linux.o
+
+teststack: teststack.o $(ARCH_OBJS)
+ $(CC) -o $@ $< $(ARCH_OBJS)
+
+ppc.o: ppc.S
+ $(CC) -c -o $@ -g $<
+
+clean:
+ $(RM) -f *.o *~ teststack
+
diff --git a/src/translate/grt/config/amd64.S b/src/translate/grt/config/amd64.S
new file mode 100644
index 000000000..0a7f0044b
--- /dev/null
+++ b/src/translate/grt/config/amd64.S
@@ -0,0 +1,131 @@
+/* GRT stack implementation for amd64 (x86_64)
+ Copyright (C) 2005 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "amd64.S"
+
+#ifdef __ELF__
+#define ENTRY(func) .align 4; .globl func; .type func,@function; func:
+#define END(func) .size func, . - func
+#define NAME(name) name
+#elif __APPLE__
+#define ENTRY(func) .align 4; .globl _##func; _##func:
+#define END(func)
+#define NAME(name) _##name
+#else
+#define ENTRY(func) .align 4; func:
+#define END(func)
+#define NAME(name) name
+#endif
+ .text
+
+ /* Function called to loop on the process. */
+ENTRY(grt_stack_loop)
+ mov 0(%rsp),%rdi
+ call *8(%rsp)
+ jmp NAME(grt_stack_loop)
+END(grt_stack_loop)
+
+ /* function Stack_Create (Func : Address; Arg : Address)
+ return Stack_Type;
+ Args: FUNC (RDI), ARG (RSI)
+ */
+ENTRY(grt_stack_create)
+ /* Standard prologue. */
+ pushq %rbp
+ movq %rsp,%rbp
+ /* Save args. */
+ sub $0x10,%rsp
+ mov %rdi,-8(%rbp)
+ mov %rsi,-16(%rbp)
+
+ /* Allocate the stack, and exit in case of failure */
+ callq NAME(grt_stack_allocate)
+ test %rax,%rax
+ je .Ldone
+
+ /* Note: %RAX contains the address of the stack_context. This is
+ also the top of the stack. */
+
+ /* Prepare stack. */
+ /* The function to be executed. */
+ mov -8(%rbp), %rdi
+ mov %rdi, -8(%rax)
+ /* The argument. */
+ mov -16(%rbp), %rsi
+ mov %rsi, -16(%rax)
+ /* The return function. Must be 8 mod 16. */
+#if __APPLE__
+ movq _grt_stack_loop@GOTPCREL(%rip), %rsi
+ movq %rsi, -24(%rax)
+#else
+ movq $grt_stack_loop, -24(%rax)
+#endif
+ /* The context. */
+ mov %rbp, -32(%rax)
+ mov %rbx, -40(%rax)
+ mov %r12, -48(%rax)
+ mov %r13, -56(%rax)
+ mov %r14, -64(%rax)
+ mov %r15, -72(%rax)
+
+ /* Save the new stack pointer to the stack context. */
+ lea -72(%rax), %rsi
+ mov %rsi, (%rax)
+
+.Ldone:
+ leave
+ ret
+END(grt_stack_create)
+
+
+
+ /* Arguments: TO (RDI), FROM (RSI) [VAL (RDX)]
+ Both are pointers to a stack_context. */
+ENTRY(grt_stack_switch)
+ /* Save call-used registers. */
+ pushq %rbp
+ pushq %rbx
+ pushq %r12
+ pushq %r13
+ pushq %r14
+ pushq %r15
+ /* Save the current stack. */
+ movq %rsp, (%rsi)
+ /* Stack switch. */
+ movq (%rdi), %rsp
+ /* Restore call-used registers. */
+ popq %r15
+ popq %r14
+ popq %r13
+ popq %r12
+ popq %rbx
+ popq %rbp
+ /* Return val. */
+ movq %rdx, %rax
+ /* Run. */
+ ret
+END(grt_stack_switch)
+
+ .ident "Written by T.Gingold"
diff --git a/src/translate/grt/config/chkstk.S b/src/translate/grt/config/chkstk.S
new file mode 100644
index 000000000..ab244d0cd
--- /dev/null
+++ b/src/translate/grt/config/chkstk.S
@@ -0,0 +1,53 @@
+/* GRT stack implementation for x86.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "chkstk.S"
+ .version "01.01"
+
+ .text
+
+#ifdef __APPLE__
+#define __chkstk ___chkstk
+#endif
+
+ /* Function called to loop on the process. */
+ .align 4
+#ifdef __ELF__
+ .type __chkstk,@function
+#endif
+ .globl __chkstk
+__chkstk:
+ testl %eax,%eax
+ je 0f
+ subl $4,%eax /* 4 bytes already used by call. */
+ subl %eax,%esp
+ jmp *(%esp,%eax)
+0:
+ ret
+#ifdef __ELF__
+ .size __chkstk, . - __chkstk
+#endif
+
+ .ident "Written by T.Gingold"
diff --git a/src/translate/grt/config/clock.c b/src/translate/grt/config/clock.c
new file mode 100644
index 000000000..242af604b
--- /dev/null
+++ b/src/translate/grt/config/clock.c
@@ -0,0 +1,43 @@
+/* GRT C bindings for time.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+#include
+
+int
+grt_get_clk_tck (void)
+{
+ return CLOCKS_PER_SEC;
+}
+
+void
+grt_get_times (int *wall, int *user, int *sys)
+{
+ clock_t res;
+
+ *wall = clock ();
+ *user = 0;
+ *sys = 0;
+}
+
diff --git a/src/translate/grt/config/i386.S b/src/translate/grt/config/i386.S
new file mode 100644
index 000000000..00d4719ac
--- /dev/null
+++ b/src/translate/grt/config/i386.S
@@ -0,0 +1,141 @@
+/* GRT stack implementation for x86.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "i386.S"
+ .version "01.01"
+
+ .text
+
+#ifdef __ELF__
+#define ENTRY(func) .align 4; .globl func; .type func,@function; func:
+#define END(func) .size func, . - func
+#define NAME(name) name
+#elif __APPLE__
+#define ENTRY(func) .align 4; .globl _##func; _##func:
+#define END(func)
+#define NAME(name) _##name
+#else
+#define ENTRY(func) .align 4; func:
+#define END(func)
+#define NAME(name) name
+#endif
+
+ /* Function called to loop on the process. */
+ENTRY(grt_stack_loop)
+ call *4(%esp)
+ jmp NAME(grt_stack_loop)
+END(grt_stack_loop)
+
+ /* function Stack_Create (Func : Address; Arg : Address)
+ return Stack_Type;
+ */
+ENTRY(grt_stack_create)
+ /* Standard prologue. */
+ pushl %ebp
+ movl %esp,%ebp
+ /* Keep aligned (call + pushl + 8 = 16 bytes). */
+ subl $8,%esp
+
+ /* Allocate the stack, and exit in case of failure */
+ call NAME(grt_stack_allocate)
+ testl %eax,%eax
+ je .Ldone
+
+ /* Note: %EAX contains the address of the stack_context. This is
+ also the top of the stack. */
+
+ /* Prepare stack. */
+ /* The function to be executed. */
+ movl 8(%ebp), %ecx
+ movl %ecx, -4(%eax)
+ /* The argument. */
+ movl 12(%ebp), %ecx
+ movl %ecx, -8(%eax)
+ /* The return function. */
+#if __APPLE__
+ call ___x86.get_pc_thunk.cx
+L1$pb:
+ movl L_grt_stack_loop$non_lazy_ptr-L1$pb(%ecx), %ecx
+ movl %ecx,-12(%eax)
+#else
+ movl $NAME(grt_stack_loop), -12(%eax)
+#endif
+ /* The context. */
+ movl %ebx, -16(%eax)
+ movl %esi, -20(%eax)
+ movl %edi, -24(%eax)
+ movl %ebp, -28(%eax)
+
+ /* Save the new stack pointer to the stack context. */
+ leal -28(%eax), %ecx
+ movl %ecx, (%eax)
+
+.Ldone:
+ leave
+ ret
+END(grt_stack_create)
+
+
+ /* Arguments: TO, FROM
+ Both are pointers to a stack_context. */
+ENTRY(grt_stack_switch)
+ /* TO -> ECX. */
+ movl 4(%esp), %ecx
+ /* FROM -> EDX. */
+ movl 8(%esp), %edx
+ /* Save call-used registers. */
+ pushl %ebx
+ pushl %esi
+ pushl %edi
+ pushl %ebp
+ /* Save the current stack. */
+ movl %esp, (%edx)
+ /* Stack switch. */
+ movl (%ecx), %esp
+ /* Restore call-used registers. */
+ popl %ebp
+ popl %edi
+ popl %esi
+ popl %ebx
+ /* Run. */
+ ret
+END(grt_stack_switch)
+
+
+#if __APPLE__
+ .section __TEXT,__textcoal_nt,coalesced,pure_instructions
+ .weak_definition ___x86.get_pc_thunk.cx
+ .private_extern ___x86.get_pc_thunk.cx
+___x86.get_pc_thunk.cx:
+ movl (%esp), %ecx
+ ret
+
+ .section __IMPORT,__pointers,non_lazy_symbol_pointers
+L_grt_stack_loop$non_lazy_ptr:
+ .indirect_symbol _grt_stack_loop
+ .long 0
+#endif
+
+ .ident "Written by T.Gingold"
diff --git a/src/translate/grt/config/ia64.S b/src/translate/grt/config/ia64.S
new file mode 100644
index 000000000..9ce3800bb
--- /dev/null
+++ b/src/translate/grt/config/ia64.S
@@ -0,0 +1,331 @@
+/* GRT stack implementation for ia64.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "ia64.S"
+ .pred.safe_across_calls p1-p5,p16-p63
+
+ .text
+ .align 16
+ .proc grt_stack_loop
+grt_stack_loop:
+ alloc r32 = ar.pfs, 0, 1, 1, 0
+ .body
+ ;;
+1: mov r33 = r4
+ br.call.sptk.many b0 = b1
+ ;;
+ br 1b
+ .endp
+
+ frame_size = 480
+
+ .global grt_stack_switch#
+ .proc grt_stack_switch#
+ /* r32: struct stack_context *TO, r33: struct stack_context *FROM. */
+ // Registers to be saved:
+ // ar.rsc, ar.bsp, ar.pfs, ar.lc, ar.rnat [5]
+ // gp, r4-r7 (+ Nat) [6]
+ // f2-f5, f16-f31 [20]
+ // p1-p5, p16-p63 [1] ???
+ // b1-b5 [5]
+ // f2-f5, f16-f31 [20*16]
+grt_stack_switch:
+ .prologue 2, 2
+ .vframe r2
+ {
+ alloc r31=ar.pfs, 2, 0, 0, 0
+ mov r14 = ar.rsc
+ adds r12 = -frame_size, r12
+ .body
+ ;;
+ }
+ // Save ar.rsc, ar.bsp, ar.pfs
+ {
+ st8 [r12] = r14 // sp + 0 <- ar.rsc
+ mov r15 = ar.bsp
+ adds r22 = (5*8), r12
+ ;;
+ }
+ {
+ st8.spill [r22] = r1, 8 // sp + 40 <- r1
+ ;;
+ st8.spill [r22] = r4, 8 // sp + 48 <- r4
+ adds r20 = 8, r12
+ ;;
+ }
+ st8 [r20] = r15, 8 // sp + 8 <- ar.bsp
+ st8.spill [r22] = r5, 8 // sp + 56 <- r5
+ mov r15 = ar.lc
+ ;;
+ {
+ st8 [r20] = r31, 8 // sp + 16 <- ar.pfs
+ // Flush dirty registers to the backing store
+ flushrs
+ mov r14 = b0
+ ;;
+ }
+ {
+ st8 [r20] = r15, 8 // sp + 24 <- ar.lc
+ // Set the RSE in enforced lazy mode.
+ mov ar.rsc = 0
+ ;;
+ }
+ {
+ // Save sp.
+ st8 [r33] = r12
+ mov r15 = ar.rnat
+ mov r16 = b1
+ ;;
+ }
+ {
+ st8.spill [r22] = r6, 8 // sp + 64 <- r6
+ st8 [r20] = r15, 64 // sp + 32 <- ar.rnat
+ ;;
+ }
+ {
+ st8.spill [r22] = r7, 16 // sp + 72 <- r7
+ st8 [r20] = r14, 8 // sp + 96 <- b0
+ mov r15 = b2
+ ;;
+ }
+ {
+ mov r17 = ar.unat
+ ;;
+ st8 [r22] = r17, 24 // sp + 88 <- ar.unat
+ mov r14 = b3
+ ;;
+ }
+ {
+ st8 [r20] = r16, 16 // sp + 104 <- b1
+ st8 [r22] = r15, 16 // sp + 112 <- b2
+ mov r17 = b4
+ ;;
+ }
+ {
+ st8 [r20] = r14, 16 // sp + 120 <- b3
+ st8 [r22] = r17, 16 // sp + 128 <- b4
+ mov r15 = b5
+ ;;
+ }
+ {
+ // Read new sp.
+ ld8 r21 = [r32]
+ ;;
+ st8 [r20] = r15, 24 // sp + 136 <- b5
+ mov r14 = pr
+ ;;
+ }
+ ;;
+ st8 [r22] = r14, 32 // sp + 144 <- pr
+ stf.spill [r20] = f2, 32 // sp + 160 <- f2
+ ;;
+ stf.spill [r22] = f3, 32 // sp + 176 <- f3
+ stf.spill [r20] = f4, 32 // sp + 192 <- f4
+ ;;
+ stf.spill [r22] = f5, 32 // sp + 208 <- f5
+ stf.spill [r20] = f16, 32 // sp + 224 <- f16
+ ;;
+ stf.spill [r22] = f17, 32 // sp + 240 <- f17
+ stf.spill [r20] = f18, 32 // sp + 256 <- f18
+ ;;
+ stf.spill [r22] = f19, 32 // sp + 272 <- f19
+ stf.spill [r20] = f20, 32 // sp + 288 <- f20
+ ;;
+ stf.spill [r22] = f21, 32 // sp + 304 <- f21
+ stf.spill [r20] = f22, 32 // sp + 320 <- f22
+ ;;
+ stf.spill [r22] = f23, 32 // sp + 336 <- f23
+ stf.spill [r20] = f24, 32 // sp + 352 <- f24
+ ;;
+ stf.spill [r22] = f25, 32 // sp + 368 <- f25
+ stf.spill [r20] = f26, 32 // sp + 384 <- f26
+ ;;
+ stf.spill [r22] = f27, 32 // sp + 400 <- f27
+ stf.spill [r20] = f28, 32 // sp + 416 <- f28
+ ;;
+ stf.spill [r22] = f29, 32 // sp + 432 <- f29
+ stf.spill [r20] = f30, 32 // sp + 448 <- f30
+ ;;
+ {
+ stf.spill [r22] = f31, 32 // sp + 464 <- f31
+ invala
+ adds r20 = 8, r21
+ ;;
+ }
+ ld8 r14 = [r21], 88 // sp + 0 (ar.rsc)
+ ld8 r16 = [r20], 8 // sp + 8 (ar.bsp)
+ ;;
+ ld8 r15 = [r21], -56 // sp + 88 (ar.unat)
+ ;;
+ ld8 r18 = [r20], 8 // sp + 16 (ar.pfs)
+ mov ar.unat = r15
+ ld8 r17 = [r21], 8 // sp + 32 (ar.rnat)
+ ;;
+ ld8 r15 = [r20], 72 // sp + 24 (ar.lc)
+ ld8.fill r1 = [r21], 8 // sp + 40 (r1)
+ mov ar.bspstore = r16
+ ;;
+ ld8.fill r4 = [r21], 8 // sp + 48 (r4)
+ mov ar.pfs = r18
+ mov ar.rnat = r17
+ ;;
+ mov ar.rsc = r14
+ mov ar.lc = r15
+ ld8 r17 = [r20], 8 // sp + 96 (b0)
+ ;;
+ {
+ ld8.fill r5 = [r21], 8 // sp + 56 (r5)
+ ld8 r14 = [r20], 8 // sp + 104 (b1)
+ mov b0 = r17
+ ;;
+ }
+ {
+ ld8.fill r6 = [r21], 8 // sp + 64 (r6)
+ ld8 r15 = [r20], 8 // sp + 112 (b2)
+ mov b1 = r14
+ ;;
+ }
+ ld8.fill r7 = [r21], 64 // sp + 72 (r7)
+ ld8 r14 = [r20], 8 // sp + 120 (b3)
+ mov b2 = r15
+ ;;
+ ld8 r15 = [r20], 16 // sp + 128 (b4)
+ ld8 r16 = [r21], 40 // sp + 136 (b5)
+ mov b3 = r14
+ ;;
+ {
+ ld8 r14 = [r20], 16 // sp + 144 (pr)
+ ;;
+ ldf.fill f2 = [r20], 32 // sp + 160 (f2)
+ mov b4 = r15
+ ;;
+ }
+ ldf.fill f3 = [r21], 32 // sp + 176 (f3)
+ ldf.fill f4 = [r20], 32 // sp + 192 (f4)
+ mov b5 = r16
+ ;;
+ ldf.fill f5 = [r21], 32 // sp + 208 (f5)
+ ldf.fill f16 = [r20], 32 // sp + 224 (f16)
+ mov pr = r14, -1
+ ;;
+ ldf.fill f17 = [r21], 32 // sp + 240 (f17)
+ ldf.fill f18 = [r20], 32 // sp + 256 (f18)
+ ;;
+ ldf.fill f19 = [r21], 32 // sp + 272 (f19)
+ ldf.fill f20 = [r20], 32 // sp + 288 (f20)
+ ;;
+ ldf.fill f21 = [r21], 32 // sp + 304 (f21)
+ ldf.fill f22 = [r20], 32 // sp + 320 (f22)
+ ;;
+ ldf.fill f23 = [r21], 32 // sp + 336 (f23)
+ ldf.fill f24 = [r20], 32 // sp + 352 (f24)
+ ;;
+ ldf.fill f25 = [r21], 32 // sp + 368 (f25)
+ ldf.fill f26 = [r20], 32 // sp + 384 (f26)
+ ;;
+ ldf.fill f27 = [r21], 32 // sp + 400 (f27)
+ ldf.fill f28 = [r20], 32 // sp + 416 (f28)
+ ;;
+ ldf.fill f29 = [r21], 32 // sp + 432 (f29)
+ ldf.fill f30 = [r20], 32 // sp + 448 (f30)
+ ;;
+ ldf.fill f31 = [r21], 32 // sp + 464 (f31)
+ mov r12 = r20
+ br.ret.sptk.many b0
+ ;;
+ .endp grt_stack_switch#
+
+ .align 16
+ // r32: func, r33: arg
+ .global grt_stack_create#
+ .proc grt_stack_create#
+grt_stack_create:
+ .prologue 14, 34
+ .save ar.pfs, r35
+ alloc r35 = ar.pfs, 2, 3, 0, 0
+ .save rp, r34
+ // Compute backing store.
+ movl r14 = stack_max_size
+ ;;
+ .body
+ {
+ ld4 r36 = [r14] // r14: bsp
+ mov r34 = b0
+ br.call.sptk.many b0 = grt_stack_allocate#
+ ;;
+ }
+ {
+ ld8 r22 = [r32], 8 // read ip (-> b1)
+ ;;
+ ld8 r23 = [r32] // read r1 from func
+ adds r21 = -(frame_size + 16) + 32, r8
+ ;;
+ }
+ {
+ st8 [r21] = r0, -32 // sp + 32 (ar.rnat = 0)
+ ;;
+ st8 [r8] = r21 // Save cur_sp
+ mov r18 = 0x0f // ar.rsc: LE, PL=3, Eager
+ ;;
+ }
+ {
+ st8 [r21] = r18, 40 // sp + 0 (ar.rsc)
+ ;;
+ st8 [r21] = r23, 64 // sp + 40 (r1 = func.r1)
+ mov b0 = r34
+ ;;
+ }
+ {
+ st8 [r21] = r22, -96 // sp + 104 (b1 = func.ip)
+ movl r15 = grt_stack_loop
+ ;;
+ }
+ sub r14 = r8, r36 // Backing store base
+ ;;
+ adds r14 = 16, r14 // Add sizeof (stack_context)
+ adds r20 = 40, r21
+ ;;
+ {
+ st8 [r21] = r14, 88 // sp + 8 (ar.bsp)
+ ;;
+ st8 [r21] = r15, -80 // sp + 96 (b0 = grt_stack_loop)
+ mov r16 = (0 << 7) | 1 // CFM: sol=0, sof=1
+ ;;
+ }
+ {
+ st8 [r21] = r16, 8 // sp + 16 (ar.pfs)
+ ;;
+ st8 [r21] = r0, 24 // sp + 24 (ar.lc)
+ mov ar.pfs = r35
+ ;;
+ }
+ {
+ st8 [r20] = r0, 8 // sp + 32 (ar.rnat)
+ st8 [r21] = r33 // sp + 48 (r4 = arg)
+ br.ret.sptk.many b0
+ ;;
+ }
+ .endp grt_stack_create#
+ .ident "GCC: (GNU) 4.0.2"
diff --git a/src/translate/grt/config/linux.c b/src/translate/grt/config/linux.c
new file mode 100644
index 000000000..74dce0903
--- /dev/null
+++ b/src/translate/grt/config/linux.c
@@ -0,0 +1,361 @@
+/* GRT stacks implementation for linux and other *nix.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+#define _GNU_SOURCE
+#include
+#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
new file mode 100644
index 000000000..bedd48ab4
--- /dev/null
+++ b/src/translate/grt/config/ppc.S
@@ -0,0 +1,334 @@
+/* GRT stack implementation for ppc.
+ Copyright (C) 2005 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "ppc.S"
+
+ .section ".text"
+
+#define OFF 240
+
+#define GREG(x) x
+#define FREG(x) x
+
+#define r0 GREG(0)
+#define r1 GREG(1)
+#define r2 GREG(2)
+#define r3 GREG(3)
+#define r4 GREG(4)
+#define r5 GREG(5)
+#define r6 GREG(6)
+#define r7 GREG(7)
+#define r8 GREG(8)
+#define r9 GREG(9)
+#define r10 GREG(10)
+#define r11 GREG(11)
+#define r12 GREG(12)
+#define r13 GREG(13)
+#define r14 GREG(14)
+#define r15 GREG(15)
+#define r16 GREG(16)
+#define r17 GREG(17)
+#define r18 GREG(18)
+#define r19 GREG(19)
+#define r20 GREG(20)
+#define r21 GREG(21)
+#define r22 GREG(22)
+#define r23 GREG(23)
+#define r24 GREG(24)
+#define r25 GREG(25)
+#define r26 GREG(26)
+#define r27 GREG(27)
+#define r28 GREG(28)
+#define r29 GREG(29)
+#define r30 GREG(30)
+#define r31 GREG(31)
+
+#define f0 FREG(0)
+#define f1 FREG(1)
+#define f2 FREG(2)
+#define f3 FREG(3)
+#define f4 FREG(4)
+#define f5 FREG(5)
+#define f6 FREG(6)
+#define f7 FREG(7)
+#define f8 FREG(8)
+#define f9 FREG(9)
+#define f10 FREG(10)
+#define f11 FREG(11)
+#define f12 FREG(12)
+#define f13 FREG(13)
+#define f14 FREG(14)
+#define f15 FREG(15)
+#define f16 FREG(16)
+#define f17 FREG(17)
+#define f18 FREG(18)
+#define f19 FREG(19)
+#define f20 FREG(20)
+#define f21 FREG(21)
+#define f22 FREG(22)
+#define f23 FREG(23)
+#define f24 FREG(24)
+#define f25 FREG(25)
+#define f26 FREG(26)
+#define f27 FREG(27)
+#define f28 FREG(28)
+#define f29 FREG(29)
+#define f30 FREG(30)
+#define f31 FREG(31)
+
+ /* Stack structure is:
+ +4 : cur_length \ Stack
+ +0 : cur_sp / Context
+ -4 : arg
+ -8 : func
+
+ -12: pad
+ -16: pad
+ -20: LR save word
+ -24: Back chain
+
+ -28: fp/gp saved registers.
+ -4 : return address
+ -8 : process function to be executed
+ -12: function argument
+ ...
+ -72: %sp
+ */
+
+ /* Function called to loop on the process. */
+ .align 4
+ .type grt_stack_loop,@function
+grt_stack_loop:
+ /* Get function. */
+ lwz r0,16(r1)
+ /* Get argument. */
+ lwz r3,20(r1)
+ mtlr r0
+ blrl
+ b grt_stack_loop
+ .size grt_stack_loop, . - grt_stack_loop
+
+ /* function Stack_Create (Func : Address; Arg : Address)
+ return Stack_Type; */
+ .align 4
+ .global grt_stack_create
+ .type grt_stack_create,@function
+grt_stack_create:
+ /* Standard prologue. */
+ stwu r1,-32(r1)
+ mflr r0
+ stw r0,36(r1)
+
+ /* Save arguments. */
+ stw r3,24(r1)
+ stw r4,28(r1)
+
+ /* Allocate the stack, and exit in case of failure */
+ bl grt_stack_allocate
+ cmpwi 0,r3,0
+ beq- .Ldone
+
+ /* Note: r3 contains the address of the stack_context. This is
+ also the top of the stack. */
+
+ /* Prepare stack. */
+ /* Align the stack. */
+ addi r5,r3,-24
+
+ /* Save the parameters. */
+ lwz r6,24(r1)
+ stw r6,16(r5)
+ lwz r7,28(r1)
+ stw r7,20(r5)
+
+ /* The return function. */
+ lis r4,grt_stack_loop@ha
+ la r4,grt_stack_loop@l(r4)
+ stw r4,4(r5)
+ /* Back-Chain. */
+ addi r4,r1,32
+ stw r4,0(r5)
+
+ /* Save register.
+ They should be considered as garbage. */
+ addi r4,r5,-OFF
+
+ stfd f31,(OFF - 8)(r4)
+ stfd f30,(OFF - 16)(r4)
+ stfd f29,(OFF - 24)(r4)
+ stfd f28,(OFF - 32)(r4)
+ stfd f27,(OFF - 40)(r4)
+ stfd f26,(OFF - 48)(r4)
+ stfd f25,(OFF - 56)(r4)
+ stfd f24,(OFF - 64)(r4)
+ stfd f23,(OFF - 72)(r4)
+ stfd f22,(OFF - 80)(r4)
+ stfd f21,(OFF - 88)(r4)
+ stfd f20,(OFF - 96)(r4)
+ stfd f19,(OFF - 104)(r4)
+ stfd f18,(OFF - 112)(r4)
+ stfd f17,(OFF - 120)(r4)
+ stfd f16,(OFF - 128)(r4)
+ stfd f15,(OFF - 136)(r4)
+ stfd f14,(OFF - 144)(r4)
+ stw r31,(OFF - 148)(r4)
+ stw r30,(OFF - 152)(r4)
+ stw r29,(OFF - 156)(r4)
+ stw r28,(OFF - 160)(r4)
+ stw r27,(OFF - 164)(r4)
+ stw r26,(OFF - 168)(r4)
+ stw r25,(OFF - 172)(r4)
+ stw r24,(OFF - 176)(r4)
+ stw r23,(OFF - 180)(r4)
+ stw r22,(OFF - 184)(r4)
+ stw r21,(OFF - 188)(r4)
+ stw r20,(OFF - 192)(r4)
+ stw r19,(OFF - 196)(r4)
+ stw r18,(OFF - 200)(r4)
+ stw r17,(OFF - 204)(r4)
+ stw r16,(OFF - 208)(r4)
+ stw r15,(OFF - 212)(r4)
+ stw r14,(OFF - 216)(r4)
+ mfcr r0
+ stw r0, (OFF - 220)(r4)
+
+ /* Save stack pointer. */
+ stw r4, 0(r3)
+
+.Ldone:
+ lwz r0,36(r1)
+ mtlr r0
+ addi r1,r1,32
+ blr
+ .size grt_stack_create,. - grt_stack_create
+
+
+ .align 4
+ .global grt_stack_switch
+ /* Arguments: TO, FROM.
+ Both are pointers to a stack_context. */
+ .type grt_stack_switch,@function
+grt_stack_switch:
+ /* Standard prologue, save return address. */
+ stwu r1,(-OFF)(r1)
+ mflr r0
+ stw r0,(OFF + 4)(r1)
+
+ /* Save r14-r31, f14-f31, CR
+ This is 18 words + 18 double words, ie 216 bytes. */
+ /* Maybe use the savefpr function ? */
+ stfd f31,(OFF - 8)(r1)
+ stfd f30,(OFF - 16)(r1)
+ stfd f29,(OFF - 24)(r1)
+ stfd f28,(OFF - 32)(r1)
+ stfd f27,(OFF - 40)(r1)
+ stfd f26,(OFF - 48)(r1)
+ stfd f25,(OFF - 56)(r1)
+ stfd f24,(OFF - 64)(r1)
+ stfd f23,(OFF - 72)(r1)
+ stfd f22,(OFF - 80)(r1)
+ stfd f21,(OFF - 88)(r1)
+ stfd f20,(OFF - 96)(r1)
+ stfd f19,(OFF - 104)(r1)
+ stfd f18,(OFF - 112)(r1)
+ stfd f17,(OFF - 120)(r1)
+ stfd f16,(OFF - 128)(r1)
+ stfd f15,(OFF - 136)(r1)
+ stfd f14,(OFF - 144)(r1)
+ stw r31,(OFF - 148)(r1)
+ stw r30,(OFF - 152)(r1)
+ stw r29,(OFF - 156)(r1)
+ stw r28,(OFF - 160)(r1)
+ stw r27,(OFF - 164)(r1)
+ stw r26,(OFF - 168)(r1)
+ stw r25,(OFF - 172)(r1)
+ stw r24,(OFF - 176)(r1)
+ stw r23,(OFF - 180)(r1)
+ stw r22,(OFF - 184)(r1)
+ stw r21,(OFF - 188)(r1)
+ stw r20,(OFF - 192)(r1)
+ stw r19,(OFF - 196)(r1)
+ stw r18,(OFF - 200)(r1)
+ stw r17,(OFF - 204)(r1)
+ stw r16,(OFF - 208)(r1)
+ stw r15,(OFF - 212)(r1)
+ stw r14,(OFF - 216)(r1)
+ mfcr r0
+ stw r0, (OFF - 220)(r1)
+
+ /* Save stack pointer. */
+ stw r1, 0(r4)
+
+ /* Load stack pointer. */
+ lwz r1, 0(r3)
+
+
+ lfd f31,(OFF - 8)(r1)
+ lfd f30,(OFF - 16)(r1)
+ lfd f29,(OFF - 24)(r1)
+ lfd f28,(OFF - 32)(r1)
+ lfd f27,(OFF - 40)(r1)
+ lfd f26,(OFF - 48)(r1)
+ lfd f25,(OFF - 56)(r1)
+ lfd f24,(OFF - 64)(r1)
+ lfd f23,(OFF - 72)(r1)
+ lfd f22,(OFF - 80)(r1)
+ lfd f21,(OFF - 88)(r1)
+ lfd f20,(OFF - 96)(r1)
+ lfd f19,(OFF - 104)(r1)
+ lfd f18,(OFF - 112)(r1)
+ lfd f17,(OFF - 120)(r1)
+ lfd f16,(OFF - 128)(r1)
+ lfd f15,(OFF - 136)(r1)
+ lfd f14,(OFF - 144)(r1)
+ lwz r31,(OFF - 148)(r1)
+ lwz r30,(OFF - 152)(r1)
+ lwz r29,(OFF - 156)(r1)
+ lwz r28,(OFF - 160)(r1)
+ lwz r27,(OFF - 164)(r1)
+ lwz r26,(OFF - 168)(r1)
+ lwz r25,(OFF - 172)(r1)
+ lwz r24,(OFF - 176)(r1)
+ lwz r23,(OFF - 180)(r1)
+ lwz r22,(OFF - 184)(r1)
+ lwz r21,(OFF - 188)(r1)
+ lwz r20,(OFF - 192)(r1)
+ lwz r19,(OFF - 196)(r1)
+ lwz r18,(OFF - 200)(r1)
+ lwz r17,(OFF - 204)(r1)
+ lwz r16,(OFF - 208)(r1)
+ lwz r15,(OFF - 212)(r1)
+ lwz r14,(OFF - 216)(r1)
+ lwz r0, (OFF - 220)(r1)
+ mtcr r0
+
+ lwz r0,(OFF + 4)(r1)
+ mtlr r0
+ addi r1,r1,OFF
+ blr
+ .size grt_stack_switch, . - grt_stack_switch
+
+
+ .ident "Written by T.Gingold"
diff --git a/src/translate/grt/config/pthread.c b/src/translate/grt/config/pthread.c
new file mode 100644
index 000000000..189ae90c8
--- /dev/null
+++ b/src/translate/grt/config/pthread.c
@@ -0,0 +1,239 @@
+/* GRT stack implementation based on pthreads.
+ Copyright (C) 2003 - 2014 Felix Bertram & Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+//-----------------------------------------------------------------------------
+// Project: GHDL - VHDL Simulator
+// Description: pthread port of stacks package, for use with MacOSX
+// Note: Tristan's original i386/Linux used assembly-code
+// to manually switch stacks for performance reasons.
+// History: 2003may22, FB, created.
+//-----------------------------------------------------------------------------
+
+#include
+#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
new file mode 100644
index 000000000..0ffe412ed
--- /dev/null
+++ b/src/translate/grt/config/sparc.S
@@ -0,0 +1,141 @@
+/* GRT stack implementation for x86.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+ .file "sparc.S"
+
+ .section ".text"
+
+ /* Stack structure is:
+ +4 : cur_length
+ +0 : cur_sp
+ -4 : return address
+ -8 : process function to be executed
+ -12: function argument
+ ...
+ -72: %sp
+ */
+
+ /* Function called to loop on the process. */
+ .align 4
+ .type grt_stack_loop,#function
+grt_stack_loop:
+ ld [%sp + 64], %o1
+ jmpl %o1 + 0, %o7
+ ld [%sp + 68], %o0
+ ba grt_stack_loop
+ nop
+ .size grt_stack_loop, . - grt_stack_loop
+
+ /* function Stack_Create (Func : Address; Arg : Address)
+ return Stack_Type; */
+ .align 4
+ .global grt_stack_create
+ .type grt_stack_create,#function
+grt_stack_create:
+ /* Standard prologue. */
+ save %sp,-80,%sp
+
+ /* Allocate the stack, and exit in case of failure */
+ call grt_stack_allocate
+ nop
+ cmp %o0, 0
+ be .Ldone
+ nop
+
+ /* Note: %o0 contains the address of the stack_context. This is
+ also the top of the stack. */
+
+ /* Prepare stack. */
+
+ /* The return function. */
+ sethi %hi(grt_stack_loop - 8), %l2
+ or %lo(grt_stack_loop - 8), %l2, %l2
+
+ /* Create a frame for grt_stack_loop. */
+ sub %o0, (64 + 8), %l1
+
+ /* The function to be executed. */
+ st %i0, [%l1 + 64]
+ /* The argument. */
+ st %i1, [%l1 + 68]
+
+ /* Create a frame for grt_stack_switch. */
+ sub %l1, 64, %l0
+
+ /* Save frame pointer. */
+ st %l1, [%l0 + 56]
+ /* Save return address. */
+ st %l2, [%l0 + 60]
+
+ /* Save stack pointer. */
+ st %l0, [%o0]
+
+.Ldone:
+ ret
+ restore %o0, %g0, %o0
+ .size grt_stack_create,. - grt_stack_create
+
+
+ .align 4
+ .global grt_stack_switch
+ /* Arguments: TO, FROM.
+ Both are pointers to a stack_context. */
+ .type grt_stack_switch,#function
+grt_stack_switch:
+ /* Standard prologue. */
+ save %sp,-80,%sp
+
+ /* Flush and invalidate windows.
+ It is not clear wether the current window is saved or not,
+ therefore, I assume it is not.
+ */
+ ta 3
+
+ /* Only IN registers %fp and %i7 (return address) must be saved.
+ Of course, I could use std/ldd, but it is not as clear
+ */
+ /* Save current frame pointer. */
+ st %fp, [%sp + 56]
+ /* Save return address. */
+ st %i7, [%sp + 60]
+
+ /* Save stack pointer. */
+ st %sp, [%i1]
+
+ /* Load stack pointer. */
+ ld [%i0], %sp
+
+ /* Load return address. */
+ ld [%sp + 60], %i7
+ /* Load frame pointer. */
+ ld [%sp + 56], %fp
+
+ /* Return. */
+ ret
+ restore
+ .size grt_stack_switch, . - grt_stack_switch
+
+
+ .ident "Written by T.Gingold"
diff --git a/src/translate/grt/config/teststack.c b/src/translate/grt/config/teststack.c
new file mode 100644
index 000000000..6a6966d6f
--- /dev/null
+++ b/src/translate/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/translate/grt/config/times.c b/src/translate/grt/config/times.c
new file mode 100644
index 000000000..9c0b4ebba
--- /dev/null
+++ b/src/translate/grt/config/times.c
@@ -0,0 +1,55 @@
+/* GRT C bindings for time.
+ Copyright (C) 2002 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+#include
+#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
new file mode 100644
index 000000000..35322ba9f
--- /dev/null
+++ b/src/translate/grt/config/win32.c
@@ -0,0 +1,265 @@
+/* GRT stack implementation for Win32 using fibers.
+ Copyright (C) 2005 - 2014 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+
+ As a special exception, if other files instantiate generics from this
+ unit, or you link this unit with other files to produce an executable,
+ this unit does not by itself cause the resulting executable to be
+ covered by the GNU General Public License. This exception does not
+ however invalidate any other reasons why the executable file might be
+ covered by the GNU Public License.
+*/
+
+#include
+#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
new file mode 100644
index 000000000..bcebc49d5
--- /dev/null
+++ b/src/translate/grt/config/win32thr.c
@@ -0,0 +1,167 @@
+/* GRT stack implementation for Win32
+ Copyright (C) 2004, 2005 Felix Bertram.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+//-----------------------------------------------------------------------------
+// Project: GHDL - VHDL Simulator
+// Description: Win32 port of stacks package
+// Note: Tristan's original i386/Linux used assembly-code
+// to manually switch stacks for performance reasons.
+// History: 2004feb09, FB, created.
+//-----------------------------------------------------------------------------
+
+#include
+//#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
new file mode 100644
index 000000000..ce5b67d7e
--- /dev/null
+++ b/src/translate/grt/ghdl_main.adb
@@ -0,0 +1,61 @@
+-- GHDL Run Time (GRT) entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Ada.Unchecked_Conversion;
+with Grt.Options; use Grt.Options;
+with Grt.Main;
+with Grt.Types; use Grt.Types;
+
+-- Some files are only referenced from compiled code. With it here so that
+-- they get compiled during build (and elaborated).
+pragma Warnings (Off);
+with Grt.Rtis_Binding;
+with Grt.Std_Logic_1164;
+pragma Warnings (On);
+
+
+function Ghdl_Main (Argc : Integer; Argv : System.Address)
+ return Integer
+is
+ -- Grt_Init corresponds to the 'adainit' subprogram for grt.
+ procedure Grt_Init;
+ pragma Import (C, Grt_Init, "grt_init");
+
+ function To_Argv_Type is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Grt.Options.Argv_Type);
+
+ Default_Progname : constant String := "ghdl_design" & NUL;
+begin
+ if Argc > 0 then
+ Grt.Options.Progname := To_Argv_Type (Argv)(0);
+ else
+ Grt.Options.Progname := To_Ghdl_C_String (Default_Progname'Address);
+ end if;
+ Grt.Options.Argc := Argc;
+ Grt.Options.Argv := To_Argv_Type (Argv);
+
+ Grt_Init;
+ Grt.Main.Run;
+ return 0;
+end Ghdl_Main;
diff --git a/src/translate/grt/ghdl_main.ads b/src/translate/grt/ghdl_main.ads
new file mode 100644
index 000000000..88d181a0a
--- /dev/null
+++ b/src/translate/grt/ghdl_main.ads
@@ -0,0 +1,33 @@
+-- GHDL Run Time (GRT) entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+
+-- 'main' function for grt.
+-- Contrary to the C main function, ARGC can be 0 (in this case a fake argv[0]
+-- is used).
+function Ghdl_Main (Argc : Integer; Argv : System.Address)
+ return Integer;
+pragma Export (C, Ghdl_Main, "ghdl_main");
+
diff --git a/src/translate/grt/ghwdump.c b/src/translate/grt/ghwdump.c
new file mode 100644
index 000000000..4affc2b5c
--- /dev/null
+++ b/src/translate/grt/ghwdump.c
@@ -0,0 +1,195 @@
+/* Display a GHDL Wavefile for debugging.
+ Copyright (C) 2005 Tristan Gingold
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+
+#include
+#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
new file mode 100644
index 000000000..2db63d9c9
--- /dev/null
+++ b/src/translate/grt/ghwlib.c
@@ -0,0 +1,1746 @@
+/* GHDL Wavefile reader library.
+ Copyright (C) 2005 Tristan Gingold
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+
+#include
+#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
new file mode 100644
index 000000000..0138267ed
--- /dev/null
+++ b/src/translate/grt/ghwlib.h
@@ -0,0 +1,399 @@
+/* GHDL Wavefile reader library.
+ Copyright (C) 2005 Tristan Gingold
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+
+
+#ifndef _GHWLIB_H_
+#define _GHWLIB_H_
+
+#include
+#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
new file mode 100644
index 000000000..5f5aa0e4c
--- /dev/null
+++ b/src/translate/grt/grt-arch.ads
@@ -0,0 +1,2 @@
+With Grt.Arch_None;
+Package Grt.Arch renames Grt.Arch_None;
diff --git a/src/translate/grt/grt-arch_none.adb b/src/translate/grt/grt-arch_none.adb
new file mode 100644
index 000000000..14db1c7d5
--- /dev/null
+++ b/src/translate/grt/grt-arch_none.adb
@@ -0,0 +1,7 @@
+package body Grt.Arch_None is
+ function Get_Time_Stamp return Ghdl_U64 is
+ begin
+ return 0;
+ end Get_Time_Stamp;
+end Grt.Arch_None;
+
diff --git a/src/translate/grt/grt-arch_none.ads b/src/translate/grt/grt-arch_none.ads
new file mode 100644
index 000000000..f8ae437d6
--- /dev/null
+++ b/src/translate/grt/grt-arch_none.ads
@@ -0,0 +1,6 @@
+with Grt.Types; use Grt.Types;
+
+package Grt.Arch_None is
+ function Get_Time_Stamp return Ghdl_U64;
+ pragma Inline (Get_Time_Stamp);
+end Grt.Arch_None;
diff --git a/src/translate/grt/grt-astdio.adb b/src/translate/grt/grt-astdio.adb
new file mode 100644
index 000000000..456d024ac
--- /dev/null
+++ b/src/translate/grt/grt-astdio.adb
@@ -0,0 +1,231 @@
+-- GHDL Run Time (GRT) stdio subprograms for GRT types.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.C; use Grt.C;
+
+package body Grt.Astdio is
+ procedure Put (Stream : FILEs; Str : String)
+ is
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ S := fwrite (Str'Address, Str'Length, 1, Stream);
+ end Put;
+
+ procedure Put (Stream : FILEs; C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := fputc (Character'Pos (C), Stream);
+ end Put;
+
+ procedure Put (Stream : FILEs; Str : Ghdl_C_String)
+ is
+ Len : Natural;
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ Len := strlen (Str);
+ S := fwrite (Str (1)'Address, size_t (Len), 1, Stream);
+ end Put;
+
+ procedure New_Line (Stream : FILEs) is
+ begin
+ Put (Stream, Nl);
+ end New_Line;
+
+ procedure Put (Str : String)
+ is
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ S := fwrite (Str'Address, Str'Length, 1, stdout);
+ end Put;
+
+ procedure Put (C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := fputc (Character'Pos (C), stdout);
+ end Put;
+
+ procedure Put (Str : Ghdl_C_String)
+ is
+ Len : Natural;
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ Len := strlen (Str);
+ S := fwrite (Str (1)'Address, size_t (Len), 1, stdout);
+ end Put;
+
+ procedure New_Line is
+ begin
+ Put (Nl);
+ end New_Line;
+
+ procedure Put_Line (Str : String)
+ is
+ begin
+ Put (Str);
+ New_Line;
+ end Put_Line;
+
+ procedure Put_Str_Len (Stream : FILEs; Str : Ghdl_Str_Len_Type)
+ is
+ S : String (1 .. 3);
+ begin
+ if Str.Str = null then
+ S (1) := ''';
+ S (2) := Character'Val (Str.Len);
+ S (3) := ''';
+ Put (Stream, S);
+ else
+ Put (Stream, Str.Str (1 .. Str.Len));
+ end if;
+ end Put_Str_Len;
+
+ generic
+ type Ntype is range <>;
+ Max_Len : Natural;
+ procedure Put_Ntype (Stream : FILEs; N : Ntype);
+
+ procedure Put_Ntype (Stream : FILEs; N : Ntype)
+ is
+ Str : String (1 .. Max_Len);
+ P : Natural := Str'Last;
+ V : Ntype;
+ begin
+ -- V is negativ.
+ if N > 0 then
+ V := -N;
+ else
+ V := N;
+ end if;
+ loop
+ Str (P) := Character'Val (48 - (V rem 10)); -- V is <= 0.
+ V := V / 10;
+ exit when V = 0;
+ P := P - 1;
+ end loop;
+ if N < 0 then
+ P := P - 1;
+ Str (P) := '-';
+ end if;
+ Put (Stream, Str (P .. Max_Len));
+ end Put_Ntype;
+
+ generic
+ type Utype is mod <>;
+ Max_Len : Natural;
+ procedure Put_Utype (Stream : FILEs; N : Utype);
+
+ procedure Put_Utype (Stream : FILEs; N : Utype)
+ is
+ Str : String (1 .. Max_Len);
+ P : Natural := Str'Last;
+ V : Utype := N;
+ begin
+ loop
+ Str (P) := Character'Val (48 + (V rem 10));
+ V := V / 10;
+ exit when V = 0;
+ P := P - 1;
+ end loop;
+ Put (Stream, Str (P .. Max_Len));
+ end Put_Utype;
+
+ procedure Put_I32_1 is new Put_Ntype (Ntype => Ghdl_I32, Max_Len => 11);
+ procedure Put_I32 (Stream : FILEs; I32 : Ghdl_I32) renames Put_I32_1;
+
+ procedure Put_U32_1 is new Put_Utype (Utype => Ghdl_U32, Max_Len => 11);
+ procedure Put_U32 (Stream : FILEs; U32 : Ghdl_U32) renames Put_U32_1;
+
+ procedure Put_I64_1 is new Put_Ntype (Ntype => Ghdl_I64, Max_Len => 20);
+ procedure Put_I64 (Stream : FILEs; I64 : Ghdl_I64) renames Put_I64_1;
+
+ procedure Put_U64_1 is new Put_Utype (Utype => Ghdl_U64, Max_Len => 20);
+ procedure Put_U64 (Stream : FILEs; U64 : Ghdl_U64) renames Put_U64_1;
+
+ procedure Put_F64 (Stream : FILEs; F64 : Ghdl_F64)
+ is
+ procedure Fprintf_G (Stream : FILEs;
+ Arg : Ghdl_F64);
+ pragma Import (C, Fprintf_G, "__ghdl_fprintf_g");
+ begin
+ Fprintf_G (Stream, F64);
+ end Put_F64;
+
+ Hex_Map : constant array (0 .. 15) of Character := "0123456789ABCDEF";
+
+ procedure Put (Stream : FILEs; Addr : System.Address)
+ is
+ Res : String (1 .. System.Word_Size / 4);
+ Val : Integer_Address := To_Integer (Addr);
+ begin
+ for I in reverse Res'Range loop
+ Res (I) := Hex_Map (Natural (Val and 15));
+ Val := Val / 16;
+ end loop;
+ Put (Stream, Res);
+ end Put;
+
+ procedure Put_Dir (Stream : FILEs; Dir : Ghdl_Dir_Type) is
+ begin
+ case Dir is
+ when Dir_To =>
+ Put (Stream, " to ");
+ when Dir_Downto =>
+ Put (Stream, " downto ");
+ end case;
+ end Put_Dir;
+
+ procedure Put_Time (Stream : FILEs; Time : Std_Time) is
+ begin
+ if Time = Std_Time'First then
+ Put (Stream, "-Inf");
+ else
+ -- Do not bother with sec, min, and hr.
+ if (Time mod 1_000_000_000_000) = 0 then
+ Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000_000_000));
+ Put (Stream, "ms");
+ elsif (Time mod 1_000_000_000) = 0 then
+ Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000_000));
+ Put (Stream, "us");
+ elsif (Time mod 1_000_000) = 0 then
+ Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000));
+ Put (Stream, "ns");
+ elsif (Time mod 1_000) = 0 then
+ Put_I64 (Stream, Ghdl_I64 (Time / 1_000));
+ Put (Stream, "ps");
+ else
+ Put_I64 (Stream, Ghdl_I64 (Time));
+ Put (Stream, "fs");
+ end if;
+ end if;
+ end Put_Time;
+
+end Grt.Astdio;
diff --git a/src/translate/grt/grt-astdio.ads b/src/translate/grt/grt-astdio.ads
new file mode 100644
index 000000000..8e8b739cc
--- /dev/null
+++ b/src/translate/grt/grt-astdio.ads
@@ -0,0 +1,60 @@
+-- GHDL Run Time (GRT) stdio subprograms for GRT types.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+with Grt.Types; use Grt.Types;
+with Grt.Stdio; use Grt.Stdio;
+
+package Grt.Astdio is
+ pragma Preelaborate (Grt.Astdio);
+
+ -- Procedures to disp on STREAM.
+ procedure Put (Stream : FILEs; Str : String);
+ procedure Put_I32 (Stream : FILEs; I32 : Ghdl_I32);
+ procedure Put_U32 (Stream : FILEs; U32 : Ghdl_U32);
+ procedure Put_I64 (Stream : FILEs; I64 : Ghdl_I64);
+ procedure Put_U64 (Stream : FILEs; U64 : Ghdl_U64);
+ procedure Put_F64 (Stream : FILEs; F64 : Ghdl_F64);
+ procedure Put (Stream : FILEs; Addr : System.Address);
+ procedure Put (Stream : FILEs; Str : Ghdl_C_String);
+ procedure Put (Stream : FILEs; C : Character);
+ procedure New_Line (Stream : FILEs);
+
+ -- Display time with unit, without space.
+ -- Eg: 10ns, 100ms, 97ps...
+ procedure Put_Time (Stream : FILEs; Time : Std_Time);
+
+ -- And on stdout.
+ procedure Put (Str : String);
+ procedure Put (C : Character);
+ procedure New_Line;
+ procedure Put_Line (Str : String);
+ procedure Put (Str : Ghdl_C_String);
+
+ -- Put STR using put procedures.
+ procedure Put_Str_Len (Stream : FILEs; Str : Ghdl_Str_Len_Type);
+
+ -- Put " to " or " downto ".
+ procedure Put_Dir (Stream : FILEs; Dir : Ghdl_Dir_Type);
+end Grt.Astdio;
diff --git a/src/translate/grt/grt-avhpi.adb b/src/translate/grt/grt-avhpi.adb
new file mode 100644
index 000000000..b935fd9a3
--- /dev/null
+++ b/src/translate/grt/grt-avhpi.adb
@@ -0,0 +1,1142 @@
+-- GHDL Run Time (GRT) - VHPI implementation for Ada.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+with Grt.Vstrings; use Grt.Vstrings;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+
+package body Grt.Avhpi is
+ procedure Get_Root_Inst (Res : out VhpiHandleT)
+ is
+ begin
+ Res := (Kind => VhpiRootInstK,
+ Ctxt => Get_Top_Context);
+ end Get_Root_Inst;
+
+ procedure Get_Package_Inst (Res : out VhpiHandleT) is
+ begin
+ Res := (Kind => VhpiIteratorK,
+ Ctxt => (Base => Null_Address,
+ Block => To_Ghdl_Rti_Access (Ghdl_Rti_Top'Address)),
+ Rel => VhpiPackInsts,
+ It_Cur => 0,
+ It2 => 0,
+ Max2 => 0);
+ end Get_Package_Inst;
+
+ -- Number of elements in an array.
+ function Ranges_To_Length (Rngs : Ghdl_Range_Array;
+ Indexes : Ghdl_Rti_Arr_Acc)
+ return Ghdl_Index_Type
+ is
+ Res : Ghdl_Index_Type;
+ begin
+ Res := 1;
+ for I in Rngs'Range loop
+ Res := Res * Range_To_Length
+ (Rngs (I), Get_Base_Type (Indexes (I - Rngs'First)));
+ end loop;
+ return Res;
+ end Ranges_To_Length;
+
+ procedure Vhpi_Iterator (Rel : VhpiOneToManyT;
+ Ref : VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ -- Default value in case of success.
+ Res := (Kind => VhpiIteratorK,
+ Ctxt => Ref.Ctxt,
+ Rel => Rel,
+ It_Cur => 0,
+ It2 => 0,
+ Max2 => 0);
+ Error := AvhpiErrorOk;
+
+ case Rel is
+ when VhpiInternalRegions =>
+ case Ref.Kind is
+ when VhpiRootInstK
+ | VhpiArchBodyK
+ | VhpiBlockStmtK
+ | VhpiIfGenerateK =>
+ return;
+ when VhpiForGenerateK =>
+ Res.It2 := 1;
+ return;
+ when VhpiCompInstStmtK =>
+ Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt);
+ return;
+ when others =>
+ null;
+ end case;
+ when VhpiDecls =>
+ case Ref.Kind is
+ when VhpiArchBodyK
+ | VhpiBlockStmtK
+ | VhpiIfGenerateK
+ | VhpiForGenerateK =>
+ return;
+ when VhpiRootInstK
+ | VhpiPackInstK =>
+ Res.It2 := 1;
+ return;
+ when VhpiCompInstStmtK =>
+ Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt);
+ Res.It2 := 1;
+ return;
+ when others =>
+ null;
+ end case;
+ when VhpiIndexedNames =>
+ case Ref.Kind is
+ when VhpiGenericDeclK =>
+ Res := (Kind => AvhpiNameIteratorK,
+ Ctxt => Ref.Ctxt,
+ N_Addr => Avhpi_Get_Address (Ref),
+ N_Type => Ref.Obj.Obj_Type,
+ N_Idx => 0,
+ N_Obj => Ref.Obj);
+ when VhpiIndexedNameK =>
+ Res := (Kind => AvhpiNameIteratorK,
+ Ctxt => Ref.Ctxt,
+ N_Addr => Ref.N_Addr,
+ N_Type => Ref.N_Type,
+ N_Idx => 0,
+ N_Obj => Ref.N_Obj);
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ return;
+ end case;
+ case Res.N_Type.Kind is
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ St : constant Ghdl_Rtin_Subtype_Array_Acc :=
+ To_Ghdl_Rtin_Subtype_Array_Acc (Res.N_Type);
+ Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype;
+ Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
+ begin
+ Bound_To_Range
+ (Loc_To_Addr (St.Common.Depth, St.Bounds, Res.Ctxt),
+ Bt, Rngs);
+ Res.N_Idx := Ranges_To_Length (Rngs, Bt.Indexes);
+ end;
+ when others =>
+ Error := AvhpiErrorBadRel;
+ end case;
+ return;
+ when others =>
+ null;
+ end case;
+ -- Failure.
+ Res := Null_Handle;
+ Error := AvhpiErrorNotImplemented;
+ end Vhpi_Iterator;
+
+ -- OBJ_RTI is the RTI for the base name.
+ function Add_Index (Ctxt : Rti_Context;
+ Obj_Base : Address;
+ Obj_Rti : Ghdl_Rtin_Object_Acc;
+ El_Type : Ghdl_Rti_Access;
+ Off : Ghdl_Index_Type) return Address
+ is
+ pragma Unreferenced (Ctxt);
+ Is_Sig : Boolean;
+ El_Size : Ghdl_Index_Type;
+ El_Type1 : Ghdl_Rti_Access;
+ begin
+ case Obj_Rti.Common.Kind is
+ when Ghdl_Rtik_Generic =>
+ Is_Sig := False;
+ when others =>
+ Internal_Error ("add_index");
+ end case;
+
+ if El_Type.Kind = Ghdl_Rtik_Subtype_Scalar then
+ El_Type1 := Get_Base_Type (El_Type);
+ else
+ El_Type1 := El_Type;
+ end if;
+
+ case El_Type1.Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ if Is_Sig then
+ El_Size := Address'Size / Storage_Unit;
+ else
+ El_Size := Ghdl_I64'Size / Storage_Unit;
+ end if;
+ when Ghdl_Rtik_Subtype_Array =>
+ if Is_Sig then
+ El_Size := Ghdl_Index_Type
+ (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Sigsize);
+ else
+ El_Size := Ghdl_Index_Type
+ (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Valsize);
+ end if;
+ when others =>
+ Internal_Error ("add_index");
+ end case;
+ return Obj_Base + Off * El_Size;
+ end Add_Index;
+
+ procedure Vhpi_Scan_Indexed_Name (Iterator : in out VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ El_Type : Ghdl_Rti_Access;
+ begin
+ if Iterator.N_Idx = 0 then
+ Error := AvhpiErrorIteratorEnd;
+ return;
+ end if;
+
+ El_Type := To_Ghdl_Rtin_Type_Array_Acc
+ (Get_Base_Type (Iterator.N_Type)).Element;
+
+ Res := (Kind => VhpiIndexedNameK,
+ Ctxt => Iterator.Ctxt,
+ N_Addr => Iterator.N_Addr,
+ N_Type => El_Type,
+ N_Idx => 0,
+ N_Obj => Iterator.N_Obj);
+
+ -- Increment Address.
+ Iterator.N_Addr := Add_Index
+ (Iterator.Ctxt, Iterator.N_Addr, Iterator.N_Obj, El_Type, 1);
+
+ Iterator.N_Idx := Iterator.N_Idx - 1;
+ Error := AvhpiErrorOk;
+ end Vhpi_Scan_Indexed_Name;
+
+ procedure Vhpi_Scan_Internal_Regions (Iterator : in out VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+ Ch : Ghdl_Rti_Access;
+ Nblk : Ghdl_Rtin_Block_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
+ if Blk = null then
+ Error := AvhpiErrorIteratorEnd;
+ return;
+ end if;
+
+ loop
+ << Again >> null;
+ if Iterator.It_Cur >= Blk.Nbr_Child then
+ Error := AvhpiErrorIteratorEnd;
+ return;
+ end if;
+
+ Ch := Blk.Children (Iterator.It_Cur);
+ Nblk := To_Ghdl_Rtin_Block_Acc (Ch);
+
+ if Iterator.Max2 /= 0 then
+ -- A for generate.
+ Iterator.It2 := Iterator.It2 + 1;
+ if Iterator.It2 >= Iterator.Max2 then
+ -- End of loop.
+ Iterator.Max2 := 0;
+ Iterator.It_Cur := Iterator.It_Cur + 1;
+ goto Again;
+ else
+ declare
+ Base : Address;
+ begin
+ Base := To_Addr_Acc (Iterator.Ctxt.Base + Nblk.Loc).all;
+ Base := Base + Iterator.It2 * Nblk.Size;
+ Res := (Kind => VhpiForGenerateK,
+ Ctxt => (Base => Base,
+ Block => Ch));
+
+ Error := AvhpiErrorOk;
+ return;
+ end;
+ end if;
+ end if;
+
+
+ Iterator.It_Cur := Iterator.It_Cur + 1;
+
+ case Ch.Kind is
+ when Ghdl_Rtik_Process =>
+ Res := (Kind => VhpiProcessStmtK,
+ Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc,
+ Block => Ch));
+ Error := AvhpiErrorOk;
+ return;
+ when Ghdl_Rtik_Block =>
+ Res := (Kind => VhpiBlockStmtK,
+ Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc,
+ Block => Ch));
+ Error := AvhpiErrorOk;
+ return;
+ when Ghdl_Rtik_If_Generate =>
+ Res := (Kind => VhpiIfGenerateK,
+ Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base
+ + Nblk.Loc).all,
+ Block => Ch));
+ -- Return only if the condition is true.
+ if Res.Ctxt.Base /= Null_Address then
+ Error := AvhpiErrorOk;
+ return;
+ end if;
+ when Ghdl_Rtik_For_Generate =>
+ Res := (Kind => VhpiForGenerateK,
+ Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base
+ + Nblk.Loc).all,
+ Block => Ch));
+ Iterator.Max2 := Get_For_Generate_Length (Nblk, Iterator.Ctxt);
+ Iterator.It2 := 0;
+ if Iterator.Max2 > 0 then
+ Iterator.It_Cur := Iterator.It_Cur - 1;
+ Error := AvhpiErrorOk;
+ return;
+ end if;
+ -- If the iterator range is nul, then continue to scan.
+ when Ghdl_Rtik_Instance =>
+ Res := (Kind => VhpiCompInstStmtK,
+ Ctxt => Iterator.Ctxt,
+ Inst => To_Ghdl_Rtin_Instance_Acc (Ch));
+ Error := AvhpiErrorOk;
+ return;
+ when others =>
+ -- Next one.
+ null;
+ end case;
+ end loop;
+ end Vhpi_Scan_Internal_Regions;
+
+ procedure Rti_To_Handle (Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Res : out VhpiHandleT)
+ is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Signal =>
+ Res := (Kind => VhpiSigDeclK,
+ Ctxt => Ctxt,
+ Obj => To_Ghdl_Rtin_Object_Acc (Rti));
+ when Ghdl_Rtik_Port =>
+ Res := (Kind => VhpiPortDeclK,
+ Ctxt => Ctxt,
+ Obj => To_Ghdl_Rtin_Object_Acc (Rti));
+ when Ghdl_Rtik_Generic =>
+ Res := (Kind => VhpiGenericDeclK,
+ Ctxt => Ctxt,
+ Obj => To_Ghdl_Rtin_Object_Acc (Rti));
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ Atype : Ghdl_Rtin_Subtype_Array_Acc;
+ Bt : Ghdl_Rtin_Type_Array_Acc;
+ begin
+ Atype := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Bt := Atype.Basetype;
+ if Atype.Name = Bt.Name then
+ Res := (Kind => VhpiArrayTypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ else
+ Res := (Kind => VhpiSubtypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ end if;
+ end;
+ when Ghdl_Rtik_Type_Array =>
+ Res := (Kind => VhpiArrayTypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32 =>
+ Res := (Kind => VhpiEnumTypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ when Ghdl_Rtik_Type_P32
+ | Ghdl_Rtik_Type_P64 =>
+ Res := (Kind => VhpiPhysTypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Res := (Kind => VhpiSubtypeDeclK,
+ Ctxt => Ctxt,
+ Atype => Rti);
+ when others =>
+ Res := (Kind => VhpiUndefined,
+ Ctxt => Ctxt);
+ end case;
+ end Rti_To_Handle;
+
+ procedure Vhpi_Scan_Decls (Iterator : in out VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+ Ch : Ghdl_Rti_Access;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
+
+ -- If there is no context, returns now.
+ -- This may happen for a unbound compinststmt.
+ if Blk = null then
+ Error := AvhpiErrorIteratorEnd;
+ return;
+ end if;
+
+ if Iterator.It2 = 1 then
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Architecture =>
+ -- Iterate on the entity.
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ when Ghdl_Rtik_Package_Body =>
+ -- Iterate on the package.
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ when Ghdl_Rtik_Package =>
+ -- Only for std.standard.
+ Iterator.It2 := 0;
+ when others =>
+ Internal_Error ("vhpi_scan_decls");
+ end case;
+ end if;
+ loop
+ loop
+ exit when Iterator.It_Cur >= Blk.Nbr_Child;
+
+ Ch := Blk.Children (Iterator.It_Cur);
+
+ Iterator.It_Cur := Iterator.It_Cur + 1;
+
+ case Ch.Kind is
+ when Ghdl_Rtik_Port
+ | Ghdl_Rtik_Generic
+ | Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Type_Array
+ | Ghdl_Rtik_Subtype_Array
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32
+ | Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Subtype_Scalar =>
+ Rti_To_Handle (Ch, Iterator.Ctxt, Res);
+ if Res.Kind /= VhpiUndefined then
+ Error := AvhpiErrorOk;
+ return;
+ else
+ Internal_Error ("vhpi_scan_decls");
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ case Iterator.It2 is
+ when 1 =>
+ -- Iterate on the architecture/package decl.
+ Iterator.It2 := 0;
+ Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
+ Iterator.It_Cur := 0;
+ when others =>
+ exit;
+ end case;
+ end loop;
+ Error := AvhpiErrorIteratorEnd;
+ end Vhpi_Scan_Decls;
+
+ procedure Vhpi_Scan (Iterator : in out VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ if Iterator.Kind = AvhpiNameIteratorK then
+ case Iterator.N_Type.Kind is
+ when Ghdl_Rtik_Subtype_Array =>
+ Vhpi_Scan_Indexed_Name (Iterator, Res, Error);
+ when others =>
+ Error := AvhpiErrorHandle;
+ Res := Null_Handle;
+ end case;
+ return;
+ elsif Iterator.Kind /= VhpiIteratorK then
+ Error := AvhpiErrorHandle;
+ Res := Null_Handle;
+ return;
+ end if;
+
+ case Iterator.Rel is
+ when VhpiPackInsts =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block);
+ if Iterator.It_Cur >= Blk.Nbr_Child then
+ Error := AvhpiErrorIteratorEnd;
+ return;
+ end if;
+ Res := (Kind => VhpiPackInstK,
+ Ctxt => (Base => Null_Address,
+ Block => Blk.Children (Iterator.It_Cur)));
+ Iterator.It_Cur := Iterator.It_Cur + 1;
+ Error := AvhpiErrorOk;
+ end;
+ when VhpiInternalRegions =>
+ Vhpi_Scan_Internal_Regions (Iterator, Res, Error);
+ when VhpiDecls =>
+ Vhpi_Scan_Decls (Iterator, Res, Error);
+ when others =>
+ Res := Null_Handle;
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ end Vhpi_Scan;
+
+ function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String
+ is
+ begin
+ case Obj.Kind is
+ when VhpiEnumTypeDeclK =>
+ return To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name;
+ when VhpiPackInstK
+ | VhpiArchBodyK
+ | VhpiEntityDeclK
+ | VhpiProcessStmtK
+ | VhpiBlockStmtK
+ | VhpiIfGenerateK
+ | VhpiForGenerateK =>
+ return To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name;
+ when VhpiRootInstK =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block);
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ return Blk.Name;
+ end;
+ when VhpiCompInstStmtK =>
+ return Obj.Inst.Name;
+ when VhpiSigDeclK
+ | VhpiPortDeclK
+ | VhpiGenericDeclK =>
+ return Obj.Obj.Name;
+ when VhpiSubtypeDeclK =>
+ return To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name;
+ when others =>
+ return null;
+ end case;
+ end Avhpi_Get_Base_Name;
+
+ procedure Vhpi_Get_Str (Property : VhpiStrPropertyT;
+ Obj : VhpiHandleT;
+ Res : out String;
+ Len : out Natural)
+ is
+ subtype R_Type is String (1 .. Res'Length);
+ R : R_Type renames Res;
+
+ procedure Add (C : Character) is
+ begin
+ Len := Len + 1;
+ if Len <= R_Type'Last then
+ R (Len) := C;
+ end if;
+ end Add;
+
+ procedure Add (Str : String) is
+ begin
+ for I in Str'Range loop
+ Add (Str (I));
+ end loop;
+ end Add;
+
+ procedure Add (Str : Ghdl_C_String) is
+ begin
+ for I in Str'Range loop
+ exit when Str (I) = NUL;
+ Add (Str (I));
+ end loop;
+ end Add;
+ begin
+ Len := 0;
+
+ case Property is
+ when VhpiNameP =>
+ case Obj.Kind is
+ when VhpiEnumTypeDeclK =>
+ Add (To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name);
+ when VhpiSubtypeDeclK =>
+ Add (To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name);
+ when VhpiArrayTypeDeclK =>
+ Add (To_Ghdl_Rtin_Type_Array_Acc (Obj.Atype).Name);
+ when VhpiPackInstK
+ | VhpiArchBodyK
+ | VhpiEntityDeclK
+ | VhpiProcessStmtK
+ | VhpiBlockStmtK
+ | VhpiIfGenerateK =>
+ Add (To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name);
+ when VhpiRootInstK =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block);
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ Add (Blk.Name);
+ end;
+ when VhpiCompInstStmtK =>
+ Add (Obj.Inst.Name);
+ when VhpiSigDeclK
+ | VhpiPortDeclK
+ | VhpiGenericDeclK =>
+ Add (Obj.Obj.Name);
+ when VhpiForGenerateK =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ Iter : Ghdl_Rtin_Object_Acc;
+ Iter_Type : Ghdl_Rti_Access;
+ Vptr : Ghdl_Value_Ptr;
+ Buf : String (1 .. 12);
+ Buf_Len : Natural;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block);
+ Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
+ Vptr := To_Ghdl_Value_Ptr
+ (Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Obj.Ctxt));
+ Add (Blk.Name);
+ Add ('(');
+ Iter_Type := Iter.Obj_Type;
+ if Iter_Type.Kind = Ghdl_Rtik_Subtype_Scalar then
+ Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc
+ (Iter_Type).Basetype;
+ end if;
+ case Iter_Type.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ To_String (Buf, Buf_Len, Vptr.I32);
+ Add (Buf (Buf_Len .. Buf'Last));
+-- when Ghdl_Rtik_Type_E8 =>
+-- Disp_Enum_Value
+-- (Stream, Rti, Ghdl_Index_Type (Vptr.E8));
+-- when Ghdl_Rtik_Type_E32 =>
+-- Disp_Enum_Value
+-- (Stream, Rti, Ghdl_Index_Type (Vptr.E32));
+-- when Ghdl_Rtik_Type_B1 =>
+-- Disp_Enum_Value
+-- (Stream, Rti,
+-- Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1)));
+ when others =>
+ Add ('?');
+ end case;
+ --Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False);
+ Add (')');
+ end;
+ when others =>
+ null;
+ end case;
+ when VhpiCompNameP =>
+ case Obj.Kind is
+ when VhpiCompInstStmtK =>
+ declare
+ Comp : Ghdl_Rtin_Component_Acc;
+ begin
+ Comp := To_Ghdl_Rtin_Component_Acc (Obj.Inst.Instance);
+ if Comp.Common.Kind = Ghdl_Rtik_Component then
+ Add (Comp.Name);
+ end if;
+ end;
+ when others =>
+ null;
+ end case;
+ when VhpiLibLogicalNameP =>
+ case Obj.Kind is
+ when VhpiPackInstK
+ | VhpiArchBodyK
+ | VhpiEntityDeclK =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ Lib : Ghdl_Rtin_Type_Scalar_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block);
+ if Blk.Common.Kind = Ghdl_Rtik_Package_Body then
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ end if;
+ Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent);
+ if Lib.Common.Kind /= Ghdl_Rtik_Library then
+ Internal_Error ("VhpiLibLogicalNameP");
+ end if;
+ Add (Lib.Name);
+ end;
+ when others =>
+ null;
+ end case;
+ when VhpiFullNameP =>
+ declare
+ Rstr : Rstring;
+ Nctxt : Rti_Context;
+ begin
+ if Obj.Kind = VhpiCompInstStmtK then
+ Get_Instance_Context (Obj.Inst, Obj.Ctxt, Nctxt);
+ Get_Path_Name (Rstr, Nctxt, ':', False);
+ else
+ Get_Path_Name (Rstr, Obj.Ctxt, ':', False);
+ end if;
+ Copy (Rstr, R, Len);
+ Free (Rstr);
+ case Obj.Kind is
+ when VhpiCompInstStmtK =>
+ null;
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ Add (':');
+ Add (Obj.Obj.Name);
+ when others =>
+ null;
+ end case;
+ end;
+ when others =>
+ null;
+ end case;
+ end Vhpi_Get_Str;
+
+ procedure Vhpi_Handle (Rel : VhpiOneToOneT;
+ Ref : VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ -- Default error.
+ Error := AvhpiErrorNotImplemented;
+
+ case Rel is
+ when VhpiDesignUnit =>
+ case Ref.Kind is
+ when VhpiRootInstK =>
+ case Ref.Ctxt.Block.Kind is
+ when Ghdl_Rtik_Architecture =>
+ Res := (Kind => VhpiArchBodyK,
+ Ctxt => Ref.Ctxt);
+ Error := AvhpiErrorOk;
+ return;
+ when others =>
+ return;
+ end case;
+ when others =>
+ return;
+ end case;
+ when VhpiPrimaryUnit =>
+ case Ref.Kind is
+ when VhpiArchBodyK =>
+ declare
+ Rti : Ghdl_Rti_Access;
+ Ent : Ghdl_Rtin_Block_Acc;
+ begin
+ Rti := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block).Parent;
+ Ent := To_Ghdl_Rtin_Block_Acc (Rti);
+ Res := (Kind => VhpiEntityDeclK,
+ Ctxt => (Base => Ref.Ctxt.Base + Ent.Loc,
+ Block => Rti));
+ Error := AvhpiErrorOk;
+ end;
+ when others =>
+ return;
+ end case;
+ when VhpiIterScheme =>
+ case Ref.Kind is
+ when VhpiForGenerateK =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ Iter : Ghdl_Rtin_Object_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block);
+ Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
+ Res := (Kind => VhpiConstDeclK,
+ Ctxt => Ref.Ctxt,
+ Obj => Iter);
+ Error := AvhpiErrorOk;
+ end;
+ when others =>
+ return;
+ end case;
+ when VhpiSubtype =>
+ case Ref.Kind is
+ when VhpiPortDeclK
+ | VhpiSigDeclK
+ | VhpiGenericDeclK
+ | VhpiConstDeclK =>
+ Res := (Kind => VhpiSubtypeIndicK,
+ Ctxt => Ref.Ctxt,
+ Atype => Ref.Obj.Obj_Type);
+ Error := AvhpiErrorOk;
+ when others =>
+ return;
+ end case;
+ when VhpiTypeMark =>
+ case Ref.Kind is
+ when VhpiSubtypeIndicK =>
+ -- FIXME: if the subtype is anonymous, return the base type.
+ Rti_To_Handle (Ref.Atype, Ref.Ctxt, Res);
+ if Res.Kind /= VhpiUndefined then
+ Error := AvhpiErrorOk;
+ end if;
+ return;
+ when others =>
+ return;
+ end case;
+ when VhpiBaseType =>
+ declare
+ Atype : Ghdl_Rti_Access;
+ begin
+ case Ref.Kind is
+ when VhpiSubtypeIndicK
+ | VhpiSubtypeDeclK
+ | VhpiArrayTypeDeclK =>
+ Atype := Ref.Atype;
+ when VhpiGenericDeclK =>
+ Atype := Ref.Obj.Obj_Type;
+ when VhpiIndexedNameK =>
+ Atype := Ref.N_Type;
+ when others =>
+ return;
+ end case;
+ case Atype.Kind is
+ when Ghdl_Rtik_Subtype_Array =>
+ Rti_To_Handle
+ (To_Ghdl_Rti_Access (To_Ghdl_Rtin_Subtype_Array_Acc
+ (Atype).Basetype),
+ Ref.Ctxt, Res);
+ if Res.Kind /= VhpiUndefined then
+ Error := AvhpiErrorOk;
+ end if;
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Rti_To_Handle
+ (To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype,
+ Ref.Ctxt, Res);
+ if Res.Kind /= VhpiUndefined then
+ Error := AvhpiErrorOk;
+ end if;
+ when Ghdl_Rtik_Type_Array =>
+ Res := Ref;
+ Error := AvhpiErrorOk;
+ when others =>
+ return;
+ end case;
+ end;
+ when VhpiElemSubtype =>
+ declare
+ Base_Type : Ghdl_Rtin_Type_Array_Acc;
+ begin
+ case Ref.Atype.Kind is
+ when Ghdl_Rtik_Subtype_Array =>
+ Base_Type :=
+ To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype).Basetype;
+ when Ghdl_Rtik_Type_Array =>
+ Base_Type := To_Ghdl_Rtin_Type_Array_Acc (Ref.Atype);
+ when others =>
+ return;
+ end case;
+ Rti_To_Handle (Base_Type.Element, Ref.Ctxt, Res);
+ if Res.Kind /= VhpiUndefined then
+ Error := AvhpiErrorOk;
+ end if;
+ end;
+ when others =>
+ Res := Null_Handle;
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ end Vhpi_Handle;
+
+ procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT;
+ Ref : VhpiHandleT;
+ Index : Natural;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ -- Default error.
+ Error := AvhpiErrorNotImplemented;
+
+ case Rel is
+ when VhpiConstraints =>
+ case Ref.Kind is
+ when VhpiSubtypeIndicK =>
+ if Ref.Atype.Kind = Ghdl_Rtik_Subtype_Array then
+ declare
+ Arr_Subtype : constant Ghdl_Rtin_Subtype_Array_Acc :=
+ To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype);
+ Basetype : constant Ghdl_Rtin_Type_Array_Acc :=
+ Arr_Subtype.Basetype;
+ Idx : constant Ghdl_Index_Type :=
+ Ghdl_Index_Type (Index);
+ Bounds : Ghdl_Range_Array (0 .. Basetype.Nbr_Dim - 1);
+ Range_Basetype : Ghdl_Rti_Access;
+ begin
+ if Idx not in 1 .. Basetype.Nbr_Dim then
+ Res := Null_Handle;
+ Error := AvhpiErrorBadIndex;
+ return;
+ end if;
+ -- constraint type is basetype.indexes (idx - 1)
+ Bound_To_Range
+ (Loc_To_Addr (Arr_Subtype.Common.Depth,
+ Arr_Subtype.Bounds, Ref.Ctxt),
+ Basetype, Bounds);
+ Res := (Kind => VhpiIntRangeK,
+ Ctxt => Ref.Ctxt,
+ Rng_Type => Basetype.Indexes (Idx - 1),
+ Rng_Addr => Bounds (Idx - 1));
+ Range_Basetype := Get_Base_Type (Res.Rng_Type);
+ case Range_Basetype.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ null;
+ when Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32 =>
+ Res := (Kind => VhpiEnumRangeK,
+ Ctxt => Ref.Ctxt,
+ Rng_Type => Res.Rng_Type,
+ Rng_Addr => Res.Rng_Addr);
+ when others =>
+ Internal_Error
+ ("vhpi_handle_by_index/constraint");
+ end case;
+ Error := AvhpiErrorOk;
+ end;
+ end if;
+ when others =>
+ return;
+ end case;
+ when VhpiIndexedNames =>
+ declare
+ Base_Type, El_Type : VhpiHandleT;
+ begin
+ Vhpi_Handle (VhpiBaseType, Ref, Base_Type, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ if Vhpi_Get_Kind (Base_Type) /= VhpiArrayTypeDeclK then
+ Error := AvhpiErrorBadRel;
+ return;
+ end if;
+ Vhpi_Handle (VhpiElemSubtype, Base_Type, El_Type, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ Res := (Kind => VhpiIndexedNameK,
+ Ctxt => Ref.Ctxt,
+ N_Addr => Avhpi_Get_Address (Ref),
+ N_Type => El_Type.Atype,
+ N_Idx => Ghdl_Index_Type (Index),
+ N_Obj => Ref.Obj);
+ if Res.N_Addr = Null_Address then
+ Error := AvhpiErrorBadRel;
+ return;
+ end if;
+ Res.N_Addr := Add_Index
+ (Res.Ctxt, Res.N_Addr, Res.N_Obj, Res.N_Type,
+ Ghdl_Index_Type (Index));
+ end;
+ when others =>
+ Res := Null_Handle;
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ end Vhpi_Handle_By_Index;
+
+ procedure Vhpi_Get (Property : VhpiIntPropertyT;
+ Obj : VhpiHandleT;
+ Res : out VhpiIntT;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ case Property is
+ when VhpiLeftBoundP =>
+ if Obj.Kind /= VhpiIntRangeK then
+ Res := 0;
+ Error := AvhpiErrorBadRel;
+ return;
+ end if;
+ Error := AvhpiErrorOk;
+ case Get_Base_Type (Obj.Rng_Type).Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Res := Obj.Rng_Addr.I32.Left;
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ return;
+ when VhpiRightBoundP =>
+ if Obj.Kind /= VhpiIntRangeK then
+ Error := AvhpiErrorBadRel;
+ return;
+ end if;
+ Error := AvhpiErrorOk;
+ case Get_Base_Type (Obj.Rng_Type).Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Res := Obj.Rng_Addr.I32.Right;
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ return;
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ end Vhpi_Get;
+
+ procedure Vhpi_Get (Property : VhpiIntPropertyT;
+ Obj : VhpiHandleT;
+ Res : out Boolean;
+ Error : out AvhpiErrorT)
+ is
+ begin
+ case Property is
+ when VhpiIsUpP =>
+ if Obj.Kind /= VhpiIntRangeK then
+ Res := False;
+ Error := AvhpiErrorBadRel;
+ return;
+ end if;
+ Error := AvhpiErrorOk;
+ case Get_Base_Type (Obj.Rng_Type).Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Res := Obj.Rng_Addr.I32.Dir = Dir_To;
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ return;
+ when others =>
+ Error := AvhpiErrorNotImplemented;
+ end case;
+ end Vhpi_Get;
+
+ function Vhpi_Get_EntityClass (Obj : VhpiHandleT)
+ return VhpiEntityClassT
+ is
+ begin
+ case Obj.Kind is
+ when VhpiArchBodyK =>
+ return VhpiArchitectureEC;
+ when others =>
+ return VhpiErrorEC;
+ end case;
+ end Vhpi_Get_EntityClass;
+
+ function Vhpi_Get_Kind (Obj : VhpiHandleT) return VhpiClassKindT is
+ begin
+ return Obj.Kind;
+ end Vhpi_Get_Kind;
+
+ function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT is
+ begin
+ case Obj.Kind is
+ when VhpiPortDeclK =>
+ case Obj.Obj.Common.Mode and Ghdl_Rti_Signal_Mode_Mask is
+ when Ghdl_Rti_Signal_Mode_In =>
+ return VhpiInMode;
+ when Ghdl_Rti_Signal_Mode_Out =>
+ return VhpiOutMode;
+ when Ghdl_Rti_Signal_Mode_Inout =>
+ return VhpiInoutMode;
+ when Ghdl_Rti_Signal_Mode_Buffer =>
+ return VhpiBufferMode;
+ when Ghdl_Rti_Signal_Mode_Linkage =>
+ return VhpiLinkageMode;
+ when others =>
+ return VhpiErrorMode;
+ end case;
+ when others =>
+ return VhpiErrorMode;
+ end case;
+ end Vhpi_Get_Mode;
+
+ function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access is
+ begin
+ case Obj.Kind is
+ when VhpiSubtypeIndicK
+ | VhpiEnumTypeDeclK =>
+ return Obj.Atype;
+ when VhpiSigDeclK
+ | VhpiPortDeclK =>
+ return To_Ghdl_Rti_Access (Obj.Obj);
+ when others =>
+ return null;
+ end case;
+ end Avhpi_Get_Rti;
+
+ function Avhpi_Get_Address (Obj : VhpiHandleT) return Address is
+ begin
+ case Obj.Kind is
+ when VhpiPortDeclK
+ | VhpiSigDeclK
+ | VhpiGenericDeclK
+ | VhpiConstDeclK =>
+ return Loc_To_Addr (Obj.Ctxt.Block.Depth,
+ Obj.Obj.Loc,
+ Obj.Ctxt);
+ when others =>
+ return Null_Address;
+ end case;
+ end Avhpi_Get_Address;
+
+ function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context is
+ begin
+ return Obj.Ctxt;
+ end Avhpi_Get_Context;
+
+ function Vhpi_Compare_Handles (Hdl1, Hdl2 : VhpiHandleT)
+ return Boolean
+ is
+ begin
+ if Hdl1.Kind /= Hdl2.Kind then
+ return False;
+ end if;
+ case Hdl1.Kind is
+ when VhpiSubtypeIndicK
+ | VhpiSubtypeDeclK
+ | VhpiArrayTypeDeclK
+ | VhpiPhysTypeDeclK =>
+ return Hdl1.Atype = Hdl2.Atype;
+ when others =>
+ -- FIXME: todo
+ Internal_Error ("vhpi_compare_handles");
+ end case;
+ end Vhpi_Compare_Handles;
+
+ function Vhpi_Put_Value (Obj : VhpiHandleT; Val : Ghdl_I64)
+ return AvhpiErrorT
+ is
+ Vptr : Ghdl_Value_Ptr;
+ Atype : Ghdl_Rti_Access;
+ begin
+ case Obj.Kind is
+ when VhpiIndexedNameK =>
+ Vptr := To_Ghdl_Value_Ptr (Obj.N_Addr);
+ Atype := Obj.N_Type;
+ when others =>
+ return AvhpiErrorNotImplemented;
+ end case;
+ case Get_Base_Type (Atype).Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ null;
+ when others =>
+ return AvhpiErrorHandle;
+ end case;
+ Vptr.I64 := Val;
+ return AvhpiErrorOk;
+ end Vhpi_Put_Value;
+end Grt.Avhpi;
+
+
diff --git a/src/translate/grt/grt-avhpi.ads b/src/translate/grt/grt-avhpi.ads
new file mode 100644
index 000000000..1eff5a8a3
--- /dev/null
+++ b/src/translate/grt/grt-avhpi.ads
@@ -0,0 +1,561 @@
+-- GHDL Run Time (GRT) - VHPI implementation for Ada.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+-- Ada oriented implementation of VHPI.
+-- This doesn't follow exactly what VHPI defined, but:
+-- * it should be easy to write a VHPI interface from this implementation.
+-- * this implementation is thread-safe (no global storage).
+-- * this implementation never allocates memory.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+
+package Grt.Avhpi is
+ -- Object Kinds.
+ type VhpiClassKindT is
+ (
+ VhpiUndefined,
+ VhpiAccessTypeDeclK,
+ VhpiAggregateK,
+ VhpiAliasDeclK,
+ VhpiAllLiteralK,
+ VhpiAllocatorK,
+ VhpiAnyCollectionK,
+ VhpiArchBodyK,
+ VhpiArgvK,
+ VhpiArrayTypeDeclK,
+ VhpiAssertStmtK,
+ VhpiAssocElemK,
+ VhpiAttrDeclK,
+ VhpiAttrSpecK,
+ VhpiBinaryExprK,
+ VhpiBitStringLiteralK,
+ VhpiBlockConfigK,
+ VhpiBlockStmtK,
+ VhpiBranchK,
+ VhpiCallbackK,
+ VhpiCaseStmtK,
+ VhpiCharLiteralK,
+ VhpiCompConfigK,
+ VhpiCompDeclK,
+ VhpiCompInstStmtK,
+ VhpiCondSigAssignStmtK,
+ VhpiCondWaveformK,
+ VhpiConfigDeclK,
+ VhpiConstDeclK,
+ VhpiConstParamDeclK,
+ VhpiConvFuncK,
+ VhpiDeRefObjK,
+ VhpiDisconnectSpecK,
+ VhpiDriverK,
+ VhpiDriverCollectionK,
+ VhpiElemAssocK,
+ VhpiElemDeclK,
+ VhpiEntityClassEntryK,
+ VhpiEntityDeclK,
+ VhpiEnumLiteralK,
+ VhpiEnumRangeK,
+ VhpiEnumTypeDeclK,
+ VhpiExitStmtK,
+ VhpiFileDeclK,
+ VhpiFileParamDeclK,
+ VhpiFileTypeDeclK,
+ VhpiFloatRangeK,
+ VhpiFloatTypeDeclK,
+ VhpiForGenerateK,
+ VhpiForLoopK,
+ VhpiForeignfK,
+ VhpiFuncCallK,
+ VhpiFuncDeclK,
+ VhpiGenericDeclK,
+ VhpiGroupDeclK,
+ VhpiGroupTempDeclK,
+ VhpiIfGenerateK,
+ VhpiIfStmtK,
+ VhpiInPortK,
+ VhpiIndexedNameK,
+ VhpiIntLiteralK,
+ VhpiIntRangeK,
+ VhpiIntTypeDeclK,
+ VhpiIteratorK,
+ VhpiLibraryDeclK,
+ VhpiLoopStmtK,
+ VhpiNextStmtK,
+ VhpiNullLiteralK,
+ VhpiNullStmtK,
+ VhpiOperatorK,
+ VhpiOthersLiteralK,
+ VhpiOutPortK,
+ VhpiPackBodyK,
+ VhpiPackDeclK,
+ VhpiPackInstK,
+ VhpiParamAttrNameK,
+ VhpiPhysLiteralK,
+ VhpiPhysRangeK,
+ VhpiPhysTypeDeclK,
+ VhpiPortDeclK,
+ VhpiProcCallStmtK,
+ VhpiProcDeclK,
+ VhpiProcessStmtK,
+ VhpiProtectedTypeK,
+ VhpiProtectedTypeBodyK,
+ VhpiProtectedTypeDeclK,
+ VhpiRealLiteralK,
+ VhpiRecordTypeDeclK,
+ VhpiReportStmtK,
+ VhpiReturnStmtK,
+ VhpiRootInstK,
+ VhpiSelectSigAssignStmtK,
+ VhpiSelectWaveformK,
+ VhpiSelectedNameK,
+ VhpiSigDeclK,
+ VhpiSigParamDeclK,
+ VhpiSimpAttrNameK,
+ VhpiSimpleSigAssignStmtK,
+ VhpiSliceNameK,
+ VhpiStringLiteralK,
+ VhpiSubpBodyK,
+ VhpiSubtypeDeclK,
+ VhpiSubtypeIndicK,
+ VhpiToolK,
+ VhpiTransactionK,
+ VhpiTypeConvK,
+ VhpiUnaryExprK,
+ VhpiUnitDeclK,
+ VhpiUserAttrNameK,
+ VhpiVarAssignStmtK,
+ VhpiVarDeclK,
+ VhpiVarParamDeclK,
+ VhpiWaitStmtK,
+ VhpiWaveformElemK,
+ VhpiWhileLoopK,
+
+ -- Iterator, but on a name.
+ AvhpiNameIteratorK
+ );
+
+ type VhpiOneToOneT is
+ (
+ VhpiAbstractLiteral,
+ VhpiActual,
+ VhpiAllLiteral,
+ VhpiAttrDecl,
+ VhpiAttrSpec,
+ VhpiBaseType,
+ VhpiBaseUnit,
+ VhpiBasicSignal,
+ VhpiBlockConfig,
+ VhpiCaseExpr,
+ VhpiCondExpr,
+ VhpiConfigDecl,
+ VhpiConfigSpec,
+ VhpiConstraint,
+ VhpiContributor,
+ VhpiCurCallback,
+ VhpiCurEqProcess,
+ VhpiCurStackFrame,
+ VhpiDeRefObj,
+ VhpiDecl,
+ VhpiDesignUnit,
+ VhpiDownStack,
+ VhpiElemSubtype,
+ VhpiEntityAspect,
+ VhpiEntityDecl,
+ VhpiEqProcessStmt,
+ VhpiExpr,
+ VhpiFormal,
+ VhpiFuncDecl,
+ VhpiGroupTempDecl,
+ VhpiGuardExpr,
+ VhpiGuardSig,
+ VhpiImmRegion,
+ VhpiInPort,
+ VhpiInitExpr,
+ VhpiIterScheme,
+ VhpiLeftExpr,
+ VhpiLexicalScope,
+ VhpiLhsExpr,
+ VhpiLocal,
+ VhpiLogicalExpr,
+ VhpiName,
+ VhpiOperator,
+ VhpiOthersLiteral,
+ VhpiOutPort,
+ VhpiParamDecl,
+ VhpiParamExpr,
+ VhpiParent,
+ VhpiPhysLiteral,
+ VhpiPrefix,
+ VhpiPrimaryUnit,
+ VhpiProtectedTypeBody,
+ VhpiProtectedTypeDecl,
+ VhpiRejectTime,
+ VhpiReportExpr,
+ VhpiResolFunc,
+ VhpiReturnExpr,
+ VhpiReturnTypeMark,
+ VhpiRhsExpr,
+ VhpiRightExpr,
+ VhpiRootInst,
+ VhpiSelectExpr,
+ VhpiSeverityExpr,
+ VhpiSimpleName,
+ VhpiSubpBody,
+ VhpiSubpDecl,
+ VhpiSubtype,
+ VhpiSuffix,
+ VhpiTimeExpr,
+ VhpiTimeOutExpr,
+ VhpiTool,
+ VhpiTypeMark,
+ VhpiUnitDecl,
+ VhpiUpStack,
+ VhpiUpperRegion,
+ VhpiValExpr,
+ VhpiValSubtype
+ );
+
+ -- Methods used to traverse 1 to many relationships.
+ type VhpiOneToManyT is
+ (
+ VhpiAliasDecls,
+ VhpiArgvs,
+ VhpiAttrDecls,
+ VhpiAttrSpecs,
+ VhpiBasicSignals,
+ VhpiBlockStmts,
+ VhpiBranchs,
+ VhpiCallbacks,
+ VhpiChoices,
+ VhpiCompInstStmts,
+ VhpiCondExprs,
+ VhpiCondWaveforms,
+ VhpiConfigItems,
+ VhpiConfigSpecs,
+ VhpiConstDecls,
+ VhpiConstraints,
+ VhpiContributors,
+ VhpiCurRegions,
+ VhpiDecls,
+ VhpiDepUnits,
+ VhpiDesignUnits,
+ VhpiDrivenSigs,
+ VhpiDrivers,
+ VhpiElemAssocs,
+ VhpiEntityClassEntrys,
+ VhpiEntityDesignators,
+ VhpiEnumLiterals,
+ VhpiForeignfs,
+ VhpiGenericAssocs,
+ VhpiGenericDecls,
+ VhpiIndexExprs,
+ VhpiIndexedNames,
+ VhpiInternalRegions,
+ VhpiMembers,
+ VhpiPackInsts,
+ VhpiParamAssocs,
+ VhpiParamDecls,
+ VhpiPortAssocs,
+ VhpiPortDecls,
+ VhpiRecordElems,
+ VhpiSelectWaveforms,
+ VhpiSelectedNames,
+ VhpiSensitivitys,
+ VhpiSeqStmts,
+ VhpiSigAttrs,
+ VhpiSigDecls,
+ VhpiSigNames,
+ VhpiSignals,
+ VhpiSpecNames,
+ VhpiSpecs,
+ VhpiStmts,
+ VhpiTransactions,
+ VhpiTypeMarks,
+ VhpiUnitDecls,
+ VhpiUses,
+ VhpiVarDecls,
+ VhpiWaveformElems,
+ VhpiLibraryDecls
+ );
+
+ type VhpiIntPropertyT is
+ (
+ VhpiAccessP,
+ VhpiArgcP,
+ VhpiAttrKindP,
+ VhpiBaseIndexP,
+ VhpiBeginLineNoP,
+ VhpiEndLineNoP,
+ VhpiEntityClassP,
+ VhpiForeignKindP,
+ VhpiFrameLevelP,
+ VhpiGenerateIndexP,
+ VhpiIntValP,
+ VhpiIsAnonymousP,
+ VhpiIsBasicP,
+ VhpiIsCompositeP,
+ VhpiIsDefaultP,
+ VhpiIsDeferredP,
+ VhpiIsDiscreteP,
+ VhpiIsForcedP,
+ VhpiIsForeignP,
+ VhpiIsGuardedP,
+ VhpiIsImplicitDeclP,
+ VhpiIsInvalidP_DEPRECATED,
+ VhpiIsLocalP,
+ VhpiIsNamedP,
+ VhpiIsNullP,
+ VhpiIsOpenP,
+ VhpiIsPLIP,
+ VhpiIsPassiveP,
+ VhpiIsPostponedP,
+ VhpiIsProtectedTypeP,
+ VhpiIsPureP,
+ VhpiIsResolvedP,
+ VhpiIsScalarP,
+ VhpiIsSeqStmtP,
+ VhpiIsSharedP,
+ VhpiIsTransportP,
+ VhpiIsUnaffectedP,
+ VhpiIsUnconstrainedP,
+ VhpiIsUninstantiatedP,
+ VhpiIsUpP,
+ VhpiIsVitalP,
+ VhpiIteratorTypeP,
+ VhpiKindP,
+ VhpiLeftBoundP,
+ VhpiLevelP_DEPRECATED,
+ VhpiLineNoP,
+ VhpiLineOffsetP,
+ VhpiLoopIndexP,
+ VhpiModeP,
+ VhpiNumDimensionsP,
+ VhpiNumFieldsP_DEPRECATED,
+ VhpiNumGensP,
+ VhpiNumLiteralsP,
+ VhpiNumMembersP,
+ VhpiNumParamsP,
+ VhpiNumPortsP,
+ VhpiOpenModeP,
+ VhpiPhaseP,
+ VhpiPositionP,
+ VhpiPredefAttrP,
+ VhpiReasonP,
+ VhpiRightBoundP,
+ VhpiSigKindP,
+ VhpiSizeP,
+ VhpiStartLineNoP,
+ VhpiStateP,
+ VhpiStaticnessP,
+ VhpiVHDLversionP,
+ VhpiIdP,
+ VhpiCapabilitiesP
+ );
+
+ -- String properties.
+ type VhpiStrPropertyT is
+ (
+ VhpiCaseNameP,
+ VhpiCompNameP,
+ VhpiDefNameP,
+ VhpiFileNameP,
+ VhpiFullCaseNameP,
+ VhpiFullNameP,
+ VhpiKindStrP,
+ VhpiLabelNameP,
+ VhpiLibLogicalNameP,
+ VhpiLibPhysicalNameP,
+ VhpiLogicalNameP,
+ VhpiLoopLabelNameP,
+ VhpiNameP,
+ VhpiOpNameP,
+ VhpiStrValP,
+ VhpiToolVersionP,
+ VhpiUnitNameP
+ );
+
+ -- Possible Errors.
+ type AvhpiErrorT is
+ (
+ AvhpiErrorOk,
+ AvhpiErrorBadRel,
+ AvhpiErrorHandle,
+ AvhpiErrorNotImplemented,
+ AvhpiErrorIteratorEnd,
+ AvhpiErrorBadIndex
+ );
+
+ type VhpiHandleT is private;
+
+ -- A null handle.
+ Null_Handle : constant VhpiHandleT;
+
+ -- Get the root instance.
+ procedure Get_Root_Inst (Res : out VhpiHandleT);
+
+ -- Get the instanciated packages.
+ procedure Get_Package_Inst (Res : out VhpiHandleT);
+
+ procedure Vhpi_Handle (Rel : VhpiOneToOneT;
+ Ref : VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT);
+
+ procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT;
+ Ref : VhpiHandleT;
+ Index : Natural;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT);
+
+ procedure Vhpi_Iterator (Rel : VhpiOneToManyT;
+ Ref : VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT);
+ procedure Vhpi_Scan (Iterator : in out VhpiHandleT;
+ Res : out VhpiHandleT;
+ Error : out AvhpiErrorT);
+
+ procedure Vhpi_Get_Str (Property : VhpiStrPropertyT;
+ Obj : VhpiHandleT;
+ Res : out String;
+ Len : out Natural);
+
+ subtype VhpiIntT is Ghdl_I32;
+
+ procedure Vhpi_Get (Property : VhpiIntPropertyT;
+ Obj : VhpiHandleT;
+ Res : out VhpiIntT;
+ Error : out AvhpiErrorT);
+ procedure Vhpi_Get (Property : VhpiIntPropertyT;
+ Obj : VhpiHandleT;
+ Res : out Boolean;
+ Error : out AvhpiErrorT);
+
+ -- Almost the same as Vhpi_Get_Str (VhpiName, OBJ), but there is not
+ -- indexes for generate stmt.
+ function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String;
+
+ -- Return TRUE iff HDL1 and HDL2 are equivalent.
+ function Vhpi_Compare_Handles (Hdl1, Hdl2 : VhpiHandleT)
+ return Boolean;
+
+-- procedure Vhpi_Handle_By_Simple_Name (Ref : VhpiHandleT;
+-- Res : out VhpiHandleT;
+-- Error : out AvhpiErrorT);
+
+ type VhpiEntityClassT is
+ (
+ VhpiErrorEC,
+ VhpiEntityEC,
+ VhpiArchitectureEC,
+ VhpiConfigurationEC,
+ VhpiProcedureEC,
+ VhpiFunctionEC,
+ VhpiPackageEC,
+ VhpiTypeEC,
+ VhpiSubtypeEC,
+ VhpiConstantEC,
+ VhpiSignalEC,
+ VhpiVariableEC,
+ VhpiComponentEC,
+ VhpiLabelEC,
+ VhpiLiteralEC,
+ VhpiUnitsEC,
+ VhpiFileEC,
+ VhpiGroupEC
+ );
+
+ function Vhpi_Get_EntityClass (Obj : VhpiHandleT)
+ return VhpiEntityClassT;
+
+ type VhpiModeT is
+ (
+ VhpiErrorMode,
+ VhpiInMode,
+ VhpiOutMode,
+ VhpiInoutMode,
+ VhpiBufferMode,
+ VhpiLinkageMode
+ );
+ function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT;
+
+ function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access;
+
+ function Avhpi_Get_Address (Obj : VhpiHandleT) return Address;
+
+ function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context;
+
+ function Vhpi_Get_Kind (Obj : VhpiHandleT) return VhpiClassKindT;
+
+ function Vhpi_Put_Value (Obj : VhpiHandleT; Val : Ghdl_I64)
+ return AvhpiErrorT;
+private
+ type VhpiHandleT (Kind : VhpiClassKindT := VhpiUndefined) is record
+ -- Context.
+ Ctxt : Rti_Context;
+
+ case Kind is
+ when VhpiIteratorK =>
+ Rel : VhpiOneToManyT;
+ It_Cur : Ghdl_Index_Type;
+ It2 : Ghdl_Index_Type;
+ Max2 : Ghdl_Index_Type;
+ when AvhpiNameIteratorK
+ | VhpiIndexedNameK =>
+ N_Addr : Address;
+ N_Type : Ghdl_Rti_Access;
+ N_Idx : Ghdl_Index_Type;
+ N_Obj : Ghdl_Rtin_Object_Acc;
+ when VhpiSigDeclK
+ | VhpiPortDeclK
+ | VhpiGenericDeclK
+ | VhpiConstDeclK =>
+ Obj : Ghdl_Rtin_Object_Acc;
+ when VhpiSubtypeIndicK
+ | VhpiSubtypeDeclK
+ | VhpiArrayTypeDeclK
+ | VhpiEnumTypeDeclK
+ | VhpiPhysTypeDeclK =>
+ Atype : Ghdl_Rti_Access;
+ when VhpiCompInstStmtK =>
+ Inst : Ghdl_Rtin_Instance_Acc;
+ when VhpiIntRangeK
+ | VhpiEnumRangeK
+ | VhpiFloatRangeK
+ | VhpiPhysRangeK =>
+ Rng_Type : Ghdl_Rti_Access;
+ Rng_Addr : Ghdl_Range_Ptr;
+ when others =>
+ null;
+ end case;
+ -- Current Object.
+ --Obj : Ghdl_Rti_Access;
+ end record;
+
+ Null_Handle : constant VhpiHandleT := (Kind => VhpiUndefined,
+ Ctxt => (Base => Null_Address,
+ Block => null));
+end Grt.Avhpi;
diff --git a/src/translate/grt/grt-avls.adb b/src/translate/grt/grt-avls.adb
new file mode 100644
index 000000000..7f13ed39a
--- /dev/null
+++ b/src/translate/grt/grt-avls.adb
@@ -0,0 +1,249 @@
+-- GHDL Run Time (GRT) - binary balanced tree.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Avls is
+ function Get_Height (Tree: AVL_Tree; N : AVL_Nid) return Ghdl_I32 is
+ begin
+ if N = AVL_Nil then
+ return 0;
+ else
+ return Tree (N).Height;
+ end if;
+ end Get_Height;
+
+ procedure Check_AVL (Tree : AVL_Tree; N : AVL_Nid)
+ is
+ L, R : AVL_Nid;
+ Lh, Rh : Ghdl_I32;
+ H : Ghdl_I32;
+ begin
+ if N = AVL_Nil then
+ return;
+ end if;
+ L := Tree (N).Left;
+ R := Tree (N).Right;
+ H := Get_Height (Tree, N);
+ if L = AVL_Nil and R = AVL_Nil then
+ if Get_Height (Tree, N) /= 1 then
+ Internal_Error ("check_AVL(1)");
+ end if;
+ return;
+ elsif L = AVL_Nil then
+ Check_AVL (Tree, R);
+ if H /= Get_Height (Tree, R) + 1 or H > 2 then
+ Internal_Error ("check_AVL(2)");
+ end if;
+ elsif R = AVL_Nil then
+ Check_AVL (Tree, L);
+ if H /= Get_Height (Tree, L) + 1 or H > 2 then
+ Internal_Error ("check_AVL(3)");
+ end if;
+ else
+ Check_AVL (Tree, L);
+ Check_AVL (Tree, R);
+ Lh := Get_Height (Tree, L);
+ Rh := Get_Height (Tree, R);
+ if Ghdl_I32'Max (Lh, Rh) + 1 /= H then
+ Internal_Error ("check_AVL(4)");
+ end if;
+ if Rh - Lh > 1 or Rh - Lh < -1 then
+ Internal_Error ("check_AVL(5)");
+ end if;
+ end if;
+ end Check_AVL;
+
+ procedure Compute_Height (Tree : in out AVL_Tree; N : AVL_Nid)
+ is
+ begin
+ Tree (N).Height :=
+ Ghdl_I32'Max (Get_Height (Tree, Tree (N).Left),
+ Get_Height (Tree, Tree (N).Right)) + 1;
+ end Compute_Height;
+
+ procedure Simple_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid)
+ is
+ R : AVL_Nid;
+ V : AVL_Value;
+ begin
+ -- Rotate nodes.
+ R := Tree (N).Right;
+ Tree (N).Right := Tree (R).Right;
+ Tree (R).Right := Tree (R).Left;
+ Tree (R).Left := Tree (N).Left;
+ Tree (N).Left := R;
+ -- Swap vals.
+ V := Tree (N).Val;
+ Tree (N).Val := Tree (R).Val;
+ Tree (R).Val := V;
+ -- Adjust bal.
+ Compute_Height (Tree, R);
+ Compute_Height (Tree, N);
+ end Simple_Rotate_Right;
+
+ procedure Simple_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid)
+ is
+ L : AVL_Nid;
+ V : AVL_Value;
+ begin
+ L := Tree (N).Left;
+ Tree (N).Left := Tree (L).Left;
+ Tree (L).Left := Tree (L).Right;
+ Tree (L).Right := Tree (N).Right;
+ Tree (N).Right := L;
+ V := Tree (N).Val;
+ Tree (N).Val := Tree (L).Val;
+ Tree (L).Val := V;
+ Compute_Height (Tree, L);
+ Compute_Height (Tree, N);
+ end Simple_Rotate_Left;
+
+ procedure Double_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid)
+ is
+ R : AVL_Nid;
+ begin
+ R := Tree (N).Right;
+ Simple_Rotate_Left (Tree, R);
+ Simple_Rotate_Right (Tree, N);
+ end Double_Rotate_Right;
+
+ procedure Double_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid)
+ is
+ L : AVL_Nid;
+ begin
+ L := Tree (N).Left;
+ Simple_Rotate_Right (Tree, L);
+ Simple_Rotate_Left (Tree, N);
+ end Double_Rotate_Left;
+
+ procedure Insert (Tree : in out AVL_Tree;
+ Cmp : AVL_Compare_Func;
+ Val : AVL_Nid;
+ N : AVL_Nid;
+ Res : out AVL_Nid)
+ is
+ Diff : Integer;
+ Op_Ch, Ch : AVL_Nid;
+ begin
+ Diff := Cmp.all (Tree (Val).Val, Tree (N).Val);
+ if Diff = 0 then
+ Res := N;
+ return;
+ end if;
+ if Diff < 0 then
+ if Tree (N).Left = AVL_Nil then
+ Tree (N).Left := Val;
+ Compute_Height (Tree, N);
+ -- N is balanced.
+ Res := Val;
+ else
+ Ch := Tree (N).Left;
+ Op_Ch := Tree (N).Right;
+ Insert (Tree, Cmp, Val, Ch, Res);
+ if Res /= Val then
+ return;
+ end if;
+ if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then
+ -- Rotate
+ if Get_Height (Tree, Tree (Ch).Left)
+ > Get_Height (Tree, Tree (Ch).Right)
+ then
+ Simple_Rotate_Left (Tree, N);
+ else
+ Double_Rotate_Left (Tree, N);
+ end if;
+ else
+ Compute_Height (Tree, N);
+ end if;
+ end if;
+ else
+ if Tree (N).Right = AVL_Nil then
+ Tree (N).Right := Val;
+ Compute_Height (Tree, N);
+ -- N is balanced.
+ Res := Val;
+ else
+ Ch := Tree (N).Right;
+ Op_Ch := Tree (N).Left;
+ Insert (Tree, Cmp, Val, Ch, Res);
+ if Res /= Val then
+ return;
+ end if;
+ if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then
+ -- Rotate
+ if Get_Height (Tree, Tree (Ch).Right)
+ > Get_Height (Tree, Tree (Ch).Left)
+ then
+ Simple_Rotate_Right (Tree, N);
+ else
+ Double_Rotate_Right (Tree, N);
+ end if;
+ else
+ Compute_Height (Tree, N);
+ end if;
+ end if;
+ end if;
+ end Insert;
+
+ procedure Get_Node (Tree : in out AVL_Tree;
+ Cmp : AVL_Compare_Func;
+ N : AVL_Nid;
+ Res : out AVL_Nid)
+ is
+ begin
+ if Tree'First /= AVL_Root or N /= Tree'Last then
+ Internal_Error ("avls.get_node");
+ end if;
+ Insert (Tree, Cmp, N, AVL_Root, Res);
+ Check_AVL (Tree, AVL_Root);
+ end Get_Node;
+
+ function Find_Node (Tree : AVL_Tree;
+ Cmp : AVL_Compare_Func;
+ Val : AVL_Value) return AVL_Nid
+ is
+ N : AVL_Nid;
+ Diff : Integer;
+ begin
+ N := AVL_Root;
+ if Tree'Last < AVL_Root then
+ return AVL_Nil;
+ end if;
+ loop
+ Diff := Cmp.all (Val, Tree (N).Val);
+ if Diff = 0 then
+ return N;
+ end if;
+ if Diff < 0 then
+ N := Tree (N).Left;
+ else
+ N := Tree (N).Right;
+ end if;
+ if N = AVL_Nil then
+ return AVL_Nil;
+ end if;
+ end loop;
+ end Find_Node;
+end Grt.Avls;
diff --git a/src/translate/grt/grt-avls.ads b/src/translate/grt/grt-avls.ads
new file mode 100644
index 000000000..790053c6f
--- /dev/null
+++ b/src/translate/grt/grt-avls.ads
@@ -0,0 +1,84 @@
+-- GHDL Run Time (GRT) - binary balanced tree.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+
+package Grt.Avls is
+ -- Implementation of a binary balanced tree.
+ -- This package is very generic, and provides only the algorithm.
+ -- The user must provide the storage of the tree.
+ -- The basic types of this implementation ares:
+ -- * AVL_Value: the value stored in the tree. This is an integer on 32
+ -- bits. However, they may either really represent integers or an index
+ -- into another table. To compare two values, a user function is always
+ -- provided.
+ -- * AVL_Nid: a node id or an index into the tree.
+ -- * AVL_Node: a node, indexed by AVL_Nid.
+ -- * AVL_Tree: an array of AVL_Node, indexed by AVL_Nid. This represents
+ -- the tree. The root of the tree is always AVL_Root, which is the
+ -- first element of the array.
+ --
+ -- As a choice, this package never allocate nodes. So, to insert a value
+ -- in the tree, the user must allocate an (empty) node, set the value of
+ -- the node and try to insert this node into the tree. If the value is
+ -- already in the tree, Get_Node will returns the node id which contains
+ -- the value. Otherwise, Get_Node returns the node just created by the
+ -- user.
+
+ -- The value in an AVL tree.
+ -- This is fixed.
+ type AVL_Value is new Ghdl_I32;
+
+ -- An AVL node id.
+ type AVL_Nid is new Ghdl_I32;
+ AVL_Nil : constant AVL_Nid := 0;
+ AVL_Root : constant AVL_Nid := 1;
+
+ type AVL_Node is record
+ Val : AVL_Value;
+ Left : AVL_Nid;
+ Right : AVL_Nid;
+ Height : Ghdl_I32;
+ end record;
+
+ type AVL_Tree is array (AVL_Nid range <>) of AVL_Node;
+
+ -- Compare two values.
+ -- Returns < 0 if L < R, 0 if L = R, > 0 if L > R.
+ type AVL_Compare_Func is access function (L, R : AVL_Value) return Integer;
+
+ -- Try to insert node N into TREE.
+ -- Returns either N or the node id of a node containing already the value.
+ procedure Get_Node (Tree : in out AVL_Tree;
+ Cmp : AVL_Compare_Func;
+ N : AVL_Nid;
+ Res : out AVL_Nid);
+
+ function Find_Node (Tree : AVL_Tree;
+ Cmp : AVL_Compare_Func;
+ Val : AVL_Value) return AVL_Nid;
+
+end Grt.Avls;
+
+
diff --git a/src/translate/grt/grt-c.ads b/src/translate/grt/grt-c.ads
new file mode 100644
index 000000000..24003cf4a
--- /dev/null
+++ b/src/translate/grt/grt-c.ads
@@ -0,0 +1,54 @@
+-- GHDL Run Time (GRT) - C interface.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+-- This package declares C types.
+-- It is a really stripped down version of interfaces.C!
+with System;
+
+package Grt.C is
+ pragma Preelaborate (Grt.C);
+
+ -- Type void * and char *.
+ subtype voids is System.Address;
+ subtype chars is System.Address;
+ subtype long is Long_Integer;
+
+ -- Type size_t.
+ type size_t is mod 2 ** Standard'Address_Size;
+
+ -- Type int. It is an alias on Integer for simplicity.
+ subtype int is Integer;
+
+ -- Low level memory management.
+ procedure Free (Addr : System.Address);
+ function Malloc (Size : size_t) return System.Address;
+ function Realloc (Ptr : System.Address; Size : size_t)
+ return System.Address;
+
+private
+ pragma Import (C, Free);
+ pragma Import (C, Malloc);
+ pragma Import (C, Realloc);
+end Grt.C;
diff --git a/src/translate/grt/grt-cbinding.c b/src/translate/grt/grt-cbinding.c
new file mode 100644
index 000000000..b95c0f0a9
--- /dev/null
+++ b/src/translate/grt/grt-cbinding.c
@@ -0,0 +1,99 @@
+/* GRT C bindings.
+ Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold.
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+#include
+#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
new file mode 100644
index 000000000..51edd678f
--- /dev/null
+++ b/src/translate/grt/grt-cvpi.c
@@ -0,0 +1,277 @@
+/* GRT VPI C helpers.
+ Copyright (C) 2003, 2004, 2005 Tristan Gingold & Felix Bertram
+
+ GHDL is free software; you can redistribute it and/or modify it under
+ the terms of the GNU General Public License as published by the Free
+ Software Foundation; either version 2, or (at your option) any later
+ version.
+
+ GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with GCC; see the file COPYING. If not, write to the Free
+ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+ 02111-1307, USA.
+*/
+//-----------------------------------------------------------------------------
+// Description: VPI interface for GRT runtime, "C" helpers
+// the main purpose of this code is to interface with the
+// Icarus Verilog Interactive (IVI) simulator GUI
+//-----------------------------------------------------------------------------
+
+#include
+#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
new file mode 100644
index 000000000..e68b1168b
--- /dev/null
+++ b/src/translate/grt/grt-disp.adb
@@ -0,0 +1,227 @@
+-- GHDL Run Time (GRT) - Common display subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Stdio; use Grt.Stdio;
+--with Grt.Errors; use Grt.Errors;
+
+package body Grt.Disp is
+
+-- procedure Put_Trim (Stream : FILEs; Str : String)
+-- is
+-- Start : Natural;
+-- begin
+-- Start := Str'First;
+-- while Start <= Str'Last and then Str (Start) = ' ' loop
+-- Start := Start + 1;
+-- end loop;
+-- Put (Stream, Str (Start .. Str'Last));
+-- end Put_Trim;
+
+-- procedure Put_E8 (Stream : FILEs; E8 : Ghdl_E8; Type_Desc : Ghdl_Desc_Ptr)
+-- is
+-- begin
+-- Put_Str_Len (Stream, Type_Desc.E8.Values (Natural (E8)));
+-- end Put_E8;
+
+ --procedure Put_E32
+ -- (Stream : FILEs; E32 : Ghdl_E32; Type_Desc : Ghdl_Desc_Ptr)
+ --is
+ --begin
+ -- Put_Str_Len (Stream, Type_Desc.E32.Values (Natural (E32)));
+ --end Put_E32;
+
+ procedure Put_Sig_Index (Sig : Sig_Table_Index)
+ is
+ begin
+ Put_I32 (stdout, Ghdl_I32 (Sig));
+ end Put_Sig_Index;
+
+ procedure Put_Sig_Range (Sig : Sig_Table_Range)
+ is
+ begin
+ Put_Sig_Index (Sig.First);
+ if Sig.Last /= Sig.First then
+ Put ("-");
+ Put_Sig_Index (Sig.Last);
+ end if;
+ end Put_Sig_Range;
+
+ procedure Disp_Now
+ is
+ begin
+ Put ("Now is ");
+ Put_Time (stdout, Current_Time);
+ Put (" +");
+ Put_I32 (stdout, Ghdl_I32 (Current_Delta));
+ New_Line;
+ end Disp_Now;
+
+ procedure Disp_Propagation_Kind (Kind : Propagation_Kind_Type)
+ is
+ begin
+ case Kind is
+ when Drv_One_Driver =>
+ Put ("Drv (1 drv) ");
+ when Eff_One_Driver =>
+ Put ("Eff (1 drv) ");
+ when Drv_One_Port =>
+ Put ("Drv (1 prt) ");
+ when Eff_One_Port =>
+ Put ("Eff (1 prt) ");
+ when Imp_Forward =>
+ Put ("Forward ");
+ when Imp_Forward_Build =>
+ Put ("Forward_Build ");
+ when Imp_Guard =>
+ Put ("Guard ");
+ when Imp_Stable =>
+ Put ("Stable ");
+ when Imp_Quiet =>
+ Put ("Quiet ");
+ when Imp_Transaction =>
+ Put ("Transaction ");
+ when Imp_Delayed =>
+ Put ("Delayed ");
+ when Eff_Actual =>
+ Put ("Eff Actual ");
+ when Eff_Multiple =>
+ Put ("Eff multiple ");
+ when Drv_One_Resolved =>
+ Put ("Drv 1 resolved ");
+ when Eff_One_Resolved =>
+ Put ("Eff 1 resolved ");
+ when In_Conversion =>
+ Put ("In conv ");
+ when Out_Conversion =>
+ Put ("Out conv ");
+ when Drv_Error =>
+ Put ("Drv error ");
+ when Drv_Multiple =>
+ Put ("Drv multiple ");
+ when Prop_End =>
+ Put ("end ");
+ end case;
+ end Disp_Propagation_Kind;
+
+ procedure Disp_Signals_Order is
+ begin
+ for I in Propagation.First .. Propagation.Last loop
+ Put_I32 (stdout, Ghdl_I32 (I));
+ Put (": ");
+ Disp_Propagation_Kind (Propagation.Table (I).Kind);
+ case Propagation.Table (I).Kind is
+ when Drv_One_Driver
+ | Eff_One_Driver
+ | Drv_One_Port
+ | Eff_One_Port
+ | Drv_One_Resolved
+ | Eff_One_Resolved
+ | Imp_Guard
+ | Imp_Stable
+ | Imp_Quiet
+ | Imp_Transaction
+ | Imp_Delayed
+ | Eff_Actual =>
+ Put_Sig_Index (Signal_Ptr_To_Index (Propagation.Table (I).Sig));
+ New_Line;
+ when Imp_Forward =>
+ Put_I32 (stdout, Ghdl_I32 (Propagation.Table (I).Sig.Net));
+ New_Line;
+ when Imp_Forward_Build =>
+ declare
+ Forward : Forward_Build_Acc;
+ begin
+ Forward := Propagation.Table (I).Forward;
+ Put_Sig_Index (Signal_Ptr_To_Index (Forward.Src));
+ Put (" -> ");
+ Put_Sig_Index (Signal_Ptr_To_Index (Forward.Targ));
+ New_Line;
+ end;
+ when Eff_Multiple
+ | Drv_Multiple =>
+ Put_Sig_Range (Propagation.Table (I).Resolv.Sig_Range);
+ New_Line;
+ when In_Conversion
+ | Out_Conversion =>
+ declare
+ Conv : Sig_Conversion_Acc;
+ begin
+ Conv := Propagation.Table (I).Conv;
+ Put_Sig_Range (Conv.Src);
+ Put (" -> ");
+ Put_Sig_Range (Conv.Dest);
+ New_Line;
+ end;
+ when Prop_End =>
+ New_Line;
+ when Drv_Error =>
+ null;
+ end case;
+ end loop;
+ end Disp_Signals_Order;
+
+ procedure Disp_Mode (Mode : Mode_Type)
+ is
+ begin
+ case Mode is
+ when Mode_B1 =>
+ Put (" b1");
+ when Mode_E8 =>
+ Put (" e8");
+ when Mode_E32 =>
+ Put ("e32");
+ when Mode_I32 =>
+ Put ("i32");
+ when Mode_I64 =>
+ Put ("i64");
+ when Mode_F64 =>
+ Put ("f64");
+ end case;
+ end Disp_Mode;
+
+ procedure Disp_Value (Value : Value_Union; Mode : Mode_Type) is
+ begin
+ case Mode is
+ when Mode_B1 =>
+ if Value.B1 then
+ Put ("T");
+ else
+ Put ("F");
+ end if;
+ when Mode_E8 =>
+ Put_I32 (stdout, Ghdl_I32 (Value.E8));
+ when Mode_E32 =>
+ Put_I32 (stdout, Ghdl_I32 (Value.E32));
+ when Mode_I32 =>
+ Put_I32 (stdout, Value.I32);
+ when Mode_I64 =>
+ Put_I64 (stdout, Value.I64);
+ when Mode_F64 =>
+ Put_F64 (stdout, Value.F64);
+ end case;
+ end Disp_Value;
+end Grt.Disp;
diff --git a/src/translate/grt/grt-disp.ads b/src/translate/grt/grt-disp.ads
new file mode 100644
index 000000000..6c15b37c9
--- /dev/null
+++ b/src/translate/grt/grt-disp.ads
@@ -0,0 +1,46 @@
+-- GHDL Run Time (GRT) - Common display subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Signals; use Grt.Signals;
+with Grt.Types; use Grt.Types;
+
+package Grt.Disp is
+ -- Display SIG number.
+ procedure Put_Sig_Index (Sig : Sig_Table_Index);
+
+ -- Disp current time and current delta.
+ procedure Disp_Now;
+
+ procedure Disp_Propagation_Kind (Kind : Propagation_Kind_Type);
+
+ -- Disp signals propagation order.
+ procedure Disp_Signals_Order;
+
+ -- Disp mode.
+ procedure Disp_Mode (Mode : Mode_Type);
+
+ -- Disp value (numeric).
+ procedure Disp_Value (Value : Value_Union; Mode : Mode_Type);
+
+end Grt.Disp;
diff --git a/src/translate/grt/grt-disp_rti.adb b/src/translate/grt/grt-disp_rti.adb
new file mode 100644
index 000000000..08d27dacb
--- /dev/null
+++ b/src/translate/grt/grt-disp_rti.adb
@@ -0,0 +1,1080 @@
+-- GHDL Run Time (GRT) - RTI dumper.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Errors; use Grt.Errors;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+
+package body Grt.Disp_Rti is
+ procedure Disp_Kind (Kind : Ghdl_Rtik);
+
+ procedure Disp_Name (Name : Ghdl_C_String) is
+ begin
+ if Name = null then
+ Put (stdout, "");
+ else
+ Put (stdout, Name);
+ end if;
+ end Disp_Name;
+
+ -- Disp value stored at ADDR and whose type is described by RTI.
+ procedure Disp_Enum_Value
+ (Stream : FILEs; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type)
+ is
+ Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+ begin
+ Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Put (Stream, Enum_Rti.Names (Val));
+ end Disp_Enum_Value;
+
+ procedure Disp_Scalar_Value
+ (Stream : FILEs;
+ Rti : Ghdl_Rti_Access;
+ Addr : in out Address;
+ Is_Sig : Boolean)
+ is
+ procedure Update (S : Ghdl_Index_Type) is
+ begin
+ Addr := Addr + (S / Storage_Unit);
+ end Update;
+
+ Vptr : Ghdl_Value_Ptr;
+ begin
+ if Is_Sig then
+ Vptr := To_Ghdl_Value_Ptr (To_Addr_Acc (Addr).all);
+ Update (Address'Size);
+ else
+ Vptr := To_Ghdl_Value_Ptr (Addr);
+ end if;
+
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Put_I32 (Stream, Vptr.I32);
+ if not Is_Sig then
+ Update (32);
+ end if;
+ when Ghdl_Rtik_Type_E8 =>
+ Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E8));
+ if not Is_Sig then
+ Update (8);
+ end if;
+ when Ghdl_Rtik_Type_E32 =>
+ Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E32));
+ if not Is_Sig then
+ Update (32);
+ end if;
+ when Ghdl_Rtik_Type_B1 =>
+ Disp_Enum_Value (Stream, Rti,
+ Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1)));
+ if not Is_Sig then
+ Update (8);
+ end if;
+ when Ghdl_Rtik_Type_F64 =>
+ Put_F64 (Stream, Vptr.F64);
+ if not Is_Sig then
+ Update (64);
+ end if;
+ when Ghdl_Rtik_Type_P64 =>
+ Put_I64 (Stream, Vptr.I64);
+ Put (Stream, " ");
+ Put (Stream,
+ Get_Physical_Unit_Name
+ (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0)));
+ if not Is_Sig then
+ Update (64);
+ end if;
+ when Ghdl_Rtik_Type_P32 =>
+ Put_I32 (Stream, Vptr.I32);
+ Put (Stream, " ");
+ Put (Stream,
+ Get_Physical_Unit_Name
+ (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0)));
+ if not Is_Sig then
+ Update (32);
+ end if;
+ when others =>
+ Internal_Error ("disp_rti.disp_scalar_value");
+ end case;
+ end Disp_Scalar_Value;
+
+-- function Get_Scalar_Type_Kind (Rti : Ghdl_Rti_Access) return Ghdl_Rtik
+-- is
+-- Ndef : Ghdl_Rti_Access;
+-- begin
+-- if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then
+-- Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype;
+-- else
+-- Ndef := Rti;
+-- end if;
+-- case Ndef.Kind is
+-- when Ghdl_Rtik_Type_I32 =>
+-- return Ndef.Kind;
+-- when others =>
+-- return Ghdl_Rtik_Error;
+-- end case;
+-- end Get_Scalar_Type_Kind;
+
+ procedure Disp_Array_Value_1 (Stream : FILEs;
+ El_Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Rngs : Ghdl_Range_Array;
+ Rtis : Ghdl_Rti_Arr_Acc;
+ Index : Ghdl_Index_Type;
+ Obj : in out Address;
+ Is_Sig : Boolean)
+ is
+ Length : Ghdl_Index_Type;
+ begin
+ Length := Range_To_Length (Rngs (Index), Get_Base_Type (Rtis (Index)));
+ Put (Stream, "(");
+ for I in 1 .. Length loop
+ if I /= 1 then
+ Put (Stream, ", ");
+ end if;
+ if Index = Rngs'Last then
+ Disp_Value (Stream, El_Rti, Ctxt, Obj, Is_Sig);
+ else
+ Disp_Array_Value_1
+ (Stream, El_Rti, Ctxt, Rngs, Rtis, Index + 1, Obj, Is_Sig);
+ end if;
+ end loop;
+ Put (Stream, ")");
+ end Disp_Array_Value_1;
+
+ procedure Disp_Array_Value (Stream : FILEs;
+ Rti : Ghdl_Rtin_Type_Array_Acc;
+ Ctxt : Rti_Context;
+ Vals : Ghdl_Uc_Array_Acc;
+ Is_Sig : Boolean)
+ is
+ Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim;
+ Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1);
+ Obj : Address;
+ begin
+ Bound_To_Range (Vals.Bounds, Rti, Rngs);
+ Obj := Vals.Base;
+ Disp_Array_Value_1
+ (Stream, Rti.Element, Ctxt, Rngs, Rti.Indexes, 0, Obj, Is_Sig);
+ end Disp_Array_Value;
+
+ procedure Disp_Record_Value (Stream : FILEs;
+ Rti : Ghdl_Rtin_Type_Record_Acc;
+ Ctxt : Rti_Context;
+ Obj : Address;
+ Is_Sig : Boolean)
+ is
+ El : Ghdl_Rtin_Element_Acc;
+ El_Addr : Address;
+ begin
+ Put (Stream, "(");
+ for I in 1 .. Rti.Nbrel loop
+ El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1));
+ if I /= 1 then
+ Put (", ");
+ end if;
+ Put (Stream, El.Name);
+ Put (" => ");
+ if Is_Sig then
+ El_Addr := Obj + El.Sig_Off;
+ else
+ El_Addr := Obj + El.Val_Off;
+ end if;
+ if Rti_Complex_Type (El.Eltype) then
+ El_Addr := Obj + To_Ghdl_Index_Acc (El_Addr).all;
+ end if;
+ Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Is_Sig);
+ end loop;
+ Put (")");
+ -- FIXME: update ADDR.
+ end Disp_Record_Value;
+
+ procedure Disp_Value
+ (Stream : FILEs;
+ Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Obj : in out Address;
+ Is_Sig : Boolean)
+ is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Disp_Scalar_Value
+ (Stream, To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype,
+ Obj, Is_Sig);
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32
+ | Ghdl_Rtik_Type_B1 =>
+ Disp_Scalar_Value (Stream, Rti, Obj, Is_Sig);
+ when Ghdl_Rtik_Type_Array =>
+ Disp_Array_Value (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt,
+ To_Ghdl_Uc_Array_Acc (Obj), Is_Sig);
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ St : constant Ghdl_Rtin_Subtype_Array_Acc :=
+ To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype;
+ Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
+ B : Address;
+ begin
+ Bound_To_Range
+ (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs);
+ B := Obj;
+ Disp_Array_Value_1
+ (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig);
+ end;
+ when Ghdl_Rtik_Type_File =>
+ declare
+ Vptr : Ghdl_Value_Ptr;
+ begin
+ Vptr := To_Ghdl_Value_Ptr (Obj);
+ Put (Stream, "File#");
+ Put_I32 (Stream, Vptr.I32);
+ -- FIXME: update OBJ (not very useful since never in a
+ -- composite type).
+ end;
+ when Ghdl_Rtik_Type_Record =>
+ Disp_Record_Value
+ (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Is_Sig);
+ when Ghdl_Rtik_Type_Protected =>
+ Put (Stream, "Unhandled protected type");
+ when others =>
+ Put (Stream, "Unknown Rti Kind : ");
+ Disp_Kind(Rti.Kind);
+ end case;
+ -- Put_Line(":");
+ end Disp_Value;
+
+ procedure Disp_Kind (Kind : Ghdl_Rtik) is
+ begin
+ case Kind is
+ when Ghdl_Rtik_Top =>
+ Put ("ghdl_rtik_top");
+ when Ghdl_Rtik_Package =>
+ Put ("ghdl_rtik_package");
+ when Ghdl_Rtik_Package_Body =>
+ Put ("ghdl_rtik_package_body");
+ when Ghdl_Rtik_Entity =>
+ Put ("ghdl_rtik_entity");
+ when Ghdl_Rtik_Architecture =>
+ Put ("ghdl_rtik_architecture");
+
+ when Ghdl_Rtik_Port =>
+ Put ("ghdl_rtik_port");
+ when Ghdl_Rtik_Generic =>
+ Put ("ghdl_rtik_generic");
+ when Ghdl_Rtik_Process =>
+ Put ("ghdl_rtik_process");
+ when Ghdl_Rtik_Component =>
+ Put ("ghdl_rtik_component");
+ when Ghdl_Rtik_Attribute =>
+ Put ("ghdl_rtik_attribute");
+
+ when Ghdl_Rtik_Attribute_Quiet =>
+ Put ("ghdl_rtik_attribute_quiet");
+ when Ghdl_Rtik_Attribute_Stable =>
+ Put ("ghdl_rtik_attribute_stable");
+ when Ghdl_Rtik_Attribute_Transaction =>
+ Put ("ghdl_rtik_attribute_transaction");
+
+ when Ghdl_Rtik_Constant =>
+ Put ("ghdl_rtik_constant");
+ when Ghdl_Rtik_Iterator =>
+ Put ("ghdl_rtik_iterator");
+ when Ghdl_Rtik_Signal =>
+ Put ("ghdl_rtik_signal");
+ when Ghdl_Rtik_Variable =>
+ Put ("ghdl_rtik_variable");
+ when Ghdl_Rtik_Guard =>
+ Put ("ghdl_rtik_guard");
+ when Ghdl_Rtik_File =>
+ Put ("ghdl_rtik_file");
+
+ when Ghdl_Rtik_Instance =>
+ Put ("ghdl_rtik_instance");
+ when Ghdl_Rtik_Block =>
+ Put ("ghdl_rtik_block");
+ when Ghdl_Rtik_If_Generate =>
+ Put ("ghdl_rtik_if_generate");
+ when Ghdl_Rtik_For_Generate =>
+ Put ("ghdl_rtik_for_generate");
+
+ when Ghdl_Rtik_Type_B1 =>
+ Put ("ghdl_rtik_type_b1");
+ when Ghdl_Rtik_Type_E8 =>
+ Put ("ghdl_rtik_type_e8");
+ when Ghdl_Rtik_Type_E32 =>
+ Put ("ghdl_rtik_type_e32");
+ when Ghdl_Rtik_Type_P64 =>
+ Put ("ghdl_rtik_type_p64");
+ when Ghdl_Rtik_Type_I32 =>
+ Put ("ghdl_rtik_type_i32");
+
+ when Ghdl_Rtik_Type_Array =>
+ Put ("ghdl_rtik_type_array");
+ when Ghdl_Rtik_Subtype_Array =>
+ Put ("ghdl_rtik_subtype_array");
+ when Ghdl_Rtik_Type_Record =>
+ Put ("ghdl_rtik_type_record");
+
+ when Ghdl_Rtik_Type_Access =>
+ Put ("ghdl_rtik_type_access");
+ when Ghdl_Rtik_Type_File =>
+ Put ("ghdl_rtik_type_file");
+ when Ghdl_Rtik_Type_Protected =>
+ Put ("ghdl_rtik_type_protected");
+
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Put ("ghdl_rtik_subtype_scalar");
+
+ when Ghdl_Rtik_Element =>
+ Put ("ghdl_rtik_element");
+ when Ghdl_Rtik_Unit64 =>
+ Put ("ghdl_rtik_unit64");
+ when Ghdl_Rtik_Unitptr =>
+ Put ("ghdl_rtik_unitptr");
+
+ when others =>
+ Put ("ghdl_rtik_#");
+ Put_I32 (stdout, Ghdl_Rtik'Pos (Kind));
+ end case;
+ end Disp_Kind;
+
+ procedure Disp_Depth (Depth : Ghdl_Rti_Depth) is
+ begin
+ Put (", D=");
+ Put_I32 (stdout, Ghdl_I32 (Depth));
+ end Disp_Depth;
+
+ procedure Disp_Indent (Indent : Natural) is
+ begin
+ for I in 1 .. Indent loop
+ Put (' ');
+ end loop;
+ end Disp_Indent;
+
+ -- Disp a subtype_indication.
+ -- OBJ may be necessary when the subtype is an unconstrained array type,
+ -- whose bounds are stored with the object.
+ procedure Disp_Subtype_Indication
+ (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address);
+
+ procedure Disp_Range
+ (Stream : FILEs; Kind : Ghdl_Rtik; Rng : Ghdl_Range_Ptr)
+ is
+ begin
+ case Kind is
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_P32 =>
+ Put_I32 (Stream, Rng.I32.Left);
+ Put_Dir (Stream, Rng.I32.Dir);
+ Put_I32 (Stream, Rng.I32.Right);
+ when Ghdl_Rtik_Type_F64 =>
+ Put_F64 (Stream, Rng.F64.Left);
+ Put_Dir (Stream, Rng.F64.Dir);
+ Put_F64 (Stream, Rng.F64.Right);
+ when Ghdl_Rtik_Type_P64 =>
+ Put_I64 (Stream, Rng.P64.Left);
+ Put_Dir (Stream, Rng.P64.Dir);
+ Put_I64 (Stream, Rng.P64.Right);
+ when others =>
+ Put ("?Scal");
+ end case;
+ end Disp_Range;
+
+ procedure Disp_Scalar_Type_Name (Def : Ghdl_Rti_Access) is
+ begin
+ case Def.Kind is
+ when Ghdl_Rtik_Subtype_Scalar =>
+ declare
+ Rti : Ghdl_Rtin_Subtype_Scalar_Acc;
+ begin
+ Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def);
+ if Rti.Name /= null then
+ Disp_Name (Rti.Name);
+ else
+ Disp_Scalar_Type_Name (Rti.Basetype);
+ end if;
+ end;
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32 =>
+ Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name);
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_I64 =>
+ Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name);
+ when others =>
+ Put ("#disp_scalar_type_name#");
+ end case;
+ end Disp_Scalar_Type_Name;
+
+ procedure Disp_Type_Array_Name (Def : Ghdl_Rtin_Type_Array_Acc;
+ Bounds_Ptr : Address)
+ is
+ Bounds : Address;
+
+ procedure Align (A : Ghdl_Index_Type) is
+ begin
+ Bounds := Align (Bounds, Ghdl_Rti_Loc (A));
+ end Align;
+
+ procedure Update (S : Ghdl_Index_Type) is
+ begin
+ Bounds := Bounds + (S / Storage_Unit);
+ end Update;
+
+ procedure Disp_Bounds (Def : Ghdl_Rti_Access)
+ is
+ Ndef : Ghdl_Rti_Access;
+ begin
+ if Bounds = Null_Address then
+ Put ("?");
+ else
+ if Def.Kind = Ghdl_Rtik_Subtype_Scalar then
+ Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def).Basetype;
+ else
+ Ndef := Def;
+ end if;
+ case Ndef.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Align (Ghdl_Range_I32'Alignment);
+ Disp_Range (stdout, Ndef.Kind, To_Ghdl_Range_Ptr (Bounds));
+ Update (Ghdl_Range_I32'Size);
+ when others =>
+ Disp_Kind (Ndef.Kind);
+ -- Bounds are not known anymore.
+ Bounds := Null_Address;
+ end case;
+ end if;
+ end Disp_Bounds;
+ begin
+ Disp_Name (Def.Name);
+ if Bounds_Ptr = Null_Address then
+ return;
+ end if;
+ Put (" (");
+ Bounds := Bounds_Ptr;
+ for I in 0 .. Def.Nbr_Dim - 1 loop
+ if I /= 0 then
+ Put (", ");
+ end if;
+ Disp_Scalar_Type_Name (Def.Indexes (I));
+ Put (" range ");
+ Disp_Bounds (Def.Indexes (I));
+ end loop;
+ Put (")");
+ end Disp_Type_Array_Name;
+
+ procedure Disp_Subtype_Scalar_Range
+ (Stream : FILEs; Def : Ghdl_Rtin_Subtype_Scalar_Acc; Ctxt : Rti_Context)
+ is
+ Range_Addr : Address;
+ Rng : Ghdl_Range_Ptr;
+ begin
+ Range_Addr := Loc_To_Addr (Def.Common.Depth,
+ Def.Range_Loc, Ctxt);
+ Rng := To_Ghdl_Range_Ptr (Range_Addr);
+ Disp_Range (Stream, Def.Basetype.Kind, Rng);
+ end Disp_Subtype_Scalar_Range;
+
+ procedure Disp_Subtype_Indication
+ (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address)
+ is
+ begin
+ case Def.Kind is
+ when Ghdl_Rtik_Subtype_Scalar =>
+ declare
+ Rti : Ghdl_Rtin_Subtype_Scalar_Acc;
+ begin
+ Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def);
+ if Rti.Name /= null then
+ Disp_Name (Rti.Name);
+ else
+ Disp_Subtype_Indication
+ (Rti.Basetype, Null_Context, Null_Address);
+ Put (" range ");
+ Disp_Subtype_Scalar_Range (stdout, Rti, Ctxt);
+ end if;
+ end;
+ --Disp_Scalar_Subtype_Name (To_Ghdl_Rtin_Scalsubtype_Acc (Def),
+ -- Base);
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32 =>
+ Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name);
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_I64 =>
+ Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name);
+ when Ghdl_Rtik_Type_File
+ | Ghdl_Rtik_Type_Access =>
+ Disp_Name (To_Ghdl_Rtin_Type_Fileacc_Acc (Def).Name);
+ when Ghdl_Rtik_Type_Record =>
+ Disp_Name (To_Ghdl_Rtin_Type_Record_Acc (Def).Name);
+ when Ghdl_Rtik_Type_Array =>
+ declare
+ Bounds : Address;
+ begin
+ if Obj = Null_Address then
+ Bounds := Null_Address;
+ else
+ Bounds := To_Ghdl_Uc_Array_Acc (Obj).Bounds;
+ end if;
+ Disp_Type_Array_Name (To_Ghdl_Rtin_Type_Array_Acc (Def),
+ Bounds);
+ end;
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ Sdef : Ghdl_Rtin_Subtype_Array_Acc;
+ begin
+ Sdef := To_Ghdl_Rtin_Subtype_Array_Acc (Def);
+ if Sdef.Name /= null then
+ Disp_Name (Sdef.Name);
+ else
+ Disp_Type_Array_Name
+ (Sdef.Basetype,
+ Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt));
+ end if;
+ end;
+ when Ghdl_Rtik_Type_Protected =>
+ Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name);
+ when others =>
+ Disp_Kind (Def.Kind);
+ Put (' ');
+ end case;
+ end Disp_Subtype_Indication;
+
+
+ procedure Disp_Rti (Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Indent : Natural);
+
+ procedure Disp_Rti_Arr (Nbr : Ghdl_Index_Type;
+ Arr : Ghdl_Rti_Arr_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ begin
+ for I in 1 .. Nbr loop
+ Disp_Rti (Arr (I - 1), Ctxt, Indent);
+ end loop;
+ end Disp_Rti_Arr;
+
+ procedure Disp_Block (Blk : Ghdl_Rtin_Block_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ Nctxt : Rti_Context;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Blk.Common.Kind);
+ Disp_Depth (Blk.Common.Depth);
+ Put (": ");
+ Disp_Name (Blk.Name);
+ New_Line;
+ if Blk.Parent /= null then
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Architecture =>
+ -- Disp entity.
+ Disp_Rti (Blk.Parent, Ctxt, Indent + 1);
+ when others =>
+ null;
+ end case;
+ end if;
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Package
+ | Ghdl_Rtik_Package_Body
+ | Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_Process =>
+ Nctxt := (Base => Ctxt.Base + Blk.Loc,
+ Block => To_Ghdl_Rti_Access (Blk));
+ Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children,
+ Nctxt, Indent + 1);
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Length : Ghdl_Index_Type;
+ begin
+ Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all,
+ Block => To_Ghdl_Rti_Access (Blk));
+ Length := Get_For_Generate_Length (Blk, Ctxt);
+ for I in 1 .. Length loop
+ Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children,
+ Nctxt, Indent + 1);
+ Nctxt.Base := Nctxt.Base + Blk.Size;
+ end loop;
+ end;
+ when Ghdl_Rtik_If_Generate =>
+ Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all,
+ Block => To_Ghdl_Rti_Access (Blk));
+ if Nctxt.Base /= Null_Address then
+ Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children,
+ Nctxt, Indent + 1);
+ end if;
+ when others =>
+ Internal_Error ("disp_block");
+ end case;
+ end Disp_Block;
+
+ procedure Disp_Object (Obj : Ghdl_Rtin_Object_Acc;
+ Is_Sig : Boolean;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ Addr : Address;
+ Obj_Type : Ghdl_Rti_Access;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Obj.Common.Kind);
+ Disp_Depth (Obj.Common.Depth);
+ Put ("; ");
+ Disp_Name (Obj.Name);
+ Put (": ");
+ Addr := Loc_To_Addr (Obj.Common.Depth, Obj.Loc, Ctxt);
+ Obj_Type := Obj.Obj_Type;
+ Disp_Subtype_Indication (Obj_Type, Ctxt, Addr);
+ Put (" := ");
+
+ -- FIXME: put this into a function.
+ if (Obj_Type.Kind = Ghdl_Rtik_Subtype_Array
+ or Obj_Type.Kind = Ghdl_Rtik_Type_Record)
+ and then Rti_Complex_Type (Obj_Type)
+ then
+ Addr := To_Addr_Acc (Addr).all;
+ end if;
+ Disp_Value (stdout, Obj_Type, Ctxt, Addr, Is_Sig);
+ New_Line;
+ end Disp_Object;
+
+ procedure Disp_Attribute (Obj : Ghdl_Rtin_Object_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Obj.Common.Kind);
+ Disp_Depth (Obj.Common.Depth);
+ Put ("; ");
+ Disp_Name (Obj.Name);
+ Put (": ");
+ Disp_Subtype_Indication (Obj.Obj_Type, Ctxt, Null_Address);
+ New_Line;
+ end Disp_Attribute;
+
+ procedure Disp_Component (Comp : Ghdl_Rtin_Component_Acc;
+ Indent : Natural)
+ is
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Comp.Common.Kind);
+ Disp_Depth (Comp.Common.Depth);
+ Put (": ");
+ Disp_Name (Comp.Name);
+ New_Line;
+ --Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Base, Ident + 1);
+ end Disp_Component;
+
+ procedure Disp_Instance (Inst : Ghdl_Rtin_Instance_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ Inst_Addr : Address;
+ Inst_Base : Address;
+ Inst_Rti : Ghdl_Rti_Access;
+ Nindent : Natural;
+ Nctxt : Rti_Context;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Inst.Common.Kind);
+ Put (": ");
+ Disp_Name (Inst.Name);
+ New_Line;
+
+ Inst_Addr := Ctxt.Base + Inst.Loc;
+ -- Read sub instance.
+ Inst_Base := To_Addr_Acc (Inst_Addr).all;
+
+ Nindent := Indent + 1;
+
+ case Inst.Instance.Kind is
+ when Ghdl_Rtik_Component =>
+ declare
+ Comp : Ghdl_Rtin_Component_Acc;
+ begin
+ Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance);
+ Disp_Indent (Nindent);
+ Disp_Kind (Comp.Common.Kind);
+ Put (": ");
+ Disp_Name (Comp.Name);
+ New_Line;
+ -- Disp components generics and ports.
+ -- FIXME: the data to disp are at COMP_BASE.
+ Nctxt := (Base => Inst_Addr,
+ Block => Inst.Instance);
+ Nindent := Nindent + 1;
+ Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Nctxt, Nindent);
+ Nindent := Nindent + 1;
+ end;
+ when Ghdl_Rtik_Entity =>
+ null;
+ when others =>
+ null;
+ end case;
+
+ -- Read instance RTI.
+ if Inst_Base /= Null_Address then
+ Inst_Rti := To_Ghdl_Rti_Acc_Acc (Inst_Base).all;
+ Nctxt := (Base => Inst_Base,
+ Block => Inst_Rti);
+ Disp_Block (To_Ghdl_Rtin_Block_Acc (Inst_Rti),
+ Nctxt, Nindent);
+ end if;
+ end Disp_Instance;
+
+ procedure Disp_Type_Enum_Decl (Enum : Ghdl_Rtin_Type_Enum_Acc;
+ Indent : Natural)
+ is
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Enum.Common.Kind);
+ Put (": ");
+ Disp_Name (Enum.Name);
+ Put (" is (");
+ Disp_Name (Enum.Names (0));
+ for I in 1 .. Enum.Nbr - 1 loop
+ Put (", ");
+ Disp_Name (Enum.Names (I));
+ end loop;
+ Put (")");
+ New_Line;
+ end Disp_Type_Enum_Decl;
+
+ procedure Disp_Subtype_Scalar_Decl (Def : Ghdl_Rtin_Subtype_Scalar_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ Bt : Ghdl_Rti_Access;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Disp_Depth (Def.Common.Depth);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is ");
+ Bt := Def.Basetype;
+ case Bt.Kind is
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_F64 =>
+ declare
+ Bdef : Ghdl_Rtin_Type_Scalar_Acc;
+ begin
+ Bdef := To_Ghdl_Rtin_Type_Scalar_Acc (Bt);
+ if Bdef.Name /= Def.Name then
+ Disp_Name (Bdef.Name);
+ Put (" range ");
+ end if;
+ -- This is the type definition.
+ Disp_Subtype_Scalar_Range (stdout, Def, Ctxt);
+ end;
+ when Ghdl_Rtik_Type_P64
+ | Ghdl_Rtik_Type_P32 =>
+ declare
+ Bdef : Ghdl_Rtin_Type_Physical_Acc;
+ Unit : Ghdl_Rti_Access;
+ begin
+ Bdef := To_Ghdl_Rtin_Type_Physical_Acc (Bt);
+ if Bdef.Name /= Def.Name then
+ Disp_Name (Bdef.Name);
+ Put (" range ");
+ end if;
+ -- This is the type definition.
+ Disp_Subtype_Scalar_Range (stdout, Def, Ctxt);
+ if Bdef.Name = Def.Name then
+ for I in 0 .. Bdef.Nbr - 1 loop
+ Unit := Bdef.Units (I);
+ New_Line;
+ Disp_Indent (Indent + 1);
+ Disp_Kind (Unit.Kind);
+ Put (": ");
+ Disp_Name (Get_Physical_Unit_Name (Unit));
+ Put (" = ");
+ case Unit.Kind is
+ when Ghdl_Rtik_Unit64 =>
+ Put_I64 (stdout,
+ To_Ghdl_Rtin_Unit64_Acc (Unit).Value);
+ when Ghdl_Rtik_Unitptr =>
+ case Bt.Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ Put_I64
+ (stdout,
+ To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64);
+ when Ghdl_Rtik_Type_P32 =>
+ Put_I32
+ (stdout,
+ To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32);
+ when others =>
+ Internal_Error
+ ("disp_rti.subtype.scalar_decl(P32/P64)");
+ end case;
+ when others =>
+ Internal_Error
+ ("disp_rti.subtype.scalar_decl(P32/P64)");
+ end case;
+ end loop;
+ end if;
+ end;
+ when others =>
+ Disp_Subtype_Indication
+ (To_Ghdl_Rti_Access (Def), Ctxt, Null_Address);
+ end case;
+ New_Line;
+ end Disp_Subtype_Scalar_Decl;
+
+ procedure Disp_Type_Array_Decl (Def : Ghdl_Rtin_Type_Array_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is array (");
+ for I in 0 .. Def.Nbr_Dim - 1 loop
+ if I /= 0 then
+ Put (", ");
+ end if;
+ Disp_Subtype_Indication (Def.Indexes (I), Ctxt, Null_Address);
+ Put (" range <>");
+ end loop;
+ Put (") of ");
+ Disp_Subtype_Indication (Def.Element, Ctxt, Null_Address);
+ New_Line;
+ end Disp_Type_Array_Decl;
+
+ procedure Disp_Subtype_Array_Decl (Def : Ghdl_Rtin_Subtype_Array_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ Basetype : constant Ghdl_Rtin_Type_Array_Acc := Def.Basetype;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is ");
+ Disp_Type_Array_Name
+ (Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt));
+ if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then
+ Put (" of ");
+ Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address);
+ end if;
+ New_Line;
+ end Disp_Subtype_Array_Decl;
+
+ procedure Disp_Type_File_Or_Access (Def : Ghdl_Rtin_Type_Fileacc_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is ");
+ case Def.Common.Kind is
+ when Ghdl_Rtik_Type_Access =>
+ Put ("access ");
+ when Ghdl_Rtik_Type_File =>
+ Put ("file ");
+ when others =>
+ Put ("?? ");
+ end case;
+ Disp_Subtype_Indication (Def.Base, Ctxt, Null_Address);
+ New_Line;
+ end Disp_Type_File_Or_Access;
+
+ procedure Disp_Type_Record (Def : Ghdl_Rtin_Type_Record_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ El : Ghdl_Rtin_Element_Acc;
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is record");
+ New_Line;
+ for I in 1 .. Def.Nbrel loop
+ El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1));
+ Disp_Indent (Indent + 1);
+ Disp_Kind (El.Common.Kind);
+ Put (": ");
+ Disp_Name (El.Name);
+ Put (": ");
+ Disp_Subtype_Indication (El.Eltype, Ctxt, Null_Address);
+ New_Line;
+ end loop;
+ end Disp_Type_Record;
+
+ procedure Disp_Type_Protected (Def : Ghdl_Rtin_Type_Scalar_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ pragma Unreferenced (Ctxt);
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is protected");
+ New_Line;
+ end Disp_Type_Protected;
+
+ procedure Disp_Rti (Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ begin
+ if Rti = null then
+ return;
+ end if;
+
+ case Rti.Kind is
+ when Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_Package
+ | Ghdl_Rtik_Process
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_If_Generate
+ | Ghdl_Rtik_For_Generate =>
+ Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Package_Body =>
+ Disp_Rti (To_Ghdl_Rtin_Block_Acc (Rti).Parent, Ctxt, Indent);
+ Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Port
+ | Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Attribute_Quiet
+ | Ghdl_Rtik_Attribute_Stable
+ | Ghdl_Rtik_Attribute_Transaction =>
+ Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), True, Ctxt, Indent);
+ when Ghdl_Rtik_Generic
+ | Ghdl_Rtik_Constant
+ | Ghdl_Rtik_Variable
+ | Ghdl_Rtik_Iterator
+ | Ghdl_Rtik_File =>
+ Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), False, Ctxt, Indent);
+ when Ghdl_Rtik_Component =>
+ Disp_Component (To_Ghdl_Rtin_Component_Acc (Rti), Indent);
+ when Ghdl_Rtik_Attribute =>
+ Disp_Attribute (To_Ghdl_Rtin_Object_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Instance =>
+ Disp_Instance (To_Ghdl_Rtin_Instance_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32 =>
+ Disp_Type_Enum_Decl (To_Ghdl_Rtin_Type_Enum_Acc (Rti), Indent);
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Disp_Subtype_Scalar_Decl (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti),
+ Ctxt, Indent);
+ when Ghdl_Rtik_Type_Array =>
+ Disp_Type_Array_Decl
+ (To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Subtype_Array =>
+ Disp_Subtype_Array_Decl
+ (To_Ghdl_Rtin_Subtype_Array_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Type_Access
+ | Ghdl_Rtik_Type_File =>
+ Disp_Type_File_Or_Access
+ (To_Ghdl_Rtin_Type_Fileacc_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Type_Record =>
+ Disp_Type_Record
+ (To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Type_Protected =>
+ Disp_Type_Protected
+ (To_Ghdl_Rtin_Type_Scalar_Acc (Rti), Ctxt, Indent);
+ when others =>
+ Disp_Indent (Indent);
+ Disp_Kind (Rti.Kind);
+ Put_Line (" ? ");
+ end case;
+ end Disp_Rti;
+
+ Disp_Rti_Flag : Boolean := False;
+
+ procedure Disp_All
+ is
+ Ctxt : Rti_Context;
+ begin
+ if not Disp_Rti_Flag then
+ return;
+ end if;
+
+ Put ("DISP_RTI.Disp_All: ");
+ Disp_Kind (Ghdl_Rti_Top.Common.Kind);
+ New_Line;
+ Ctxt := (Base => Ghdl_Rti_Top_Instance,
+ Block => Ghdl_Rti_Top.Parent);
+ Disp_Rti_Arr (Ghdl_Rti_Top.Nbr_Child,
+ Ghdl_Rti_Top.Children,
+ Ctxt, 0);
+ Disp_Rti (Ghdl_Rti_Top.Parent, Ctxt, 0);
+
+ --Disp_Hierarchy;
+ end Disp_All;
+
+ function Disp_Rti_Option (Opt : String) return Boolean
+ is
+ begin
+ if Opt = "--dump-rti" then
+ Disp_Rti_Flag := True;
+ return True;
+ else
+ return False;
+ end if;
+ end Disp_Rti_Option;
+
+ procedure Disp_Rti_Help
+ is
+ procedure P (Str : String) renames Put_Line;
+ begin
+ P (" --dump-rti dump Run Time Information");
+ end Disp_Rti_Help;
+
+ Disp_Rti_Hooks : aliased constant Hooks_Type :=
+ (Option => Disp_Rti_Option'Access,
+ Help => Disp_Rti_Help'Access,
+ Init => null,
+ Start => Disp_All'Access,
+ Finish => null);
+
+ procedure Register is
+ begin
+ Register_Hooks (Disp_Rti_Hooks'Access);
+ end Register;
+
+end Grt.Disp_Rti;
diff --git a/src/translate/grt/grt-disp_rti.ads b/src/translate/grt/grt-disp_rti.ads
new file mode 100644
index 000000000..6033d2011
--- /dev/null
+++ b/src/translate/grt/grt-disp_rti.ads
@@ -0,0 +1,43 @@
+-- GHDL Run Time (GRT) - RTI dumper.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+
+package Grt.Disp_Rti is
+ -- Disp NAME. If NAME is null, then disp .
+ procedure Disp_Name (Name : Ghdl_C_String);
+
+ -- Disp a value.
+ procedure Disp_Value (Stream : FILEs;
+ Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ Obj : in out Address;
+ Is_Sig : Boolean);
+
+ procedure Register;
+end Grt.Disp_Rti;
diff --git a/src/translate/grt/grt-disp_signals.adb b/src/translate/grt/grt-disp_signals.adb
new file mode 100644
index 000000000..424d20dcf
--- /dev/null
+++ b/src/translate/grt/grt-disp_signals.adb
@@ -0,0 +1,524 @@
+-- GHDL Run Time (GRT) - Display subprograms for signals.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Ada.Unchecked_Conversion;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Errors; use Grt.Errors;
+pragma Elaborate_All (Grt.Rtis_Utils);
+with Grt.Vstrings; use Grt.Vstrings;
+with Grt.Options;
+with Grt.Processes;
+with Grt.Disp; use Grt.Disp;
+
+package body Grt.Disp_Signals is
+ procedure Foreach_Scalar_Signal
+ (Process : access procedure (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param : Rti_Object))
+ is
+ procedure Call_Process (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param : Rti_Object) is
+ begin
+ Process.all (Val_Addr, Val_Name, Val_Type, Param);
+ end Call_Process;
+
+ pragma Inline (Call_Process);
+
+ procedure Foreach_Scalar_Signal_Signal is new
+ Foreach_Scalar (Param_Type => Rti_Object,
+ Process => Call_Process);
+
+ function Foreach_Scalar_Signal_Object
+ (Ctxt : Rti_Context; Obj : Ghdl_Rti_Access)
+ return Traverse_Result
+ is
+ Sig : Ghdl_Rtin_Object_Acc;
+ begin
+ case Obj.Kind is
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Attribute_Quiet
+ | Ghdl_Rtik_Attribute_Stable
+ | Ghdl_Rtik_Attribute_Transaction =>
+ Sig := To_Ghdl_Rtin_Object_Acc (Obj);
+ Foreach_Scalar_Signal_Signal
+ (Ctxt, Sig.Obj_Type,
+ Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True,
+ Rti_Object'(Obj, Ctxt));
+ when others =>
+ null;
+ end case;
+ return Traverse_Ok;
+ end Foreach_Scalar_Signal_Object;
+
+ function Foreach_Scalar_Signal_Traverse is
+ new Traverse_Blocks (Process => Foreach_Scalar_Signal_Object);
+
+ Res : Traverse_Result;
+ pragma Unreferenced (Res);
+ begin
+ Res := Foreach_Scalar_Signal_Traverse (Get_Top_Context);
+ end Foreach_Scalar_Signal;
+
+ procedure Disp_Context (Ctxt : Rti_Context)
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+ Nctxt : Rti_Context;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Block
+ | Ghdl_Rtik_Process =>
+ Nctxt := Get_Parent_Context (Ctxt);
+ Disp_Context (Nctxt);
+ Put ('.');
+ Put (Blk.Name);
+ when Ghdl_Rtik_Entity =>
+ Put (Blk.Name);
+ when Ghdl_Rtik_Architecture =>
+ Nctxt := Get_Parent_Context (Ctxt);
+ Disp_Context (Nctxt);
+ Put ('(');
+ Put (Blk.Name);
+ Put (')');
+ when others =>
+ Internal_Error ("disp_context");
+ end case;
+ end Disp_Context;
+
+ -- This is a debugging procedure.
+ pragma Unreferenced (Disp_Context);
+
+ -- Option --trace-signals.
+
+ -- Disp transaction TRANS from signal SIG.
+ procedure Disp_Transaction (Trans : Transaction_Acc;
+ Sig_Type : Ghdl_Rti_Access;
+ Mode : Mode_Type)
+ is
+ T : Transaction_Acc;
+ begin
+ T := Trans;
+ loop
+ case T.Kind is
+ when Trans_Value =>
+ if Sig_Type /= null then
+ Disp_Value (stdout, T.Val, Sig_Type);
+ else
+ Disp_Value (T.Val, Mode);
+ end if;
+ when Trans_Direct =>
+ if Sig_Type /= null then
+ Disp_Value (stdout, T.Val_Ptr.all, Sig_Type);
+ else
+ Disp_Value (T.Val_Ptr.all, Mode);
+ end if;
+ when Trans_Null =>
+ Put ("NULL");
+ when Trans_Error =>
+ Put ("ERROR");
+ end case;
+ if T.Kind = Trans_Direct then
+ -- The Time field is not updated for direct transaction.
+ Put ("[DIRECT]");
+ else
+ Put ("@");
+ Put_Time (stdout, T.Time);
+ end if;
+ T := T.Next;
+ exit when T = null;
+ Put (", ");
+ end loop;
+ end Disp_Transaction;
+
+ procedure Disp_Simple_Signal
+ (Sig : Ghdl_Signal_Ptr; Sig_Type : Ghdl_Rti_Access; Sources : Boolean)
+ is
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Resolved_Signal_Acc, Target => Address);
+ begin
+ Put (' ');
+ Put (stdout, Sig.all'Address);
+ Put (' ');
+ Disp_Mode (Sig.Mode);
+ Put (' ');
+ if Sig.Active then
+ Put ('A');
+ else
+ Put ('-');
+ end if;
+ if Sig.Event then
+ Put ('E');
+ else
+ Put ('-');
+ end if;
+ if Sig.Has_Active then
+ Put ('a');
+ else
+ Put ('-');
+ end if;
+ if Sig.S.Effective /= null then
+ Put ('e');
+ else
+ Put ('-');
+ end if;
+ if Boolean'(True) then
+ Put (" last_event=");
+ Put_Time (stdout, Sig.Last_Event);
+ Put (" last_active=");
+ Put_Time (stdout, Sig.Last_Active);
+ end if;
+ Put (" val=");
+ if Sig_Type /= null then
+ Disp_Value (stdout, Sig.Value, Sig_Type);
+ else
+ Disp_Value (Sig.Value, Sig.Mode);
+ end if;
+ Put ("; drv=");
+ if Sig_Type /= null then
+ Disp_Value (stdout, Sig.Driving_Value, Sig_Type);
+ else
+ Disp_Value (Sig.Driving_Value, Sig.Mode);
+ end if;
+ if Sources then
+ if Sig.Nbr_Ports > 0 then
+ Put (';');
+ Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports));
+ Put (" ports");
+ end if;
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ if Sig.S.Resolv /= null then
+ Put (stdout, " res func ");
+ Put (stdout, To_Address(Sig.S.Resolv));
+ end if;
+ if Sig.S.Nbr_Drivers = 0 then
+ Put ("; no driver");
+ elsif Sig.S.Nbr_Drivers = 1 then
+ Put ("; trans=");
+ Disp_Transaction
+ (Sig.S.Drivers (0).First_Trans, Sig_Type, Sig.Mode);
+ else
+ for I in 0 .. Sig.S.Nbr_Drivers - 1 loop
+ New_Line;
+ Put (" ");
+ Disp_Transaction
+ (Sig.S.Drivers (I).First_Trans, Sig_Type, Sig.Mode);
+ end loop;
+ end if;
+ end if;
+ end if;
+ New_Line;
+ end Disp_Simple_Signal;
+
+ procedure Disp_Signal_Name (Stream : FILEs;
+ Ctxt : Rti_Context;
+ Sig : Ghdl_Rtin_Object_Acc) is
+ begin
+ case Sig.Common.Kind is
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard =>
+ Put (stdout, Ctxt);
+ Put (".");
+ Put (Stream, Sig.Name);
+ when Ghdl_Rtik_Attribute_Quiet =>
+ Put (stdout, Ctxt);
+ Put (".");
+ Put (Stream, " 'quiet");
+ when Ghdl_Rtik_Attribute_Stable =>
+ Put (stdout, Ctxt);
+ Put (".");
+ Put (Stream, " 'stable");
+ when Ghdl_Rtik_Attribute_Transaction =>
+ Put (stdout, Ctxt);
+ Put (".");
+ Put (Stream, " 'transaction");
+ when others =>
+ null;
+ end case;
+ end Disp_Signal_Name;
+
+ procedure Disp_Scalar_Signal (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Parent : Rti_Object)
+ is
+ begin
+ Disp_Signal_Name (stdout, Parent.Ctxt,
+ To_Ghdl_Rtin_Object_Acc (Parent.Obj));
+ Put (stdout, Val_Name);
+ Disp_Simple_Signal (To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all),
+ Val_Type, Options.Disp_Sources);
+ end Disp_Scalar_Signal;
+
+
+ procedure Disp_All_Signals is
+ begin
+ Foreach_Scalar_Signal (Disp_Scalar_Signal'access);
+ end Disp_All_Signals;
+
+ -- Option disp-sensitivity
+
+ procedure Disp_Scalar_Sensitivity (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Parent : Rti_Object)
+ is
+ pragma Unreferenced (Val_Type);
+ Sig : Ghdl_Signal_Ptr;
+
+ Action : Action_List_Acc;
+ begin
+ Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
+ if Sig.Flags.Seen then
+ return;
+ else
+ Sig.Flags.Seen := True;
+ end if;
+ Disp_Signal_Name (stdout, Parent.Ctxt,
+ To_Ghdl_Rtin_Object_Acc (Parent.Obj));
+ Put (stdout, Val_Name);
+ New_Line (stdout);
+
+ Action := Sig.Event_List;
+ while Action /= null loop
+ Put (stdout, " wakeup ");
+ Grt.Processes.Disp_Process_Name (stdout, Action.Proc);
+ New_Line (stdout);
+ Action := Action.Next;
+ end loop;
+
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ for I in 1 .. Sig.S.Nbr_Drivers loop
+ Put (stdout, " driven ");
+ Grt.Processes.Disp_Process_Name
+ (stdout, Sig.S.Drivers (I - 1).Proc);
+ New_Line (stdout);
+ end loop;
+ end if;
+ end Disp_Scalar_Sensitivity;
+
+ procedure Disp_All_Sensitivity is
+ begin
+ Foreach_Scalar_Signal (Disp_Scalar_Sensitivity'access);
+ end Disp_All_Sensitivity;
+
+
+ -- Option disp-signals-map
+
+ procedure Disp_Signals_Map_Scalar (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Parent : Rti_Object)
+ is
+ pragma Unreferenced (Val_Type);
+
+ function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Signal_Ptr);
+
+ S : Ghdl_Signal_Ptr;
+ begin
+ Disp_Signal_Name (stdout,
+ Parent.Ctxt, To_Ghdl_Rtin_Object_Acc (Parent.Obj));
+ Put (stdout, Val_Name);
+ Put (": ");
+ S := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
+ Put (stdout, S.all'Address);
+ Put (" net: ");
+ Put_I32 (stdout, Ghdl_I32 (S.Net));
+ if S.Has_Active then
+ Put (" +A");
+ end if;
+ New_Line;
+ end Disp_Signals_Map_Scalar;
+
+ procedure Disp_Signals_Map is
+ begin
+ Foreach_Scalar_Signal (Disp_Signals_Map_Scalar'access);
+ end Disp_Signals_Map;
+
+ -- Option --disp-signals-table
+ procedure Disp_Mode_Signal (Mode : Mode_Signal_Type)
+ is
+ begin
+ case Mode is
+ when Mode_Signal =>
+ Put ("signal");
+ when Mode_Linkage =>
+ Put ("linkage");
+ when Mode_Buffer =>
+ Put ("buffer");
+ when Mode_Out =>
+ Put ("out");
+ when Mode_Inout =>
+ Put ("inout");
+ when Mode_In =>
+ Put ("in");
+ when Mode_Stable =>
+ Put ("stable");
+ when Mode_Quiet =>
+ Put ("quiet");
+ when Mode_Transaction =>
+ Put ("transaction");
+ when Mode_Delayed =>
+ Put ("delayed");
+ when Mode_Guard =>
+ Put ("guard");
+ when Mode_Conv_In =>
+ Put ("conv_in");
+ when Mode_Conv_Out =>
+ Put ("conv_out");
+ when Mode_End =>
+ Put ("end");
+ end case;
+ end Disp_Mode_Signal;
+
+ procedure Disp_Signals_Table
+ is
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Sig := Sig_Table.Table (I);
+ Put_Sig_Index (I);
+ Put (": ");
+ Put (stdout, Sig.all'Address);
+ if Sig.Has_Active then
+ Put (" +A");
+ end if;
+ Put (" net: ");
+ Put_I32 (stdout, Ghdl_I32 (Sig.Net));
+ Put (" smode: ");
+ Disp_Mode_Signal (Sig.S.Mode_Sig);
+ Put (" #prt: ");
+ Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports));
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ Put (" #drv: ");
+ Put_I32 (stdout, Ghdl_I32 (Sig.S.Nbr_Drivers));
+ if Sig.S.Effective /= null then
+ Put (" eff: ");
+ Put (stdout, Sig.S.Effective.all'Address);
+ end if;
+ if Sig.S.Resolv /= null then
+ Put (" resolved");
+ end if;
+ end if;
+ if Boolean'(False) then
+ Put (" link: ");
+ Put (stdout, Sig.Link.all'Address);
+ end if;
+ New_Line;
+ if Sig.Nbr_Ports /= 0 then
+ for J in 1 .. Sig.Nbr_Ports loop
+ Put (" ");
+ Put (stdout, Sig.Ports (J - 1).all'Address);
+ end loop;
+ New_Line;
+ end if;
+ end loop;
+ Grt.Stdio.fflush (stdout);
+ end Disp_Signals_Table;
+
+ procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ Disp_Simple_Signal (Sig, null, True);
+ end Disp_A_Signal;
+
+ procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr)
+ is
+ Found : Boolean := False;
+ Cur_Ctxt : Rti_Context;
+ Cur_Sig : Ghdl_Rtin_Object_Acc;
+
+ procedure Process_Scalar (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param : Boolean)
+ is
+ pragma Unreferenced (Val_Type);
+ pragma Unreferenced (Param);
+ Sig1 : Ghdl_Signal_Ptr;
+ begin
+ -- Read the signal.
+ Sig1 := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
+ if Sig1 = Sig and not Found then
+ Disp_Signal_Name (Stream, Cur_Ctxt, Cur_Sig);
+ Put (Stream, Val_Name);
+ Found := True;
+ end if;
+ end Process_Scalar;
+
+ procedure Foreach_Scalar is new Grt.Rtis_Utils.Foreach_Scalar
+ (Param_Type => Boolean, Process => Process_Scalar);
+
+ function Process_Block (Ctxt : Rti_Context;
+ Obj : Ghdl_Rti_Access)
+ return Traverse_Result
+ is
+ begin
+ case Obj.Kind is
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Attribute_Stable
+ | Ghdl_Rtik_Attribute_Quiet
+ | Ghdl_Rtik_Attribute_Transaction =>
+ Cur_Ctxt := Ctxt;
+ Cur_Sig := To_Ghdl_Rtin_Object_Acc (Obj);
+ Foreach_Scalar
+ (Ctxt, Cur_Sig.Obj_Type,
+ Loc_To_Addr (Cur_Sig.Common.Depth, Cur_Sig.Loc, Ctxt),
+ True, True);
+ if Found then
+ return Traverse_Stop;
+ end if;
+ when others =>
+ null;
+ end case;
+ return Traverse_Ok;
+ end Process_Block;
+
+ function Foreach_Block is new Grt.Rtis_Utils.Traverse_Blocks
+ (Process_Block);
+
+ Res_Status : Traverse_Result;
+ pragma Unreferenced (Res_Status);
+ begin
+ Res_Status := Foreach_Block (Get_Top_Context);
+ if not Found then
+ Put (Stream, "(unknown signal)");
+ end if;
+ end Put_Signal_Name;
+
+end Grt.Disp_Signals;
diff --git a/src/translate/grt/grt-disp_signals.ads b/src/translate/grt/grt-disp_signals.ads
new file mode 100644
index 000000000..73bd60d06
--- /dev/null
+++ b/src/translate/grt/grt-disp_signals.ads
@@ -0,0 +1,48 @@
+-- GHDL Run Time (GRT) - Display subprograms for signals.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Signals; use Grt.Signals;
+with Grt.Stdio; use Grt.Stdio;
+
+package Grt.Disp_Signals is
+ procedure Disp_All_Signals;
+
+ procedure Disp_Signals_Map;
+
+ procedure Disp_Signals_Table;
+
+ procedure Disp_All_Sensitivity;
+
+ procedure Disp_Mode_Signal (Mode : Mode_Signal_Type);
+
+ -- Disp informations on signal SIG.
+ -- To be used inside the debugger.
+ procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr);
+
+ -- Put the full name of signal SIG.
+ -- This operation is really expensive, since the whole hierarchy is
+ -- traversed.
+ procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr);
+end Grt.Disp_Signals;
diff --git a/src/translate/grt/grt-disp_tree.adb b/src/translate/grt/grt-disp_tree.adb
new file mode 100644
index 000000000..7d5811960
--- /dev/null
+++ b/src/translate/grt/grt-disp_tree.adb
@@ -0,0 +1,461 @@
+-- GHDL Run Time (GRT) - Tree displayer.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Disp_Rti; use Grt.Disp_Rti;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Types; use Grt.Types;
+with Grt.Errors; use Grt.Errors;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Hooks; use Grt.Hooks;
+
+package body Grt.Disp_Tree is
+ -- Set by --disp-tree, to display the design hierarchy.
+ type Disp_Tree_Kind is
+ (
+ Disp_Tree_None, -- Do not disp tree.
+ Disp_Tree_Inst, -- Disp entities, arch, package, blocks, components.
+ Disp_Tree_Proc, -- As above plus processes
+ Disp_Tree_Port -- As above plus ports and signals.
+ );
+ Disp_Tree_Flag : Disp_Tree_Kind := Disp_Tree_None;
+
+
+ -- Get next interesting child.
+ procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc;
+ Index : in out Ghdl_Index_Type;
+ Child : out Ghdl_Rti_Access)
+ is
+ begin
+ -- Exit if no more children.
+ while Index < Parent.Nbr_Child loop
+ Child := Parent.Children (Index);
+ Index := Index + 1;
+ case Child.Kind is
+ when Ghdl_Rtik_Package
+ | Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_For_Generate
+ | Ghdl_Rtik_If_Generate
+ | Ghdl_Rtik_Instance =>
+ return;
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard =>
+ if Disp_Tree_Flag >= Disp_Tree_Port then
+ return;
+ end if;
+ when Ghdl_Rtik_Process =>
+ if Disp_Tree_Flag >= Disp_Tree_Proc then
+ return;
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ Child := null;
+ end Get_Tree_Child;
+
+ procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
+ is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Process
+ | Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_If_Generate =>
+ declare
+ Blk : constant Ghdl_Rtin_Block_Acc :=
+ To_Ghdl_Rtin_Block_Acc (Rti);
+ begin
+ Disp_Name (Blk.Name);
+ end;
+ when Ghdl_Rtik_Package_Body
+ | Ghdl_Rtik_Package =>
+ declare
+ Blk : Ghdl_Rtin_Block_Acc;
+ Lib : Ghdl_Rtin_Type_Scalar_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Rti);
+ if Rti.Kind = Ghdl_Rtik_Package_Body then
+ Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
+ end if;
+ Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent);
+ Disp_Name (Lib.Name);
+ Put ('.');
+ Disp_Name (Blk.Name);
+ end;
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Blk : constant Ghdl_Rtin_Block_Acc :=
+ To_Ghdl_Rtin_Block_Acc (Rti);
+ Iter : Ghdl_Rtin_Object_Acc;
+ Addr : Address;
+ begin
+ Disp_Name (Blk.Name);
+ Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
+ Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
+ Put ('(');
+ Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False);
+ Put (')');
+ end;
+ when Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Port
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Iterator =>
+ Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name);
+ when Ghdl_Rtik_Instance =>
+ Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name);
+ when others =>
+ null;
+ end case;
+
+ case Rti.Kind is
+ when Ghdl_Rtik_Package
+ | Ghdl_Rtik_Package_Body =>
+ Put (" [package]");
+ when Ghdl_Rtik_Entity =>
+ Put (" [entity]");
+ when Ghdl_Rtik_Architecture =>
+ Put (" [arch]");
+ when Ghdl_Rtik_Process =>
+ Put (" [process]");
+ when Ghdl_Rtik_Block =>
+ Put (" [block]");
+ when Ghdl_Rtik_For_Generate =>
+ Put (" [for-generate]");
+ when Ghdl_Rtik_If_Generate =>
+ Put (" [if-generate ");
+ if Ctxt.Base = Null_Address then
+ Put ("false]");
+ else
+ Put ("true]");
+ end if;
+ when Ghdl_Rtik_Signal =>
+ Put (" [signal]");
+ when Ghdl_Rtik_Port =>
+ Put (" [port ");
+ case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is
+ when Ghdl_Rti_Signal_Mode_In =>
+ Put ("in");
+ when Ghdl_Rti_Signal_Mode_Out =>
+ Put ("out");
+ when Ghdl_Rti_Signal_Mode_Inout =>
+ Put ("inout");
+ when Ghdl_Rti_Signal_Mode_Buffer =>
+ Put ("buffer");
+ when Ghdl_Rti_Signal_Mode_Linkage =>
+ Put ("linkage");
+ when others =>
+ Put ("?");
+ end case;
+ Put ("]");
+ when Ghdl_Rtik_Guard =>
+ Put (" [guard]");
+ when Ghdl_Rtik_Iterator =>
+ Put (" [iterator]");
+ when Ghdl_Rtik_Instance =>
+ Put (" [instance]");
+ when others =>
+ null;
+ end case;
+ end Disp_Tree_Child;
+
+ procedure Disp_Tree_Block
+ (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String);
+
+ procedure Disp_Tree_Block1
+ (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
+ is
+ Child : Ghdl_Rti_Access;
+ Child2 : Ghdl_Rti_Access;
+ Index : Ghdl_Index_Type;
+
+ procedure Disp_Header (Nctxt : Rti_Context;
+ Force_Cont : Boolean := False)
+ is
+ begin
+ Put (Pfx);
+
+ if Blk.Common.Kind /= Ghdl_Rtik_Entity
+ and Child2 = null
+ and Force_Cont = False
+ then
+ Put ("`-");
+ else
+ Put ("+-");
+ end if;
+
+ Disp_Tree_Child (Child, Nctxt);
+ New_Line;
+ end Disp_Header;
+
+ procedure Disp_Sub_Block
+ (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context)
+ is
+ Npfx : String (1 .. Pfx'Length + 2);
+ begin
+ Npfx (1 .. Pfx'Length) := Pfx;
+ Npfx (Pfx'Length + 2) := ' ';
+ if Child2 = null then
+ Npfx (Pfx'Length + 1) := ' ';
+ else
+ Npfx (Pfx'Length + 1) := '|';
+ end if;
+ Disp_Tree_Block (Sub_Blk, Nctxt, Npfx);
+ end Disp_Sub_Block;
+
+ begin
+ Index := 0;
+ Get_Tree_Child (Blk, Index, Child);
+ while Child /= null loop
+ Get_Tree_Child (Blk, Index, Child2);
+
+ case Child.Kind is
+ when Ghdl_Rtik_Process
+ | Ghdl_Rtik_Block =>
+ declare
+ Nblk : constant Ghdl_Rtin_Block_Acc :=
+ To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt : Rti_Context;
+ begin
+ Nctxt := (Base => Ctxt.Base + Nblk.Loc,
+ Block => Child);
+ Disp_Header (Nctxt, False);
+ Disp_Sub_Block (Nblk, Nctxt);
+ end;
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Nblk : constant Ghdl_Rtin_Block_Acc :=
+ To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt : Rti_Context;
+ Length : Ghdl_Index_Type;
+ Old_Child2 : Ghdl_Rti_Access;
+ begin
+ Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all,
+ Block => Child);
+ Length := Get_For_Generate_Length (Nblk, Ctxt);
+ Disp_Header (Nctxt, Length > 1);
+ Old_Child2 := Child2;
+ if Length > 1 then
+ Child2 := Child;
+ end if;
+ for I in 1 .. Length loop
+ Disp_Sub_Block (Nblk, Nctxt);
+ if I /= Length then
+ Nctxt.Base := Nctxt.Base + Nblk.Size;
+ if I = Length - 1 then
+ Child2 := Old_Child2;
+ end if;
+ Disp_Header (Nctxt);
+ end if;
+ end loop;
+ Child2 := Old_Child2;
+ end;
+ when Ghdl_Rtik_If_Generate =>
+ declare
+ Nblk : constant Ghdl_Rtin_Block_Acc :=
+ To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt : Rti_Context;
+ begin
+ Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all,
+ Block => Child);
+ Disp_Header (Nctxt);
+ if Nctxt.Base /= Null_Address then
+ Disp_Sub_Block (Nblk, Nctxt);
+ end if;
+ end;
+ when Ghdl_Rtik_Instance =>
+ declare
+ Inst : Ghdl_Rtin_Instance_Acc;
+ Sub_Ctxt : Rti_Context;
+ Sub_Blk : Ghdl_Rtin_Block_Acc;
+ Npfx : String (1 .. Pfx'Length + 4);
+ Comp : Ghdl_Rtin_Component_Acc;
+ Ch : Ghdl_Rti_Access;
+ begin
+ Disp_Header (Ctxt);
+ Inst := To_Ghdl_Rtin_Instance_Acc (Child);
+ Get_Instance_Context (Inst, Ctxt, Sub_Ctxt);
+ Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block);
+ if Inst.Instance.Kind = Ghdl_Rtik_Component
+ and then Disp_Tree_Flag >= Disp_Tree_Port
+ then
+ -- Disp generics and ports of the component.
+ Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance);
+ for I in 1 .. Comp.Nbr_Child loop
+ Ch := Comp.Children (I - 1);
+ if Ch.Kind = Ghdl_Rtik_Port then
+ -- Disp only port (and not generics).
+ Put (Pfx);
+ if Child2 = null then
+ Put (" ");
+ else
+ Put ("| ");
+ end if;
+ if I = Comp.Nbr_Child and then Sub_Blk = null then
+ Put ("`-");
+ else
+ Put ("+-");
+ end if;
+ Disp_Tree_Child (Ch, Sub_Ctxt);
+ New_Line;
+ end if;
+ end loop;
+ end if;
+ if Sub_Blk /= null then
+ Npfx (1 .. Pfx'Length) := Pfx;
+ if Child2 = null then
+ Npfx (Pfx'Length + 1) := ' ';
+ else
+ Npfx (Pfx'Length + 1) := '|';
+ end if;
+ Npfx (Pfx'Length + 2) := ' ';
+ Npfx (Pfx'Length + 3) := '`';
+ Npfx (Pfx'Length + 4) := '-';
+ Put (Npfx);
+ Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt);
+ New_Line;
+ Npfx (Pfx'Length + 3) := ' ';
+ Npfx (Pfx'Length + 4) := ' ';
+ Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx);
+ end if;
+ end;
+ when others =>
+ Disp_Header (Ctxt);
+ end case;
+
+ Child := Child2;
+ end loop;
+ end Disp_Tree_Block1;
+
+ procedure Disp_Tree_Block
+ (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
+ is
+ begin
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Architecture =>
+ declare
+ Npfx : String (1 .. Pfx'Length + 2);
+ Nctxt : Rti_Context;
+ begin
+ -- The entity.
+ Nctxt := (Base => Ctxt.Base,
+ Block => Blk.Parent);
+ Disp_Tree_Block1
+ (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx);
+ -- Then the architecture.
+ Put (Pfx);
+ Put ("`-");
+ Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt);
+ New_Line;
+ Npfx (1 .. Pfx'Length) := Pfx;
+ Npfx (Pfx'Length + 1) := ' ';
+ Npfx (Pfx'Length + 2) := ' ';
+ Disp_Tree_Block1 (Blk, Ctxt, Npfx);
+ end;
+ when Ghdl_Rtik_Package_Body =>
+ Disp_Tree_Block1
+ (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx);
+ when others =>
+ Disp_Tree_Block1 (Blk, Ctxt, Pfx);
+ end case;
+ end Disp_Tree_Block;
+
+ procedure Disp_Hierarchy
+ is
+ Ctxt : Rti_Context;
+ Parent : Ghdl_Rtin_Block_Acc;
+ Child : Ghdl_Rti_Access;
+ begin
+ if Disp_Tree_Flag = Disp_Tree_None then
+ return;
+ end if;
+
+ Ctxt := Get_Top_Context;
+ Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+
+ Disp_Tree_Child (Parent.Parent, Ctxt);
+ New_Line;
+ Disp_Tree_Block (Parent, Ctxt, "");
+
+ for I in 1 .. Ghdl_Rti_Top.Nbr_Child loop
+ Child := Ghdl_Rti_Top.Children (I - 1);
+ Ctxt := (Base => Null_Address,
+ Block => Child);
+ Disp_Tree_Child (Child, Ctxt);
+ New_Line;
+ Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, "");
+ end loop;
+ end Disp_Hierarchy;
+
+ function Disp_Tree_Option (Option : String) return Boolean
+ is
+ Opt : constant String (1 .. Option'Length) := Option;
+ begin
+ if Opt'Length >= 11 and then Opt (1 .. 11) = "--disp-tree" then
+ if Opt'Length = 11 then
+ Disp_Tree_Flag := Disp_Tree_Port;
+ elsif Opt (12 .. Opt'Last) = "=port" then
+ Disp_Tree_Flag := Disp_Tree_Port;
+ elsif Opt (12 .. Opt'Last) = "=proc" then
+ Disp_Tree_Flag := Disp_Tree_Proc;
+ elsif Opt (12 .. Opt'Last) = "=inst" then
+ Disp_Tree_Flag := Disp_Tree_Inst;
+ elsif Opt (12 .. Opt'Last) = "=none" then
+ Disp_Tree_Flag := Disp_Tree_None;
+ else
+ Error ("bad argument for --disp-tree option, try --help");
+ end if;
+ return True;
+ else
+ return False;
+ end if;
+ end Disp_Tree_Option;
+
+ procedure Disp_Tree_Help
+ is
+ procedure P (Str : String) renames Put_Line;
+ begin
+ P (" --disp-tree[=KIND] disp the design hierarchy after elaboration");
+ P (" KIND is inst, proc, port (default)");
+ end Disp_Tree_Help;
+
+ Disp_Tree_Hooks : aliased constant Hooks_Type :=
+ (Option => Disp_Tree_Option'Access,
+ Help => Disp_Tree_Help'Access,
+ Init => null,
+ Start => Disp_Hierarchy'Access,
+ Finish => null);
+
+ procedure Register is
+ begin
+ Register_Hooks (Disp_Tree_Hooks'Access);
+ end Register;
+
+end Grt.Disp_Tree;
diff --git a/src/translate/grt/grt-disp_tree.ads b/src/translate/grt/grt-disp_tree.ads
new file mode 100644
index 000000000..e3bc983a7
--- /dev/null
+++ b/src/translate/grt/grt-disp_tree.ads
@@ -0,0 +1,27 @@
+-- GHDL Run Time (GRT) - RTI dumper.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+package Grt.Disp_Tree is
+ procedure Register;
+end Grt.Disp_Tree;
diff --git a/src/translate/grt/grt-errors.adb b/src/translate/grt/grt-errors.adb
new file mode 100644
index 000000000..eddea38c1
--- /dev/null
+++ b/src/translate/grt/grt-errors.adb
@@ -0,0 +1,253 @@
+-- GHDL Run Time (GRT) - Error handling.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Options; use Grt.Options;
+with Grt.Hooks; use Grt.Hooks;
+
+package body Grt.Errors is
+ -- Called in case of premature exit.
+ -- CODE is 0 for success, 1 for failure.
+ procedure Ghdl_Exit (Code : Integer);
+ pragma No_Return (Ghdl_Exit);
+
+ procedure Ghdl_Exit (Code : Integer)
+ is
+ procedure C_Exit (Status : Integer);
+ pragma Import (C, C_Exit, "exit");
+ pragma No_Return (C_Exit);
+ begin
+ C_Exit (Code);
+ end Ghdl_Exit;
+
+ procedure Maybe_Return_Via_Longjump (Val : Integer);
+ pragma Import (C, Maybe_Return_Via_Longjump,
+ "__ghdl_maybe_return_via_longjump");
+
+ procedure Exit_Simulation is
+ begin
+ Maybe_Return_Via_Longjump (-2);
+ Internal_Error ("exit_simulation");
+ end Exit_Simulation;
+
+ procedure Fatal_Error is
+ begin
+ if Error_Hook /= null then
+ -- Call the hook, but avoid infinite loop by reseting it.
+ declare
+ Current_Hook : constant Proc_Hook_Type := Error_Hook;
+ begin
+ Error_Hook := null;
+ Current_Hook.all;
+ end;
+ end if;
+ Maybe_Return_Via_Longjump (-1);
+ if Expect_Failure then
+ Ghdl_Exit (0);
+ else
+ Ghdl_Exit (1);
+ end if;
+ end Fatal_Error;
+
+ procedure Put_Err (Str : String) is
+ begin
+ Put (stderr, Str);
+ end Put_Err;
+
+ procedure Put_Err (Str : Ghdl_C_String) is
+ begin
+ Put (stderr, Str);
+ end Put_Err;
+
+ procedure Put_Err (N : Integer) is
+ begin
+ Put_I32 (stderr, Ghdl_I32 (N));
+ end Put_Err;
+
+ procedure Newline_Err is
+ begin
+ New_Line (stderr);
+ end Newline_Err;
+
+-- procedure Put_Err (Str : Ghdl_Str_Len_Type)
+-- is
+-- S : String (1 .. 3);
+-- begin
+-- if Str.Str = null then
+-- S (1) := ''';
+-- S (2) := Character'Val (Str.Len);
+-- S (3) := ''';
+-- Put_Err (S);
+-- else
+-- Put_Err (Str.Str (1 .. Str.Len));
+-- end if;
+-- end Put_Err;
+
+ procedure Report_H (Str : String := "") is
+ begin
+ Put_Err (Str);
+ end Report_H;
+
+ procedure Report_C (Str : String) is
+ begin
+ Put_Err (Str);
+ end Report_C;
+
+ procedure Report_C (Str : Ghdl_C_String)
+ is
+ Len : constant Natural := strlen (Str);
+ begin
+ Put_Err (Str (1 .. Len));
+ end Report_C;
+
+ procedure Report_C (N : Integer)
+ renames Put_Err;
+
+ procedure Report_Now_C is
+ begin
+ Put_Time (stderr, Grt.Types.Current_Time);
+ end Report_Now_C;
+
+ procedure Report_E (Str : String) is
+ begin
+ Put_Err (Str);
+ Newline_Err;
+ end Report_E;
+
+ procedure Report_E (Str : Std_String_Ptr)
+ is
+ subtype Ada_Str is String (1 .. Natural (Str.Bounds.Dim_1.Length));
+ begin
+ if Ada_Str'Length > 0 then
+ Put_Err (Ada_Str (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1)));
+ end if;
+ Newline_Err;
+ end Report_E;
+
+ procedure Error_H is
+ begin
+ Put_Err (Progname);
+ Put_Err (":error: ");
+ end Error_H;
+
+ Cont : Boolean := False;
+
+ procedure Error_C (Str : String) is
+ begin
+ if not Cont then
+ Error_H;
+ Cont := True;
+ end if;
+ Put_Err (Str);
+ end Error_C;
+
+ procedure Error_C (Str : Ghdl_C_String)
+ is
+ Len : constant Natural := strlen (Str);
+ begin
+ if not Cont then
+ Error_H;
+ Cont := True;
+ end if;
+ Put_Err (Str (1 .. Len));
+ end Error_C;
+
+ procedure Error_C (N : Integer) is
+ begin
+ if not Cont then
+ Error_H;
+ Cont := True;
+ end if;
+ Put_Err (N);
+ end Error_C;
+
+-- procedure Error_C (Inst : Ghdl_Instance_Name_Acc)
+-- is
+-- begin
+-- if not Cont then
+-- Error_H;
+-- Cont := True;
+-- end if;
+-- if Inst.Parent /= null then
+-- Error_C (Inst.Parent);
+-- Put_Err (".");
+-- end if;
+-- case Inst.Kind is
+-- when Ghdl_Name_Architecture =>
+-- Put_Err ("(");
+-- Put_Err (Inst.Name.all);
+-- Put_Err (")");
+-- when others =>
+-- if Inst.Name /= null then
+-- Put_Err (Inst.Name.all);
+-- end if;
+-- end case;
+-- end Error_C;
+
+ procedure Error_E (Str : String := "") is
+ begin
+ Put_Err (Str);
+ Newline_Err;
+ Cont := False;
+ Fatal_Error;
+ end Error_E;
+
+ procedure Error_C_Std (Str : Std_String_Uncons)
+ is
+ subtype Str_Subtype is String (1 .. Str'Length);
+ begin
+ Error_C (Str_Subtype (Str));
+ end Error_C_Std;
+
+ procedure Error (Str : String) is
+ begin
+ Error_H;
+ Put_Err (Str);
+ Newline_Err;
+ Fatal_Error;
+ end Error;
+
+ procedure Info (Str : String) is
+ begin
+ Put_Err (Progname);
+ Put_Err (":info: ");
+ Put_Err (Str);
+ Newline_Err;
+ end Info;
+
+ procedure Internal_Error (Msg : String) is
+ begin
+ Put_Err (Progname);
+ Put_Err (":internal error: ");
+ Put_Err (Msg);
+ Newline_Err;
+ Fatal_Error;
+ end Internal_Error;
+
+ procedure Grt_Overflow_Error is
+ begin
+ Error ("overflow detected");
+ end Grt_Overflow_Error;
+end Grt.Errors;
diff --git a/src/translate/grt/grt-errors.ads b/src/translate/grt/grt-errors.ads
new file mode 100644
index 000000000..c797a71bd
--- /dev/null
+++ b/src/translate/grt/grt-errors.ads
@@ -0,0 +1,84 @@
+-- GHDL Run Time (GRT) - Error handling.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Hooks;
+
+package Grt.Errors is
+ pragma Preelaborate (Grt.Errors);
+
+ -- Multi-call error procedure.
+ -- Start and continue with Error_C, finish by an Error_E.
+ procedure Error_C (Str : String);
+ procedure Error_C (N : Integer);
+ procedure Error_C (Str : Ghdl_C_String);
+ procedure Error_C_Std (Str : Std_String_Uncons);
+ --procedure Error_C (Inst : Ghdl_Instance_Name_Acc);
+ procedure Error_E (Str : String := "");
+ -- procedure Error_E_Std (Str : Std_String_Uncons);
+ pragma No_Return (Error_E);
+
+ -- Multi-call report procedure. Do not exit at end.
+ procedure Report_H (Str : String := "");
+ procedure Report_C (Str : Ghdl_C_String);
+ procedure Report_C (Str : String);
+ procedure Report_C (N : Integer);
+ procedure Report_Now_C;
+ procedure Report_E (Str : String);
+ procedure Report_E (Str : Std_String_Ptr);
+
+ -- Complete error message.
+ procedure Error (Str : String);
+
+ -- Internal error. The message must contain the subprogram name which
+ -- has called this procedure.
+ procedure Internal_Error (Msg : String);
+ pragma No_Return (Internal_Error);
+
+ -- Display a message which is not an error.
+ procedure Info (Str : String);
+
+ -- Display an error message for an overflow.
+ procedure Grt_Overflow_Error;
+
+ -- Called at end of error message. Central point for failures.
+ procedure Fatal_Error;
+ pragma No_Return (Fatal_Error);
+ pragma Export (C, Fatal_Error, "__ghdl_fatal");
+
+ Exit_Status : Integer := 0;
+ procedure Exit_Simulation;
+
+ -- Hook called in case of error.
+ Error_Hook : Grt.Hooks.Proc_Hook_Type := null;
+
+ -- If true, an error is expected and the exit status is inverted.
+ Expect_Failure : Boolean := False;
+
+private
+ pragma Export (C, Grt_Overflow_Error, "grt_overflow_error");
+
+ pragma No_Return (Error);
+end Grt.Errors;
+
diff --git a/src/translate/grt/grt-files.adb b/src/translate/grt/grt-files.adb
new file mode 100644
index 000000000..30d51cf43
--- /dev/null
+++ b/src/translate/grt/grt-files.adb
@@ -0,0 +1,452 @@
+-- GHDL Run Time (GRT) - VHDL files subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.C; use Grt.C;
+with Grt.Table;
+with System; use System;
+pragma Elaborate_All (Grt.Table);
+
+package body Grt.Files is
+ subtype C_Files is Grt.Stdio.FILEs;
+
+ Auto_Flush : constant Boolean := False;
+
+ type File_Entry_Type is record
+ Stream : C_Files;
+ Signature : Ghdl_C_String;
+ Is_Text : Boolean;
+ Is_Alive : Boolean;
+ end record;
+
+ package Files_Table is new Grt.Table
+ (Table_Component_Type => File_Entry_Type,
+ Table_Index_Type => Ghdl_File_Index,
+ Table_Low_Bound => 1,
+ Table_Initial => 2);
+
+ function Get_File (Index : Ghdl_File_Index) return C_Files
+ is
+ begin
+ if Index not in Files_Table.First .. Files_Table.Last then
+ Internal_Error ("get_file: bad file index");
+ end if;
+ return Files_Table.Table (Index).Stream;
+ end Get_File;
+
+ procedure Check_File_Mode (Index : Ghdl_File_Index; Is_Text : Boolean)
+ is
+ begin
+ if Files_Table.Table (Index).Is_Text /= Is_Text then
+ Internal_Error ("check_file_mode: bad file mode");
+ end if;
+ end Check_File_Mode;
+
+ function Create_File (Is_Text : Boolean; Sig : Ghdl_C_String)
+ return Ghdl_File_Index is
+ begin
+ Files_Table.Append ((Stream => NULL_Stream,
+ Signature => Sig,
+ Is_Text => Is_Text,
+ Is_Alive => True));
+ return Files_Table.Last;
+ end Create_File;
+
+ procedure Destroy_File (Is_Text : Boolean; Index : Ghdl_File_Index) is
+ begin
+ if Get_File (Index) /= NULL_Stream then
+ Internal_Error ("destroy_file");
+ end if;
+ Check_File_Mode (Index, Is_Text);
+ Files_Table.Table (Index).Is_Alive := False;
+ if Index = Files_Table.Last then
+ while Files_Table.Last >= Files_Table.First
+ and then Files_Table.Table (Files_Table.Last).Is_Alive = False
+ loop
+ Files_Table.Decrement_Last;
+ end loop;
+ end if;
+ end Destroy_File;
+
+ procedure File_Error (File : Ghdl_File_Index)
+ is
+ pragma Unreferenced (File);
+ begin
+ Internal_Error ("file: IO error");
+ end File_Error;
+
+ function Ghdl_Text_File_Elaborate return Ghdl_File_Index is
+ begin
+ return Create_File (True, null);
+ end Ghdl_Text_File_Elaborate;
+
+ function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index
+ is
+ begin
+ return Create_File (False, Sig);
+ end Ghdl_File_Elaborate;
+
+ procedure Ghdl_Text_File_Finalize (File : Ghdl_File_Index) is
+ begin
+ Destroy_File (True, File);
+ end Ghdl_Text_File_Finalize;
+
+ procedure Ghdl_File_Finalize (File : Ghdl_File_Index) is
+ begin
+ Destroy_File (False, File);
+ end Ghdl_File_Finalize;
+
+ function Ghdl_File_Endfile (File : Ghdl_File_Index) return Boolean
+ is
+ Stream : C_Files;
+ C : int;
+ begin
+ Stream := Get_File (File);
+ if feof (Stream) /= 0 then
+ return True;
+ end if;
+ C := fgetc (Stream);
+ if C < 0 then
+ return True;
+ end if;
+ if ungetc (C, Stream) /= C then
+ Error ("internal error: ungetc");
+ end if;
+ return False;
+ end Ghdl_File_Endfile;
+
+ Sig_Header : constant String := "#GHDL-BINARY-FILE-0.0" & Nl;
+
+ function File_Open (File : Ghdl_File_Index;
+ Mode : Ghdl_I32;
+ Str : Std_String_Ptr)
+ return Ghdl_I32
+ is
+ Name : String (1 .. Integer (Str.Bounds.Dim_1.Length) + 1);
+ Str_Mode : String (1 .. 3);
+ F : C_Files;
+ Sig : Ghdl_C_String;
+ Sig_Len : Natural;
+ begin
+ F := Get_File (File);
+
+ if F /= NULL_Stream then
+ -- File was already open.
+ return Status_Error;
+ end if;
+
+ -- Copy file name and convert it to a C string (NUL terminated).
+ for I in 1 .. Str.Bounds.Dim_1.Length loop
+ Name (Natural (I)) := Str.Base (I - 1);
+ end loop;
+ Name (Name'Last) := NUL;
+
+ if Name = "STD_INPUT" & NUL then
+ if Mode /= Read_Mode then
+ return Mode_Error;
+ end if;
+ F := stdin;
+ elsif Name = "STD_OUTPUT" & NUL then
+ if Mode /= Write_Mode then
+ return Mode_Error;
+ end if;
+ F := stdout;
+ else
+ case Mode is
+ when Read_Mode =>
+ Str_Mode (1) := 'r';
+ when Write_Mode =>
+ Str_Mode (1) := 'w';
+ when Append_Mode =>
+ Str_Mode (1) := 'a';
+ when others =>
+ -- Bad mode, cannot happen.
+ Internal_Error ("file_open: bad open mode");
+ end case;
+ if Files_Table.Table (File).Is_Text then
+ Str_Mode (2) := NUL;
+ else
+ Str_Mode (2) := 'b';
+ Str_Mode (3) := NUL;
+ end if;
+ F := fopen (Name'Address, Str_Mode'Address);
+ if F = NULL_Stream then
+ return Name_Error;
+ end if;
+ end if;
+ Sig := Files_Table.Table (File).Signature;
+ if Sig /= null then
+ Sig_Len := strlen (Sig);
+ case Mode is
+ when Write_Mode =>
+ if fwrite (Sig_Header'Address, 1, Sig_Header'Length, F)
+ /= Sig_Header'Length
+ then
+ File_Error (File);
+ end if;
+ if fwrite (Sig (1)'Address, 1, size_t (Sig_Len), F)
+ /= size_t (Sig_Len)
+ then
+ File_Error (File);
+ end if;
+ when Read_Mode =>
+ declare
+ Hdr : String (1 .. Sig_Header'Length);
+ Sig_Buf : String (1 .. Sig_Len);
+ begin
+ if fread (Hdr'Address, 1, Hdr'Length, F) /= Hdr'Length then
+ File_Error (File);
+ end if;
+ if Hdr /= Sig_Header then
+ File_Error (File);
+ end if;
+ if fread (Sig_Buf'Address, 1, Sig_Buf'Length, F)
+ /= Sig_Buf'Length
+ then
+ File_Error (File);
+ end if;
+ if Sig_Buf /= Sig (1 .. Sig_Len) then
+ File_Error (File);
+ end if;
+ end;
+ when Append_Mode =>
+ null;
+ when others =>
+ null;
+ end case;
+ end if;
+ Files_Table.Table (File).Stream := F;
+ return Open_Ok;
+ end File_Open;
+
+ procedure Ghdl_Text_File_Open
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ is
+ Res : Ghdl_I32;
+ begin
+ Check_File_Mode (File, True);
+
+ Res := File_Open (File, Mode, Str);
+
+ if Res /= Open_Ok then
+ Error_C ("open: cannot open text file ");
+ Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1));
+ Error_E;
+ end if;
+ end Ghdl_Text_File_Open;
+
+ procedure Ghdl_File_Open
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ is
+ Res : Ghdl_I32;
+ begin
+ Check_File_Mode (File, False);
+
+ Res := File_Open (File, Mode, Str);
+
+ if Res /= Open_Ok then
+ Error_C ("open: cannot open file ");
+ Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1));
+ Error_E;
+ end if;
+ end Ghdl_File_Open;
+
+ function Ghdl_Text_File_Open_Status
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ return Ghdl_I32
+ is
+ begin
+ Check_File_Mode (File, True);
+ return File_Open (File, Mode, Str);
+ end Ghdl_Text_File_Open_Status;
+
+ function Ghdl_File_Open_Status
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ return Ghdl_I32
+ is
+ begin
+ Check_File_Mode (File, False);
+ return File_Open (File, Mode, Str);
+ end Ghdl_File_Open_Status;
+
+ procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr)
+ is
+ Res : C_Files;
+ R : size_t;
+ R1 : int;
+ pragma Unreferenced (R, R1);
+ begin
+ Res := Get_File (File);
+ Check_File_Mode (File, True);
+ if Res = NULL_Stream then
+ Error ("write to a non-opened file");
+ end if;
+ -- FIXME: check mode.
+ R := fwrite (Str.Base (0)'Address,
+ size_t (Str.Bounds.Dim_1.Length), 1, Res);
+ -- FIXME: check r
+ -- Write '\n'.
+ R1 := fputc (Character'Pos (Nl), Res);
+ if Auto_Flush then
+ fflush (Res);
+ end if;
+ end Ghdl_Text_Write;
+
+ procedure Ghdl_Write_Scalar (File : Ghdl_File_Index;
+ Ptr : Ghdl_Ptr;
+ Length : Ghdl_Index_Type)
+ is
+ Res : C_Files;
+ R : size_t;
+ begin
+ Res := Get_File (File);
+ Check_File_Mode (File, False);
+ if Res = NULL_Stream then
+ Error ("write to a non-opened file");
+ end if;
+ -- FIXME: check mode.
+ R := fwrite (System.Address (Ptr), size_t (Length), 1, Res);
+ if R /= 1 then
+ Error ("write_scalar failed");
+ end if;
+ if Auto_Flush then
+ fflush (Res);
+ end if;
+ end Ghdl_Write_Scalar;
+
+ procedure Ghdl_Read_Scalar (File : Ghdl_File_Index;
+ Ptr : Ghdl_Ptr;
+ Length : Ghdl_Index_Type)
+ is
+ Res : C_Files;
+ R : size_t;
+ begin
+ Res := Get_File (File);
+ Check_File_Mode (File, False);
+ if Res = NULL_Stream then
+ Error ("write to a non-opened file");
+ end if;
+ -- FIXME: check mode.
+ R := fread (System.Address (Ptr), size_t (Length), 1, Res);
+ if R /= 1 then
+ Error ("read_scalar failed");
+ end if;
+ end Ghdl_Read_Scalar;
+
+ function Ghdl_Text_Read_Length (File : Ghdl_File_Index;
+ Str : Std_String_Ptr)
+ return Std_Integer
+ is
+ Stream : C_Files;
+ C : int;
+ Len : Ghdl_Index_Type;
+ begin
+ Stream := Get_File (File);
+ Check_File_Mode (File, True);
+ Len := Str.Bounds.Dim_1.Length;
+ -- Read until EOL (or EOF).
+ -- Store as much as possible.
+ for I in Ghdl_Index_Type loop
+ C := fgetc (Stream);
+ if C < 0 then
+ Error ("read: end of file reached");
+ return Std_Integer (I);
+ end if;
+ if I < Len then
+ Str.Base (I) := Character'Val (C);
+ end if;
+ -- End of line is '\n' or LF or character # 10.
+ if C = 10 then
+ return Std_Integer (I + 1);
+ end if;
+ end loop;
+ return 0;
+ end Ghdl_Text_Read_Length;
+
+ procedure Ghdl_Untruncated_Text_Read
+ (Res : Ghdl_Untruncated_Text_Read_Result_Acc;
+ File : Ghdl_File_Index;
+ Str : Std_String_Ptr)
+ is
+ Stream : C_Files;
+ Len : int;
+ Idx : Ghdl_Index_Type;
+ begin
+ Stream := Get_File (File);
+ Check_File_Mode (File, True);
+ Len := int (Str.Bounds.Dim_1.Length);
+ if fgets (Str.Base (0)'Address, Len, Stream) = Null_Address then
+ Internal_Error ("ghdl_untruncated_text_read: end of file");
+ end if;
+ -- Compute the length.
+ for I in Ghdl_Index_Type loop
+ if Str.Base (I) = NUL then
+ Idx := I;
+ exit;
+ end if;
+ end loop;
+ Res.Len := Std_Integer (Idx);
+ end Ghdl_Untruncated_Text_Read;
+
+ procedure File_Close (File : Ghdl_File_Index; Is_Text : Boolean)
+ is
+ Stream : C_Files;
+ begin
+ Stream := Get_File (File);
+ Check_File_Mode (File, Is_Text);
+ -- LRM 3.4.1 File Operations
+ -- If F is not associated with an external file, then FILE_CLOSE has
+ -- no effect.
+ if Stream = NULL_Stream then
+ return;
+ end if;
+ if fclose (Stream) /= 0 then
+ Internal_Error ("file_close: fclose error");
+ end if;
+ Files_Table.Table (File).Stream := NULL_Stream;
+ end File_Close;
+
+ procedure Ghdl_Text_File_Close (File : Ghdl_File_Index) is
+ begin
+ File_Close (File, True);
+ end Ghdl_Text_File_Close;
+
+ procedure Ghdl_File_Close (File : Ghdl_File_Index) is
+ begin
+ File_Close (File, False);
+ end Ghdl_File_Close;
+
+ procedure Ghdl_File_Flush (File : Ghdl_File_Index)
+ is
+ Stream : C_Files;
+ begin
+ Stream := Get_File (File);
+ if Stream = NULL_Stream then
+ return;
+ end if;
+ fflush (Stream);
+ end Ghdl_File_Flush;
+end Grt.Files;
+
diff --git a/src/translate/grt/grt-files.ads b/src/translate/grt/grt-files.ads
new file mode 100644
index 000000000..14f998468
--- /dev/null
+++ b/src/translate/grt/grt-files.ads
@@ -0,0 +1,123 @@
+-- GHDL Run Time (GRT) - VHDL files subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Interfaces;
+
+package Grt.Files is
+ type Ghdl_File_Index is new Interfaces.Integer_32;
+
+ -- File open mode.
+ Read_Mode : constant Ghdl_I32 := 0;
+ Write_Mode : constant Ghdl_I32 := 1;
+ Append_Mode : constant Ghdl_I32 := 2;
+
+ -- file_open_status.
+ Open_Ok : constant Ghdl_I32 := 0;
+ Status_Error : constant Ghdl_I32 := 1;
+ Name_Error : constant Ghdl_I32 := 2;
+ Mode_Error : constant Ghdl_I32 := 3;
+
+ -- General files.
+ function Ghdl_File_Endfile (File : Ghdl_File_Index) return Boolean;
+
+ -- Elaboration.
+ function Ghdl_Text_File_Elaborate return Ghdl_File_Index;
+ function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index;
+
+ -- Finalization.
+ procedure Ghdl_Text_File_Finalize (File : Ghdl_File_Index);
+ procedure Ghdl_File_Finalize (File : Ghdl_File_Index);
+
+ -- Subprograms.
+ procedure Ghdl_Text_File_Open
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr);
+ function Ghdl_Text_File_Open_Status
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ return Ghdl_I32;
+
+ procedure Ghdl_File_Open
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr);
+ function Ghdl_File_Open_Status
+ (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr)
+ return Ghdl_I32;
+
+ procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr);
+ procedure Ghdl_Write_Scalar (File : Ghdl_File_Index;
+ Ptr : Ghdl_Ptr;
+ Length : Ghdl_Index_Type);
+
+ procedure Ghdl_Read_Scalar (File : Ghdl_File_Index;
+ Ptr : Ghdl_Ptr;
+ Length : Ghdl_Index_Type);
+
+ function Ghdl_Text_Read_Length
+ (File : Ghdl_File_Index; Str : Std_String_Ptr) return Std_Integer;
+
+ type Ghdl_Untruncated_Text_Read_Result is record
+ Len : Std_Integer;
+ end record;
+
+ type Ghdl_Untruncated_Text_Read_Result_Acc is
+ access Ghdl_Untruncated_Text_Read_Result;
+
+ procedure Ghdl_Untruncated_Text_Read
+ (Res : Ghdl_Untruncated_Text_Read_Result_Acc;
+ File : Ghdl_File_Index;
+ Str : Std_String_Ptr);
+
+ procedure Ghdl_Text_File_Close (File : Ghdl_File_Index);
+ procedure Ghdl_File_Close (File : Ghdl_File_Index);
+
+ procedure Ghdl_File_Flush (File : Ghdl_File_Index);
+private
+ pragma Export (Ada, Ghdl_File_Endfile, "__ghdl_file_endfile");
+
+ pragma Export (C, Ghdl_Text_File_Elaborate, "__ghdl_text_file_elaborate");
+ pragma Export (C, Ghdl_File_Elaborate, "__ghdl_file_elaborate");
+
+ pragma Export (C, Ghdl_Text_File_Finalize, "__ghdl_text_file_finalize");
+ pragma Export (C, Ghdl_File_Finalize, "__ghdl_file_finalize");
+
+ pragma Export (C, Ghdl_Text_File_Open, "__ghdl_text_file_open");
+ pragma Export (C, Ghdl_Text_File_Open_Status,
+ "__ghdl_text_file_open_status");
+
+ pragma Export (C, Ghdl_File_Open, "__ghdl_file_open");
+ pragma Export (C, Ghdl_File_Open_Status, "__ghdl_file_open_status");
+
+ pragma Export (C, Ghdl_Text_Write, "__ghdl_text_write");
+ pragma Export (C, Ghdl_Write_Scalar, "__ghdl_write_scalar");
+
+ pragma Export (C, Ghdl_Read_Scalar, "__ghdl_read_scalar");
+
+ pragma Export (C, Ghdl_Text_Read_Length, "__ghdl_text_read_length");
+ pragma Export (C, Ghdl_Untruncated_Text_Read,
+ "std__textio__untruncated_text_read");
+
+ pragma Export (C, Ghdl_Text_File_Close, "__ghdl_text_file_close");
+ pragma Export (C, Ghdl_File_Close, "__ghdl_file_close");
+
+ pragma Export (C, Ghdl_File_Flush, "__ghdl_file_flush");
+end Grt.Files;
diff --git a/src/translate/grt/grt-hooks.adb b/src/translate/grt/grt-hooks.adb
new file mode 100644
index 000000000..6a77aaf01
--- /dev/null
+++ b/src/translate/grt/grt-hooks.adb
@@ -0,0 +1,161 @@
+-- GHDL Run Time (GRT) - Hooks.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package body Grt.Hooks is
+ type Hooks_Cell;
+ type Hooks_Cell_Acc is access Hooks_Cell;
+ type Hooks_Cell is record
+ Hooks : Hooks_Acc;
+ Next : Hooks_Cell_Acc;
+ end record;
+
+ First_Hooks : Hooks_Cell_Acc := null;
+ Last_Hooks : Hooks_Cell_Acc := null;
+
+ procedure Register_Hooks (Hooks : Hooks_Acc)
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := new Hooks_Cell'(Hooks => Hooks,
+ Next => null);
+ if Last_Hooks = null then
+ First_Hooks := Cell;
+ else
+ Last_Hooks.Next := Cell;
+ end if;
+ Last_Hooks := Cell;
+ end Register_Hooks;
+
+ type Hook_Cell;
+ type Hook_Cell_Acc is access Hook_Cell;
+ type Hook_Cell is record
+ Hook : Proc_Hook_Type;
+ Next : Hook_Cell_Acc;
+ end record;
+
+ -- Chain of cycle hooks.
+ Cycle_Hook : Hook_Cell_Acc := null;
+ Last_Cycle_Hook : Hook_Cell_Acc := null;
+
+ procedure Register_Cycle_Hook (Proc : Proc_Hook_Type)
+ is
+ Cell : Hook_Cell_Acc;
+ begin
+ Cell := new Hook_Cell'(Hook => Proc,
+ Next => null);
+ if Cycle_Hook = null then
+ Cycle_Hook := Cell;
+ else
+ Last_Cycle_Hook.Next := Cell;
+ end if;
+ Last_Cycle_Hook := Cell;
+ end Register_Cycle_Hook;
+
+ procedure Call_Cycle_Hooks
+ is
+ Cell : Hook_Cell_Acc;
+ begin
+ Cell := Cycle_Hook;
+ while Cell /= null loop
+ Cell.Hook.all;
+ Cell := Cell.Next;
+ end loop;
+ end Call_Cycle_Hooks;
+
+ function Call_Option_Hooks (Opt : String) return Boolean
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := First_Hooks;
+ while Cell /= null loop
+ if Cell.Hooks.Option /= null
+ and then Cell.Hooks.Option.all (Opt)
+ then
+ return True;
+ end if;
+ Cell := Cell.Next;
+ end loop;
+ return False;
+ end Call_Option_Hooks;
+
+ procedure Call_Help_Hooks
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := First_Hooks;
+ while Cell /= null loop
+ if Cell.Hooks.Help /= null then
+ Cell.Hooks.Help.all;
+ end if;
+ Cell := Cell.Next;
+ end loop;
+ end Call_Help_Hooks;
+
+ procedure Call_Init_Hooks
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := First_Hooks;
+ while Cell /= null loop
+ if Cell.Hooks.Init /= null then
+ Cell.Hooks.Init.all;
+ end if;
+ Cell := Cell.Next;
+ end loop;
+ end Call_Init_Hooks;
+
+ procedure Call_Start_Hooks
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := First_Hooks;
+ while Cell /= null loop
+ if Cell.Hooks.Start /= null then
+ Cell.Hooks.Start.all;
+ end if;
+ Cell := Cell.Next;
+ end loop;
+ end Call_Start_Hooks;
+
+ procedure Call_Finish_Hooks
+ is
+ Cell : Hooks_Cell_Acc;
+ begin
+ Cell := First_Hooks;
+ while Cell /= null loop
+ if Cell.Hooks.Finish /= null then
+ Cell.Hooks.Finish.all;
+ end if;
+ Cell := Cell.Next;
+ end loop;
+ end Call_Finish_Hooks;
+
+ procedure Proc_Hook_Nil is
+ begin
+ null;
+ end Proc_Hook_Nil;
+end Grt.Hooks;
+
+
diff --git a/src/translate/grt/grt-hooks.ads b/src/translate/grt/grt-hooks.ads
new file mode 100644
index 000000000..20846c7f8
--- /dev/null
+++ b/src/translate/grt/grt-hooks.ads
@@ -0,0 +1,70 @@
+-- GHDL Run Time (GRT) - Hooks.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+package Grt.Hooks is
+ pragma Preelaborate (Grt.Hooks);
+
+ type Option_Hook_Type is access function (Opt : String) return Boolean;
+ type Proc_Hook_Type is access procedure;
+
+ type Hooks_Type is record
+ -- Called for every unknown command line argument.
+ -- Return TRUE if handled.
+ Option : Option_Hook_Type;
+
+ -- Display command line help.
+ Help : Proc_Hook_Type;
+
+ -- Called at initialization (after decoding options).
+ Init : Proc_Hook_Type;
+
+ -- Called just after elaboration.
+ Start : Proc_Hook_Type;
+
+ -- Called at the end of execution.
+ Finish : Proc_Hook_Type;
+ end record;
+
+ type Hooks_Acc is access constant Hooks_Type;
+
+ -- Registers hook.
+ procedure Register_Hooks (Hooks : Hooks_Acc);
+
+ -- Register an hook which will call PROC after every non-delta cycles.
+ procedure Register_Cycle_Hook (Proc : Proc_Hook_Type);
+
+ -- Call hooks.
+ function Call_Option_Hooks (Opt : String) return Boolean;
+ procedure Call_Help_Hooks;
+ procedure Call_Init_Hooks;
+ procedure Call_Start_Hooks;
+ procedure Call_Finish_Hooks;
+
+ -- Call non-delta cycles hooks.
+ procedure Call_Cycle_Hooks;
+ pragma Inline_Always (Call_Cycle_Hooks);
+
+ -- Nil procedure.
+ procedure Proc_Hook_Nil;
+end Grt.Hooks;
diff --git a/src/translate/grt/grt-images.adb b/src/translate/grt/grt-images.adb
new file mode 100644
index 000000000..342c98f2a
--- /dev/null
+++ b/src/translate/grt/grt-images.adb
@@ -0,0 +1,387 @@
+-- GHDL Run Time (GRT) - 'image subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Ada.Unchecked_Conversion;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+with Grt.Processes; use Grt.Processes;
+with Grt.Vstrings; use Grt.Vstrings;
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Images is
+ function To_Std_String_Basep is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Std_String_Basep);
+
+ function To_Std_String_Boundp is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Std_String_Boundp);
+
+ procedure Set_String_Bounds (Res : Std_String_Ptr; Len : Ghdl_Index_Type)
+ is
+ begin
+ Res.Bounds := To_Std_String_Boundp
+ (Ghdl_Stack2_Allocate (Std_String_Bound'Size / System.Storage_Unit));
+ Res.Bounds.Dim_1 := (Left => 1,
+ Right => Std_Integer (Len),
+ Dir => Dir_To,
+ Length => Len);
+ end Set_String_Bounds;
+
+ procedure Return_String (Res : Std_String_Ptr; Str : String)
+ is
+ begin
+ Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Str'Length));
+ for I in 0 .. Str'Length - 1 loop
+ Res.Base (Ghdl_Index_Type (I)) := Str (Str'First + I);
+ end loop;
+ Set_String_Bounds (Res, Str'Length);
+ end Return_String;
+
+ procedure Return_Enum
+ (Res : Std_String_Ptr; Rti : Ghdl_Rti_Access; Index : Ghdl_Index_Type)
+ is
+ Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+ Str : Ghdl_C_String;
+ begin
+ Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Str := Enum_Rti.Names (Index);
+ Return_String (Res, Str (1 .. strlen (Str)));
+ end Return_Enum;
+
+ procedure Ghdl_Image_B1
+ (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access)
+ is
+ begin
+ Return_Enum (Res, Rti, Ghdl_B1'Pos (Val));
+ end Ghdl_Image_B1;
+
+ procedure Ghdl_Image_E8
+ (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access)
+ is
+ begin
+ Return_Enum (Res, Rti, Ghdl_E8'Pos (Val));
+ end Ghdl_Image_E8;
+
+ procedure Ghdl_Image_E32
+ (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access)
+ is
+ begin
+ Return_Enum (Res, Rti, Ghdl_E32'Pos (Val));
+ end Ghdl_Image_E32;
+
+ procedure Ghdl_Image_I32 (Res : Std_String_Ptr; Val : Ghdl_I32)
+ is
+ Str : String (1 .. 11);
+ First : Natural;
+ begin
+ To_String (Str, First, Val);
+ Return_String (Res, Str (First .. Str'Last));
+ end Ghdl_Image_I32;
+
+ procedure Ghdl_Image_P64
+ (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access)
+ is
+ Str : String (1 .. 21);
+ First : Natural;
+ Phys : constant Ghdl_Rtin_Type_Physical_Acc
+ := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Unit_Name : Ghdl_C_String;
+ Unit_Len : Natural;
+ begin
+ To_String (Str, First, Val);
+ Unit_Name := Get_Physical_Unit_Name (Phys.Units (0));
+ Unit_Len := strlen (Unit_Name);
+ declare
+ L : constant Natural := Str'Last + 1 - First;
+ Str2 : String (1 .. L + 1 + Unit_Len);
+ begin
+ Str2 (1 .. L) := Str (First .. Str'Last);
+ Str2 (L + 1) := ' ';
+ Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len);
+ Return_String (Res, Str2);
+ end;
+ end Ghdl_Image_P64;
+
+ procedure Ghdl_Image_P32
+ (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access)
+ is
+ Str : String (1 .. 11);
+ First : Natural;
+ Phys : constant Ghdl_Rtin_Type_Physical_Acc
+ := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Unit_Name : Ghdl_C_String;
+ Unit_Len : Natural;
+ begin
+ To_String (Str, First, Val);
+ Unit_Name := Get_Physical_Unit_Name (Phys.Units (0));
+ Unit_Len := strlen (Unit_Name);
+ declare
+ L : constant Natural := Str'Last + 1 - First;
+ Str2 : String (1 .. L + 1 + Unit_Len);
+ begin
+ Str2 (1 .. L) := Str (First .. Str'Last);
+ Str2 (L + 1) := ' ';
+ Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len);
+ Return_String (Res, Str2);
+ end;
+ end Ghdl_Image_P32;
+
+ procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64)
+ is
+ Str : String (1 .. 24);
+ P : Natural;
+ begin
+ To_String (Str, P, Val);
+ Return_String (Res, Str (1 .. P));
+ end Ghdl_Image_F64;
+
+ procedure Ghdl_To_String_I32 (Res : Std_String_Ptr; Val : Ghdl_I32)
+ renames Ghdl_Image_I32;
+ procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64)
+ renames Ghdl_Image_F64;
+
+ procedure Ghdl_To_String_F64_Digits
+ (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32)
+ is
+ Str : String_Real_Digits;
+ P : Natural;
+ begin
+ To_String (Str, P, Val, Nbr_Digits);
+ Return_String (Res, Str (1 .. P));
+ end Ghdl_To_String_F64_Digits;
+
+ procedure Ghdl_To_String_F64_Format
+ (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr)
+ is
+ C_Format : String (1 .. Positive (Format.Bounds.Dim_1.Length + 1));
+ Str : Grt.Vstrings.String_Real_Format;
+ P : Natural;
+ begin
+ for I in 1 .. C_Format'Last - 1 loop
+ C_Format (I) := Format.Base (Ghdl_Index_Type (I - 1));
+ end loop;
+ C_Format (C_Format'Last) := NUL;
+
+ To_String (Str, P, Val, To_Ghdl_C_String (C_Format'Address));
+ Return_String (Res, Str (1 .. P));
+ end Ghdl_To_String_F64_Format;
+
+ subtype Log_Base_Type is Ghdl_Index_Type range 3 .. 4;
+ Hex_Chars : constant array (Natural range 0 .. 15) of Character :=
+ "0123456789ABCDEF";
+
+ procedure Ghdl_BV_To_String (Res : Std_String_Ptr;
+ Val : Std_Bit_Vector_Basep;
+ Len : Ghdl_Index_Type;
+ Log_Base : Log_Base_Type)
+ is
+ Res_Len : constant Ghdl_Index_Type := (Len + Log_Base - 1) / Log_Base;
+ Pos : Ghdl_Index_Type;
+ V : Natural;
+ Sh : Natural range 0 .. 4;
+ begin
+ Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Res_Len));
+ V := 0;
+ Sh := 0;
+ Pos := Res_Len - 1;
+ for I in reverse 1 .. Len loop
+ V := V + Std_Bit'Pos (Val (I - 1)) * (2 ** Sh);
+ Sh := Sh + 1;
+ if Sh = Natural (Log_Base) or else I = 1 then
+ Res.Base (Pos) := Hex_Chars (V);
+ Pos := Pos - 1;
+ Sh := 0;
+ V := 0;
+ end if;
+ end loop;
+ Set_String_Bounds (Res, Res_Len);
+ end Ghdl_BV_To_String;
+
+ procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr;
+ Base : Std_Bit_Vector_Basep;
+ Len : Ghdl_Index_Type) is
+ begin
+ Ghdl_BV_To_String (Res, Base, Len, 3);
+ end Ghdl_BV_To_Ostring;
+
+ procedure Ghdl_BV_To_Hstring (Res : Std_String_Ptr;
+ Base : Std_Bit_Vector_Basep;
+ Len : Ghdl_Index_Type) is
+ begin
+ Ghdl_BV_To_String (Res, Base, Len, 4);
+ end Ghdl_BV_To_Hstring;
+
+ procedure To_String_Enum
+ (Res : Std_String_Ptr; Rti : Ghdl_Rti_Access; Index : Ghdl_Index_Type)
+ is
+ Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+ Str : Ghdl_C_String;
+ begin
+ Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Str := Enum_Rti.Names (Index);
+ if Str (1) = ''' then
+ Return_String (Res, Str (2 .. 2));
+ else
+ Return_String (Res, Str (1 .. strlen (Str)));
+ end if;
+ end To_String_Enum;
+
+ procedure Ghdl_To_String_B1
+ (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access) is
+ begin
+ To_String_Enum (Res, Rti, Ghdl_B1'Pos (Val));
+ end Ghdl_To_String_B1;
+
+ procedure Ghdl_To_String_E8
+ (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access) is
+ begin
+ To_String_Enum (Res, Rti, Ghdl_E8'Pos (Val));
+ end Ghdl_To_String_E8;
+
+ procedure Ghdl_To_String_E32
+ (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access) is
+ begin
+ To_String_Enum (Res, Rti, Ghdl_E32'Pos (Val));
+ end Ghdl_To_String_E32;
+
+ procedure Ghdl_To_String_Char (Res : Std_String_Ptr; Val : Std_Character) is
+ begin
+ Return_String (Res, (1 => Val));
+ end Ghdl_To_String_Char;
+
+ procedure Ghdl_To_String_P32
+ (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access)
+ renames Ghdl_Image_P32;
+
+ procedure Ghdl_To_String_P64
+ (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access)
+ renames Ghdl_Image_P64;
+
+ procedure Ghdl_Time_To_String_Unit
+ (Res : Std_String_Ptr;
+ Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access)
+ is
+ Str : Grt.Vstrings.String_Time_Unit;
+ First : Natural;
+ Phys : constant Ghdl_Rtin_Type_Physical_Acc
+ := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Unit_Name : Ghdl_C_String;
+ Unit_Len : Natural;
+ begin
+ Unit_Name := null;
+ for I in 1 .. Phys.Nbr loop
+ if Get_Physical_Unit_Value (Phys.Units (I - 1), Rti) = Ghdl_I64 (Unit)
+ then
+ Unit_Name := Get_Physical_Unit_Name (Phys.Units (I - 1));
+ exit;
+ end if;
+ end loop;
+ if Unit_Name = null then
+ Error ("no unit for to_string");
+ end if;
+ Grt.Vstrings.To_String (Str, First, Ghdl_I64 (Val), Ghdl_I64 (Unit));
+ Unit_Len := strlen (Unit_Name);
+ declare
+ L : constant Natural := Str'Last + 1 - First;
+ Str2 : String (1 .. L + 1 + Unit_Len);
+ begin
+ Str2 (1 .. L) := Str (First .. Str'Last);
+ Str2 (L + 1) := ' ';
+ Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len);
+ Return_String (Res, Str2);
+ end;
+ end Ghdl_Time_To_String_Unit;
+
+ procedure Ghdl_Array_Char_To_String_B1
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access)
+ is
+ Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc :=
+ To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Str : Ghdl_C_String;
+ Arr : constant Ghdl_B1_Array_Base_Ptr := To_Ghdl_B1_Array_Base_Ptr (Val);
+ begin
+ Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len));
+ for I in 1 .. Len loop
+ Str := Enum_Rti.Names (Ghdl_B1'Pos (Arr (I - 1)));
+ Res.Base (I - 1) := Str (2);
+ end loop;
+ Set_String_Bounds (Res, Len);
+ end Ghdl_Array_Char_To_String_B1;
+
+ procedure Ghdl_Array_Char_To_String_E8
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access)
+ is
+ Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc :=
+ To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Str : Ghdl_C_String;
+ Arr : constant Ghdl_E8_Array_Base_Ptr := To_Ghdl_E8_Array_Base_Ptr (Val);
+ begin
+ Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len));
+ for I in 1 .. Len loop
+ Str := Enum_Rti.Names (Ghdl_E8'Pos (Arr (I - 1)));
+ Res.Base (I - 1) := Str (2);
+ end loop;
+ Set_String_Bounds (Res, Len);
+ end Ghdl_Array_Char_To_String_E8;
+
+ procedure Ghdl_Array_Char_To_String_E32
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access)
+ is
+ Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc :=
+ To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Str : Ghdl_C_String;
+ Arr : constant Ghdl_E32_Array_Base_Ptr :=
+ To_Ghdl_E32_Array_Base_Ptr (Val);
+ begin
+ Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len));
+ for I in 1 .. Len loop
+ Str := Enum_Rti.Names (Ghdl_E32'Pos (Arr (I - 1)));
+ Res.Base (I - 1) := Str (2);
+ end loop;
+ Set_String_Bounds (Res, Len);
+ end Ghdl_Array_Char_To_String_E32;
+
+-- procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64)
+-- is
+-- -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1)
+-- -- + exp_digits (4) -> 24.
+-- Str : String (1 .. 25);
+
+-- procedure Snprintf_G (Str : System.Address;
+-- Size : Integer;
+-- Arg : Ghdl_F64);
+-- pragma Import (C, Snprintf_G, "__ghdl_snprintf_g");
+
+-- function strlen (Str : System.Address) return Integer;
+-- pragma Import (C, strlen);
+-- begin
+-- Snprintf_G (Str'Address, Str'Length, Val);
+-- Return_String (Res, Str (1 .. strlen (Str'Address)));
+-- end Ghdl_Image_F64;
+
+end Grt.Images;
diff --git a/src/translate/grt/grt-images.ads b/src/translate/grt/grt-images.ads
new file mode 100644
index 000000000..cd8911091
--- /dev/null
+++ b/src/translate/grt/grt-images.ads
@@ -0,0 +1,110 @@
+-- GHDL Run Time (GRT) - 'image subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+
+package Grt.Images is
+ -- For all images procedures, the result is allocated on the secondary
+ -- stack.
+
+ procedure Ghdl_Image_B1
+ (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Image_E8
+ (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Image_E32
+ (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Image_I32 (Res : Std_String_Ptr; Val : Ghdl_I32);
+ procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64);
+ procedure Ghdl_Image_P64
+ (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Image_P32
+ (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access);
+
+ procedure Ghdl_To_String_I32 (Res : Std_String_Ptr; Val : Ghdl_I32);
+ procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64);
+ procedure Ghdl_To_String_F64_Digits
+ (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32);
+ procedure Ghdl_To_String_F64_Format
+ (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr);
+ procedure Ghdl_To_String_B1
+ (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_To_String_E8
+ (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_To_String_E32
+ (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_To_String_Char
+ (Res : Std_String_Ptr; Val : Std_Character);
+ procedure Ghdl_To_String_P32
+ (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_To_String_P64
+ (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Time_To_String_Unit
+ (Res : Std_String_Ptr;
+ Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Array_Char_To_String_B1
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Array_Char_To_String_E8
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access);
+ procedure Ghdl_Array_Char_To_String_E32
+ (Res : Std_String_Ptr;
+ Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access);
+
+ procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr;
+ Base : Std_Bit_Vector_Basep;
+ Len : Ghdl_Index_Type);
+ procedure Ghdl_BV_To_Hstring (Res : Std_String_Ptr;
+ Base : Std_Bit_Vector_Basep;
+ Len : Ghdl_Index_Type);
+private
+ pragma Export (Ada, Ghdl_Image_B1, "__ghdl_image_b1");
+ pragma Export (C, Ghdl_Image_E8, "__ghdl_image_e8");
+ pragma Export (C, Ghdl_Image_E32, "__ghdl_image_e32");
+ pragma Export (C, Ghdl_Image_I32, "__ghdl_image_i32");
+ pragma Export (C, Ghdl_Image_F64, "__ghdl_image_f64");
+ pragma Export (C, Ghdl_Image_P64, "__ghdl_image_p64");
+ pragma Export (C, Ghdl_Image_P32, "__ghdl_image_p32");
+
+ pragma Export (C, Ghdl_To_String_I32, "__ghdl_to_string_i32");
+ pragma Export (C, Ghdl_To_String_F64, "__ghdl_to_string_f64");
+ pragma Export (C, Ghdl_To_String_F64_Digits, "__ghdl_to_string_f64_digits");
+ pragma Export (C, Ghdl_To_String_F64_Format, "__ghdl_to_string_f64_format");
+ pragma Export (Ada, Ghdl_To_String_B1, "__ghdl_to_string_b1");
+ pragma Export (C, Ghdl_To_String_E8, "__ghdl_to_string_e8");
+ pragma Export (C, Ghdl_To_String_E32, "__ghdl_to_string_e32");
+ pragma Export (C, Ghdl_To_String_Char, "__ghdl_to_string_char");
+ pragma Export (C, Ghdl_To_String_P32, "__ghdl_to_string_p32");
+ pragma Export (C, Ghdl_To_String_P64, "__ghdl_to_string_p64");
+ pragma Export (C, Ghdl_Time_To_String_Unit, "__ghdl_time_to_string_unit");
+ pragma Export (C, Ghdl_Array_Char_To_String_B1,
+ "__ghdl_array_char_to_string_b1");
+ pragma Export (C, Ghdl_Array_Char_To_String_E8,
+ "__ghdl_array_char_to_string_e8");
+ pragma Export (C, Ghdl_Array_Char_To_String_E32,
+ "__ghdl_array_char_to_string_e32");
+ pragma Export (C, Ghdl_BV_To_Ostring, "__ghdl_bv_to_ostring");
+ pragma Export (C, Ghdl_BV_To_Hstring, "__ghdl_bv_to_hstring");
+end Grt.Images;
diff --git a/src/translate/grt/grt-lib.adb b/src/translate/grt/grt-lib.adb
new file mode 100644
index 000000000..d2b095c67
--- /dev/null
+++ b/src/translate/grt/grt-lib.adb
@@ -0,0 +1,298 @@
+-- GHDL Run Time (GRT) - misc subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+with Grt.Options;
+
+package body Grt.Lib is
+ --procedure Memcpy (Dst : Address; Src : Address; Size : Size_T);
+ --pragma Import (C, Memcpy);
+
+ procedure Ghdl_Memcpy
+ (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type)
+ is
+ procedure Memmove
+ (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type);
+ pragma Import (C, Memmove);
+ begin
+ Memmove (Dest, Src, Size);
+ end Ghdl_Memcpy;
+
+ procedure Do_Report (Msg : String;
+ Str : Std_String_Ptr;
+ Default_Str : String;
+ Severity : Integer;
+ Loc : Ghdl_Location_Ptr)
+ is
+ Level : constant Integer := Severity mod 256;
+ begin
+ Report_H;
+ Report_C (Loc.Filename);
+ Report_C (":");
+ Report_C (Loc.Line);
+ Report_C (":");
+ Report_C (Loc.Col);
+ Report_C (":@");
+ Report_Now_C;
+ Report_C (":(");
+ Report_C (Msg);
+ Report_C (" ");
+ case Level is
+ when Note_Severity =>
+ Report_C ("note");
+ when Warning_Severity =>
+ Report_C ("warning");
+ when Error_Severity =>
+ Report_C ("error");
+ when Failure_Severity =>
+ Report_C ("failure");
+ when others =>
+ Report_C ("???");
+ end case;
+ Report_C ("): ");
+ if Str /= null then
+ Report_E (Str);
+ else
+ Report_E (Default_Str);
+ end if;
+ if Level >= Grt.Options.Severity_Level then
+ Error_C (Msg);
+ Error_E (" failed");
+ end if;
+ end Do_Report;
+
+ procedure Ghdl_Assert_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr)
+ is
+ begin
+ Do_Report ("assertion", Str, "Assertion violation", Severity, Loc);
+ end Ghdl_Assert_Failed;
+
+ procedure Ghdl_Ieee_Assert_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr)
+ is
+ use Grt.Options;
+ begin
+ if Ieee_Asserts = Disable_Asserts
+ or else (Ieee_Asserts = Disable_Asserts_At_Time_0 and Current_Time = 0)
+ then
+ return;
+ else
+ Do_Report ("assertion", Str, "Assertion violation", Severity, Loc);
+ end if;
+ end Ghdl_Ieee_Assert_Failed;
+
+ procedure Ghdl_Psl_Assert_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is
+ begin
+ Do_Report ("psl assertion", Str, "Assertion violation", Severity, Loc);
+ end Ghdl_Psl_Assert_Failed;
+
+ procedure Ghdl_Psl_Cover
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is
+ begin
+ Do_Report ("psl cover", Str, "sequence covered", Severity, Loc);
+ end Ghdl_Psl_Cover;
+
+ procedure Ghdl_Psl_Cover_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is
+ begin
+ Do_Report ("psl cover failure",
+ Str, "sequence not covered", Severity, Loc);
+ end Ghdl_Psl_Cover_Failed;
+
+ procedure Ghdl_Report
+ (Str : Std_String_Ptr;
+ Severity : Integer;
+ Loc : Ghdl_Location_Ptr)
+ is
+ begin
+ Do_Report ("report", Str, "Assertion violation", Severity, Loc);
+ end Ghdl_Report;
+
+ procedure Ghdl_Program_Error (Filename : Ghdl_C_String;
+ Line : Ghdl_I32;
+ Code : Ghdl_Index_Type)
+ is
+ begin
+ case Code is
+ when 1 =>
+ Error_C ("missing return in function");
+ when 2 =>
+ Error_C ("block already configured");
+ when 3 =>
+ Error_C ("bad configuration");
+ when others =>
+ Error_C ("unknown error code ");
+ Error_C (Integer (Code));
+ end case;
+ Error_C (" at ");
+ if Filename = null then
+ Error_C ("*unknown*");
+ else
+ Error_C (Filename);
+ end if;
+ Error_C (":");
+ Error_C (Integer(Line));
+ Error_E ("");
+ end Ghdl_Program_Error;
+
+ procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String;
+ Line: Ghdl_I32)
+ is
+ begin
+ Error_C ("bound check failure at ");
+ Error_C (Filename);
+ Error_C (":");
+ Error_C (Integer (Line));
+ Error_E ("");
+ end Ghdl_Bound_Check_Failed_L1;
+
+ function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32)
+ return Ghdl_I32
+ is
+ pragma Suppress (Overflow_Check);
+
+ R : Ghdl_I32;
+ Res : Ghdl_I32;
+ P : Ghdl_I32;
+ T : Ghdl_I64;
+ begin
+ if E < 0 then
+ Error ("negative exponent");
+ end if;
+ Res := 1;
+ P := V;
+ R := E;
+ loop
+ if R mod 2 = 1 then
+ T := Ghdl_I64 (Res) * Ghdl_I64 (P);
+ Res := Ghdl_I32 (T);
+ if Ghdl_I64 (Res) /= T then
+ Error ("overflow in exponentiation");
+ end if;
+ end if;
+ R := R / 2;
+ exit when R = 0;
+ P := P * P;
+ end loop;
+ return Res;
+ end Ghdl_Integer_Exp;
+
+ function C_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr;
+ pragma Import (C, C_Malloc, "malloc");
+
+ function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr is
+ begin
+ return C_Malloc (Size);
+ end Ghdl_Malloc;
+
+ function Ghdl_Malloc0 (Size : Ghdl_Index_Type) return Ghdl_Ptr
+ is
+ procedure Memset (Ptr : Ghdl_Ptr; C : Integer; Size : Ghdl_Index_Type);
+ pragma Import (C, Memset);
+
+ Res : Ghdl_Ptr;
+ begin
+ Res := C_Malloc (Size);
+ Memset (Res, 0, Size);
+ return Res;
+ end Ghdl_Malloc0;
+
+ procedure Ghdl_Deallocate (Ptr : Ghdl_Ptr)
+ is
+ procedure C_Free (Ptr : Ghdl_Ptr);
+ pragma Import (C, C_Free, "free");
+ begin
+ C_Free (Ptr);
+ end Ghdl_Deallocate;
+
+ function Ghdl_Real_Exp (X : Ghdl_Real; Exp : Ghdl_I32)
+ return Ghdl_Real
+ is
+ R : Ghdl_I32;
+ Res : Ghdl_Real;
+ P : Ghdl_Real;
+ begin
+ Res := 1.0;
+ P := X;
+ R := Exp;
+ if R >= 0 then
+ loop
+ if R mod 2 = 1 then
+ Res := Res * P;
+ end if;
+ R := R / 2;
+ exit when R = 0;
+ P := P * P;
+ end loop;
+ return Res;
+ else
+ R := -R;
+ loop
+ if R mod 2 = 1 then
+ Res := Res * P;
+ end if;
+ R := R / 2;
+ exit when R = 0;
+ P := P * P;
+ end loop;
+ if Res = 0.0 then
+ Error ("division per 0.0");
+ return 0.0;
+ end if;
+ return 1.0 / Res;
+ end if;
+ end Ghdl_Real_Exp;
+
+ function Ghdl_Get_Resolution_Limit return Std_Time is
+ begin
+ return 1;
+ end Ghdl_Get_Resolution_Limit;
+
+ procedure Ghdl_Control_Simulation
+ (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer) is
+ begin
+ Report_H;
+ -- Report_C (Grt.Options.Progname);
+ Report_C ("simulation ");
+ if Stop then
+ Report_C ("stopped");
+ else
+ Report_C ("finished");
+ end if;
+ Report_C (" @");
+ Report_Now_C;
+ if Has_Status then
+ Report_C (" with status ");
+ Report_C (Integer (Status));
+ end if;
+ Report_E ("");
+ if Has_Status then
+ Exit_Status := Integer (Status);
+ end if;
+ Exit_Simulation;
+ end Ghdl_Control_Simulation;
+
+end Grt.Lib;
diff --git a/src/translate/grt/grt-lib.ads b/src/translate/grt/grt-lib.ads
new file mode 100644
index 000000000..4dac2c8d2
--- /dev/null
+++ b/src/translate/grt/grt-lib.ads
@@ -0,0 +1,127 @@
+-- GHDL Run Time (GRT) - misc subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+
+package Grt.Lib is
+ pragma Preelaborate (Grt.Lib);
+
+ procedure Ghdl_Memcpy
+ (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type);
+
+ procedure Ghdl_Assert_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr);
+ procedure Ghdl_Ieee_Assert_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr);
+
+ procedure Ghdl_Psl_Assert_Failed
+ (Str : Std_String_Ptr;
+ Severity : Integer;
+ Loc : Ghdl_Location_Ptr);
+
+ -- Called when a sequence is covered (in a cover directive)
+ procedure Ghdl_Psl_Cover
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr);
+
+ procedure Ghdl_Psl_Cover_Failed
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr);
+
+ procedure Ghdl_Report
+ (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr);
+
+ Note_Severity : constant Integer := 0;
+ Warning_Severity : constant Integer := 1;
+ Error_Severity : constant Integer := 2;
+ Failure_Severity : constant Integer := 3;
+
+ procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String;
+ Line: Ghdl_I32);
+
+ -- Program error has occured:
+ -- * configuration of an already configured block.
+ procedure Ghdl_Program_Error (Filename : Ghdl_C_String;
+ Line : Ghdl_I32;
+ Code : Ghdl_Index_Type);
+
+ function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32)
+ return Ghdl_I32;
+
+ function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr;
+
+ -- Allocate and clear SIZE bytes.
+ function Ghdl_Malloc0 (Size : Ghdl_Index_Type) return Ghdl_Ptr;
+
+ procedure Ghdl_Deallocate (Ptr : Ghdl_Ptr);
+
+ function Ghdl_Real_Exp (X : Ghdl_Real; Exp : Ghdl_I32)
+ return Ghdl_Real;
+
+ type Ghdl_Std_Ulogic_Boolean_Array_Type is array (Ghdl_E8 range 0 .. 8)
+ of Ghdl_B1;
+
+ Ghdl_Std_Ulogic_To_Boolean_Array :
+ constant Ghdl_Std_Ulogic_Boolean_Array_Type := (False, -- U
+ False, -- X
+ False, -- 0
+ True, -- 1
+ False, -- Z
+ False, -- W
+ False, -- L
+ True, -- H
+ False -- -
+ );
+
+ function Ghdl_Get_Resolution_Limit return Std_Time;
+ procedure Ghdl_Control_Simulation
+ (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer);
+private
+ pragma Export (C, Ghdl_Memcpy, "__ghdl_memcpy");
+
+ pragma Export (C, Ghdl_Assert_Failed, "__ghdl_assert_failed");
+ pragma Export (C, Ghdl_Ieee_Assert_Failed, "__ghdl_ieee_assert_failed");
+ pragma Export (C, Ghdl_Psl_Assert_Failed, "__ghdl_psl_assert_failed");
+ pragma Export (C, Ghdl_Psl_Cover, "__ghdl_psl_cover");
+ pragma Export (C, Ghdl_Psl_Cover_Failed, "__ghdl_psl_cover_failed");
+ pragma Export (C, Ghdl_Report, "__ghdl_report");
+
+ pragma Export (C, Ghdl_Bound_Check_Failed_L1,
+ "__ghdl_bound_check_failed_l1");
+ pragma Export (C, Ghdl_Program_Error, "__ghdl_program_error");
+
+ pragma Export (C, Ghdl_Malloc, "__ghdl_malloc");
+ pragma Export (C, Ghdl_Malloc0, "__ghdl_malloc0");
+ pragma Export (C, Ghdl_Deallocate, "__ghdl_deallocate");
+
+ pragma Export (C, Ghdl_Integer_Exp, "__ghdl_integer_exp");
+ pragma Export (C, Ghdl_Real_Exp, "__ghdl_real_exp");
+
+ pragma Export (C, Ghdl_Std_Ulogic_To_Boolean_Array,
+ "__ghdl_std_ulogic_to_boolean_array");
+
+ pragma Export (C, Ghdl_Get_Resolution_Limit,
+ "__ghdl_get_resolution_limit");
+ pragma Export (Ada, Ghdl_Control_Simulation,
+ "__ghdl_control_simulation");
+end Grt.Lib;
diff --git a/src/translate/grt/grt-main.adb b/src/translate/grt/grt-main.adb
new file mode 100644
index 000000000..116ea7b2e
--- /dev/null
+++ b/src/translate/grt/grt-main.adb
@@ -0,0 +1,190 @@
+-- GHDL Run Time (GRT) - entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Types; use Grt.Types;
+with Grt.Errors;
+with Grt.Stacks;
+with Grt.Processes;
+with Grt.Signals;
+with Grt.Options; use Grt.Options;
+with Grt.Stats;
+with Grt.Hooks;
+with Grt.Disp_Signals;
+with Grt.Disp;
+with Grt.Modules;
+
+-- The following packages are not referenced in this package.
+-- These are subprograms called only from GHDL generated code.
+-- They are with'ed in order to be present in the binary.
+pragma Warnings (Off);
+with Grt.Files;
+with Grt.Types;
+with Grt.Lib;
+with Grt.Shadow_Ieee;
+with Grt.Images;
+with Grt.Values;
+with Grt.Names;
+pragma Warnings (On);
+
+package body Grt.Main is
+ procedure Ghdl_Elaborate;
+ pragma Import (C, Ghdl_Elaborate, "__ghdl_ELABORATE");
+
+ -- Wrapper around elaboration just to return 0.
+ function Ghdl_Elaborate_Wrapper return Integer is
+ begin
+ Ghdl_Elaborate;
+ return 0;
+ end Ghdl_Elaborate_Wrapper;
+
+ procedure Disp_Stats_Hook (Code : Integer);
+ pragma Convention (C, Disp_Stats_Hook);
+
+ procedure Disp_Stats_Hook (Code : Integer)
+ is
+ pragma Unreferenced (Code);
+ begin
+ Stats.End_Simulation;
+ Stats.Disp_Stats;
+ end Disp_Stats_Hook;
+
+ procedure Check_Flag_String
+ is
+ Err : Boolean;
+ begin
+ -- The conditions may be statically known.
+ pragma Warnings (Off);
+
+ Err := False;
+ if (Std_Integer'Size = 32 and Flag_String (3) /= 'i')
+ or else (Std_Integer'Size = 64 and Flag_String (3) /= 'I')
+ then
+ Err := True;
+ end if;
+ if (Std_Time'Size = 32 and Flag_String (4) /= 't')
+ or else (Std_Time'Size = 64 and Flag_String (4) /= 'T')
+ then
+ Err := True;
+ end if;
+
+ pragma Warnings (On);
+
+ if Err then
+ Grt.Errors.Error
+ ("GRT is not consistent with the flags used for your design");
+ end if;
+ end Check_Flag_String;
+
+ procedure Run
+ is
+ use Grt.Errors;
+ Stop : Boolean;
+ Status : Integer;
+ begin
+ -- Register modules.
+ -- They may insert hooks.
+ Grt.Modules.Register_Modules;
+
+ -- If the time resolution is to be set by the user, select a default
+ -- resolution. Options may override it.
+ if Flag_String (5) = '?' then
+ Set_Time_Resolution ('n');
+ end if;
+
+ -- Decode options.
+ Grt.Options.Decode (Stop);
+
+ -- Check coherency between GRT and GHDL generated code.
+ Check_Flag_String;
+
+ -- Early stop (for options such as --help).
+ if Stop then
+ return;
+ end if;
+
+ -- Internal initializations.
+ Grt.Stacks.Stack_Init;
+
+ Grt.Hooks.Call_Init_Hooks;
+
+ Grt.Processes.Init;
+
+ Grt.Signals.Init;
+
+ if Flag_Stats then
+ Stats.Start_Elaboration;
+ end if;
+
+ -- Elaboration. Run through longjump to catch errors.
+ if Grt.Processes.Run_Through_Longjump (Ghdl_Elaborate_Wrapper'Access) < 0
+ then
+ Grt.Errors.Error ("error during elaboration");
+ return;
+ end if;
+
+ if Flag_Stats then
+ Stats.Start_Order;
+ end if;
+
+ Grt.Hooks.Call_Start_Hooks;
+
+ if not Flag_No_Run then
+ Grt.Signals.Order_All_Signals;
+
+ if Grt.Options.Disp_Signals_Map then
+ Grt.Disp_Signals.Disp_Signals_Map;
+ end if;
+ if Grt.Options.Disp_Signals_Table then
+ Grt.Disp_Signals.Disp_Signals_Table;
+ end if;
+ if Disp_Signals_Order then
+ Grt.Disp.Disp_Signals_Order;
+ end if;
+ if Disp_Sensitivity then
+ Grt.Disp_Signals.Disp_All_Sensitivity;
+ end if;
+
+ -- Do the simulation.
+ Status := Grt.Processes.Simulation;
+ end if;
+
+ if Flag_Stats then
+ Disp_Stats_Hook (0);
+ end if;
+
+ if Expect_Failure then
+ if Status >= 0 then
+ Expect_Failure := False;
+ Error ("error expected, but none occured");
+ end if;
+ else
+ if Status < 0 then
+ Error ("simulation failed");
+ end if;
+ end if;
+ end Run;
+
+end Grt.Main;
diff --git a/src/translate/grt/grt-main.ads b/src/translate/grt/grt-main.ads
new file mode 100644
index 000000000..4f78477f2
--- /dev/null
+++ b/src/translate/grt/grt-main.ads
@@ -0,0 +1,29 @@
+-- GHDL Run Time (GRT) - entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package Grt.Main is
+ -- Elaborate and simulate the design.
+ procedure Run;
+end Grt.Main;
diff --git a/src/translate/grt/grt-modules.adb b/src/translate/grt/grt-modules.adb
new file mode 100644
index 000000000..e5304f04d
--- /dev/null
+++ b/src/translate/grt/grt-modules.adb
@@ -0,0 +1,47 @@
+-- GHDL Run Time (GRT) - Modules.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Vcd;
+with Grt.Vcdz;
+with Grt.Vpi;
+with Grt.Waves;
+with Grt.Vital_Annotate;
+with Grt.Disp_Tree;
+with Grt.Disp_Rti;
+
+package body Grt.Modules is
+ procedure Register_Modules is
+ begin
+ -- List of modules to be registered.
+ Grt.Disp_Tree.Register;
+ Grt.Vcd.Register;
+ Grt.Vcdz.Register;
+ Grt.Waves.Register;
+ Grt.Vpi.Register;
+ Grt.Vital_Annotate.Register;
+ Grt.Disp_Rti.Register;
+ end Register_Modules;
+end Grt.Modules;
diff --git a/src/translate/grt/grt-modules.ads b/src/translate/grt/grt-modules.ads
new file mode 100644
index 000000000..23c7d6e7a
--- /dev/null
+++ b/src/translate/grt/grt-modules.ads
@@ -0,0 +1,29 @@
+-- GHDL Run Time (GRT) - Modules.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package Grt.Modules is
+ -- Register optional modules.
+ procedure Register_Modules;
+end Grt.Modules;
diff --git a/src/translate/grt/grt-names.adb b/src/translate/grt/grt-names.adb
new file mode 100644
index 000000000..e7928f75c
--- /dev/null
+++ b/src/translate/grt/grt-names.adb
@@ -0,0 +1,105 @@
+-- GHDL Run Time (GRT) - 'name* subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+--with Grt.Errors; use Grt.Errors;
+with Ada.Unchecked_Conversion;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Processes; use Grt.Processes;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Rtis_Utils; use Grt.Rtis_Utils;
+with Grt.Vstrings; use Grt.Vstrings;
+
+package body Grt.Names is
+ function To_Str_String_Boundp is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Std_String_Boundp);
+
+ function To_Std_String_Basep is new Ada.Unchecked_Conversion
+ (Source => String_Ptr, Target => Std_String_Basep);
+
+ function To_Std_String_Basep is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Std_String_Basep);
+
+ procedure Get_Name (Res : Std_String_Ptr;
+ Ctxt : Rti_Context;
+ Name : Ghdl_Str_Len_Ptr;
+ Is_Path : Boolean)
+ is
+ procedure Memcpy (Dst : Address; Src : Address; Len : Integer);
+ pragma Import (C, Memcpy);
+
+ Bounds : Std_String_Boundp;
+ Len : Natural;
+
+ Rstr : Rstring;
+ R_Len : Natural;
+ begin
+ if Ctxt.Block /= null then
+ Prepend (Rstr, ':');
+ Get_Path_Name (Rstr, Ctxt, ':', not Is_Path);
+ R_Len := Length (Rstr);
+ Len := R_Len + Name.Len;
+ else
+ Len := Name.Len;
+ end if;
+
+ Bounds := To_Str_String_Boundp
+ (Ghdl_Stack2_Allocate (Std_String_Bound'Size / System.Storage_Unit));
+ Bounds.Dim_1.Left := 1;
+ Bounds.Dim_1.Right := Ghdl_I32 (Len);
+ Bounds.Dim_1.Dir := Dir_To;
+ Bounds.Dim_1.Length := Ghdl_Index_Type (Len);
+ Res.Bounds := Bounds;
+ if Ctxt.Block /= null then
+ Res.Base := To_Std_String_Basep
+ (Ghdl_Stack2_Allocate (Ghdl_Index_Type (Len)));
+ Memcpy (Res.Base (0)'Address, Get_Address (Rstr), R_Len);
+ Memcpy (Res.Base (Ghdl_Index_Type (R_Len))'Address,
+ Name.Str (1)'Address,
+ Name.Len);
+ Free (Rstr);
+ else
+ Res.Base := To_Std_String_Basep (Name.Str);
+ end if;
+ end Get_Name;
+
+ procedure Ghdl_Get_Path_Name (Res : Std_String_Ptr;
+ Ctxt : Ghdl_Rti_Access;
+ Base : Address;
+ Name : Ghdl_Str_Len_Ptr)
+ is
+ begin
+ Get_Name (Res, (Base, Ctxt), Name, True);
+ end Ghdl_Get_Path_Name;
+
+ procedure Ghdl_Get_Instance_Name (Res : Std_String_Ptr;
+ Ctxt : Ghdl_Rti_Access;
+ Base : Address;
+ Name : Ghdl_Str_Len_Ptr)
+ is
+ begin
+ Get_Name (Res, (Base, Ctxt), Name, False);
+ end Ghdl_Get_Instance_Name;
+
+end Grt.Names;
diff --git a/src/translate/grt/grt-names.ads b/src/translate/grt/grt-names.ads
new file mode 100644
index 000000000..e0c284231
--- /dev/null
+++ b/src/translate/grt/grt-names.ads
@@ -0,0 +1,42 @@
+-- GHDL Run Time (GRT) - 'name* subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+
+package Grt.Names is
+ procedure Ghdl_Get_Path_Name (Res : Std_String_Ptr;
+ Ctxt : Ghdl_Rti_Access;
+ Base : Address;
+ Name : Ghdl_Str_Len_Ptr);
+
+ procedure Ghdl_Get_Instance_Name (Res : Std_String_Ptr;
+ Ctxt : Ghdl_Rti_Access;
+ Base : Address;
+ Name : Ghdl_Str_Len_Ptr);
+private
+ pragma Export (C, Ghdl_Get_Path_Name, "__ghdl_get_path_name");
+ pragma Export (C, Ghdl_Get_Instance_Name, "__ghdl_get_instance_name");
+end Grt.Names;
diff --git a/src/translate/grt/grt-options.adb b/src/translate/grt/grt-options.adb
new file mode 100644
index 000000000..df1eb4ec8
--- /dev/null
+++ b/src/translate/grt/grt-options.adb
@@ -0,0 +1,507 @@
+-- GHDL Run Time (GRT) - command line options.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Interfaces; use Interfaces;
+with Grt.Errors; use Grt.Errors;
+with Grt.Astdio;
+with Grt.Hooks;
+
+package body Grt.Options is
+
+ Std_Standard_Time_Fs : Std_Time;
+ Std_Standard_Time_Ps : Std_Time;
+ Std_Standard_Time_Ns : Std_Time;
+ Std_Standard_Time_Us : Std_Time;
+ Std_Standard_Time_Ms : Std_Time;
+ Std_Standard_Time_Sec : Std_Time;
+ Std_Standard_Time_Min : Std_Time;
+ Std_Standard_Time_Hr : Std_Time;
+ pragma Export (C, Std_Standard_Time_Fs, "std__standard__time__BT__fs");
+ pragma Weak_External (Std_Standard_Time_Fs);
+ pragma Export (C, Std_Standard_Time_Ps, "std__standard__time__BT__ps");
+ pragma Weak_External (Std_Standard_Time_Ps);
+ pragma Export (C, Std_Standard_Time_Ns, "std__standard__time__BT__ns");
+ pragma Weak_External (Std_Standard_Time_Ns);
+ pragma Export (C, Std_Standard_Time_Us, "std__standard__time__BT__us");
+ pragma Weak_External (Std_Standard_Time_Us);
+ pragma Export (C, Std_Standard_Time_Ms, "std__standard__time__BT__ms");
+ pragma Weak_External (Std_Standard_Time_Ms);
+ pragma Export (C, Std_Standard_Time_Sec, "std__standard__time__BT__sec");
+ pragma Weak_External (Std_Standard_Time_Sec);
+ pragma Export (C, Std_Standard_Time_Min, "std__standard__time__BT__min");
+ pragma Weak_External (Std_Standard_Time_Min);
+ pragma Export (C, Std_Standard_Time_Hr, "std__standard__time__BT__hr");
+ pragma Weak_External (Std_Standard_Time_Hr);
+
+ procedure Set_Time_Resolution (Res : Character)
+ is
+ begin
+ Std_Standard_Time_Hr := 0;
+ case Res is
+ when 'f' =>
+ Std_Standard_Time_Fs := 1;
+ Std_Standard_Time_Ps := 1000;
+ Std_Standard_Time_Ns := 1000_000;
+ Std_Standard_Time_Us := 1000_000_000;
+ Std_Standard_Time_Ms := Std_Time'Last;
+ Std_Standard_Time_Sec := Std_Time'Last;
+ Std_Standard_Time_Min := Std_Time'Last;
+ Std_Standard_Time_Hr := Std_Time'Last;
+ when 'p' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 1;
+ Std_Standard_Time_Ns := 1000;
+ Std_Standard_Time_Us := 1000_000;
+ Std_Standard_Time_Ms := 1000_000_000;
+ Std_Standard_Time_Sec := Std_Time'Last;
+ Std_Standard_Time_Min := Std_Time'Last;
+ Std_Standard_Time_Hr := Std_Time'Last;
+ when 'n' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 1;
+ Std_Standard_Time_Us := 1000;
+ Std_Standard_Time_Ms := 1000_000;
+ Std_Standard_Time_Sec := 1000_000_000;
+ Std_Standard_Time_Min := Std_Time'Last;
+ Std_Standard_Time_Hr := Std_Time'Last;
+ when 'u' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 0;
+ Std_Standard_Time_Us := 1;
+ Std_Standard_Time_Ms := 1000;
+ Std_Standard_Time_Sec := 1000_000;
+ Std_Standard_Time_Min := 60_000_000;
+ Std_Standard_Time_Hr := Std_Time'Last;
+ when 'm' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 0;
+ Std_Standard_Time_Us := 0;
+ Std_Standard_Time_Ms := 1;
+ Std_Standard_Time_Sec := 1000;
+ Std_Standard_Time_Min := 60_000;
+ Std_Standard_Time_Hr := 3600_000;
+ when 's' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 0;
+ Std_Standard_Time_Us := 0;
+ Std_Standard_Time_Ms := 0;
+ Std_Standard_Time_Sec := 1;
+ Std_Standard_Time_Min := 60;
+ Std_Standard_Time_Hr := 3600;
+ when 'M' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 0;
+ Std_Standard_Time_Us := 0;
+ Std_Standard_Time_Ms := 0;
+ Std_Standard_Time_Sec := 0;
+ Std_Standard_Time_Min := 1;
+ Std_Standard_Time_Hr := 60;
+ when 'h' =>
+ Std_Standard_Time_Fs := 0;
+ Std_Standard_Time_Ps := 0;
+ Std_Standard_Time_Ns := 0;
+ Std_Standard_Time_Us := 0;
+ Std_Standard_Time_Ms := 0;
+ Std_Standard_Time_Sec := 0;
+ Std_Standard_Time_Min := 0;
+ Std_Standard_Time_Hr := 1;
+ when others =>
+ Error ("bad time resolution");
+ end case;
+ end Set_Time_Resolution;
+
+ procedure Help
+ is
+ use Grt.Astdio;
+ procedure P (Str : String) renames Put_Line;
+ Prog_Name : Ghdl_C_String;
+ begin
+ if Argc > 0 then
+ Prog_Name := Argv (0);
+ Put ("Usage: ");
+ Put (Prog_Name (1 .. strlen (Prog_Name)));
+ Put (" [OPTIONS]");
+ New_Line;
+ end if;
+
+ P ("Options are:");
+ P (" --help, -h disp this help");
+ P (" --assert-level=LEVEL stop simulation if assert at LEVEL");
+ P (" LEVEL is note,warning,error,failure,none");
+ P (" --ieee-asserts=POLICY enable or disable asserts from IEEE");
+ P (" POLICY is enable,disable,disable-at-0");
+ P (" --stop-time=X stop the simulation at time X");
+ P (" X is expressed as a time value, without spaces: 1ns, ps...");
+ P (" --stop-delta=X stop the simulation cycle after X delta");
+ P (" --expect-failure invert exit status");
+ P (" --stack-size=X set the stack size of non-sensitized processes");
+ P (" --stack-max-size=X set the maximum stack size");
+ P (" --no-run do not simulate, only elaborate");
+ -- P (" --threads=N use N threads for simulation");
+ Grt.Hooks.Call_Help_Hooks;
+ P ("trace options:");
+ P (" --disp-time disp time as simulation advances");
+ P (" --trace-signals disp signals after each cycle");
+ P (" --trace-processes disp process name before each cycle");
+ P (" --stats display run-time statistics");
+ P ("debug options:");
+ P (" --disp-order disp signals order");
+ P (" --disp-sources disp sources while displaying signals");
+ P (" --disp-sig-types disp signal types");
+ P (" --disp-signals-map disp map bw declared sigs and internal sigs");
+ P (" --disp-signals-table disp internal signals");
+ P (" --checks do internal checks after each process run");
+ P (" --activity=LEVEL watch activity of LEVEL signals");
+ P (" LEVEL is all, min (default) or none (unsafe)");
+ end Help;
+
+ -- Extract from STR a number.
+ -- First, all leading blanks are skipped.
+ -- Then, all next digits are eaten.
+ -- The position of the first non digit or one past the upper bound is
+ -- returned into POS.
+ -- If there is no digits, OK is set to false, else to true.
+ procedure Extract_Integer
+ (Str : String;
+ Ok : out Boolean;
+ Result : out Integer_64;
+ Pos : out Natural)
+ is
+ begin
+ Pos := Str'First;
+ -- Skip blanks.
+ while Pos <= Str'Last and then Str (Pos) = ' ' loop
+ Pos := Pos + 1;
+ end loop;
+ Ok := False;
+ Result := 0;
+ loop
+ exit when Pos > Str'Last or else Str (Pos) not in '0' .. '9';
+ Ok := True;
+ Result := Result * 10
+ + (Character'Pos (Str (Pos)) - Character'Pos ('0'));
+ Pos := Pos + 1;
+ end loop;
+ end Extract_Integer;
+
+ function Extract_Size (Str : String; Option_Name : String) return Natural
+ is
+ Ok : Boolean;
+ Val : Integer_64;
+ Pos : Natural;
+ begin
+ Extract_Integer (Str, Ok, Val, Pos);
+ if not Ok then
+ Val := 1;
+ end if;
+ if Pos > Str'Last then
+ -- No suffix.
+ if Val > Integer_64(Natural'Last) then
+ Error_C ("Size exceeds limit for option ");
+ Error_E (Option_Name);
+ else
+ return Natural (Val);
+ end if;
+ end if;
+ if Pos = Str'Last
+ or else (Pos + 1 = Str'Last
+ and then (Str (Pos + 1) = 'b' or Str (Pos + 1) = 'o'))
+ then
+ if Str (Pos) = 'k' or Str (Pos) = 'K' then
+ return Natural (Val) * 1024;
+ elsif Str (Pos) = 'm' or Str (Pos) = 'M' then
+ return Natural (Val) * 1024 * 1024;
+ end if;
+ end if;
+ Error_C ("bad memory unit for option ");
+ Error_E (Option_Name);
+ end Extract_Size;
+
+ function To_Lower (C : Character) return Character is
+ begin
+ if C in 'A' .. 'Z' then
+ return Character'Val (Character'Pos (C) + 32);
+ else
+ return C;
+ end if;
+ end To_Lower;
+
+ procedure Decode_Option
+ (Option : String; Status : out Decode_Option_Status)
+ is
+ pragma Assert (Option'First = 1);
+ Len : constant Natural := Option'Last;
+ begin
+ Status := Decode_Option_Ok;
+ if Option = "--" then
+ Status := Decode_Option_Last;
+ elsif Option = "--help" or else Option = "-h" then
+ Help;
+ Status := Decode_Option_Help;
+ elsif Option = "--disp-time" then
+ Disp_Time := True;
+ elsif Option = "--trace-signals" then
+ Trace_Signals := True;
+ Disp_Time := True;
+ elsif Option = "--trace-processes" then
+ Trace_Processes := True;
+ Disp_Time := True;
+ elsif Option = "--disp-order" then
+ Disp_Signals_Order := True;
+ elsif Option = "--checks" then
+ Checks := True;
+ elsif Option = "--disp-sources" then
+ Disp_Sources := True;
+ elsif Option = "--disp-sig-types" then
+ Disp_Sig_Types := True;
+ elsif Option = "--disp-signals-map" then
+ Disp_Signals_Map := True;
+ elsif Option = "--disp-signals-table" then
+ Disp_Signals_Table := True;
+ elsif Option = "--disp-sensitivity" then
+ Disp_Sensitivity := True;
+ elsif Option = "--stats" then
+ Flag_Stats := True;
+ elsif Option = "--no-run" then
+ Flag_No_Run := True;
+ elsif Len > 18 and then Option (1 .. 18) = "--time-resolution=" then
+ declare
+ Res : Character;
+ Unit : String (1 .. 3);
+ begin
+ Res := '?';
+ if Len >= 20 then
+ Unit (1) := To_Lower (Option (19));
+ Unit (2) := To_Lower (Option (20));
+ if Len = 20 then
+ if Unit (1 .. 2) = "fs" then
+ Res := 'f';
+ elsif Unit (1 .. 2) = "ps" then
+ Res := 'p';
+ elsif Unit (1 .. 2) = "ns" then
+ Res := 'n';
+ elsif Unit (1 .. 2) = "us" then
+ Res := 'u';
+ elsif Unit (1 .. 2) = "ms" then
+ Res := 'm';
+ elsif Unit (1 .. 2) = "hr" then
+ Res := 'h';
+ end if;
+ elsif Len = 21 then
+ Unit (3) := To_Lower (Option (21));
+ if Unit = "min" then
+ Res := 'M';
+ elsif Unit = "sec" then
+ Res := 's';
+ end if;
+ end if;
+ end if;
+ if Res = '?' then
+ Error_C ("bad unit for '");
+ Error_C (Option);
+ Error_E ("'");
+ else
+ if Flag_String (5) = '-' then
+ Error ("time resolution is ignored");
+ elsif Flag_String (5) = '?' then
+ if Stop_Time /= Std_Time'Last then
+ Error ("time resolution must be set "
+ & "before --stop-time");
+ else
+ Set_Time_Resolution (Res);
+ end if;
+ elsif Flag_String (5) /= Res then
+ Error ("time resolution is fixed during analysis");
+ end if;
+ end if;
+ end;
+ elsif Len > 12 and then Option (1 .. 12) = "--stop-time=" then
+ declare
+ Ok : Boolean;
+ Pos : Natural;
+ Time : Integer_64;
+ Unit : String (1 .. 3);
+ begin
+ Extract_Integer (Option (13 .. Len), Ok, Time, Pos);
+ if not Ok then
+ Time := 1;
+ end if;
+ if (Len - Pos + 1) not in 2 .. 3 then
+ Error_C ("bad unit for '");
+ Error_C (Option);
+ Error_E ("'");
+ return;
+ end if;
+ Unit (1) := To_Lower (Option (Pos));
+ Unit (2) := To_Lower (Option (Pos + 1));
+ if Len = Pos + 2 then
+ Unit (3) := To_Lower (Option (Pos + 2));
+ else
+ Unit (3) := ' ';
+ end if;
+ if Unit = "fs " then
+ null;
+ elsif Unit = "ps " then
+ Time := Time * (10 ** 3);
+ elsif Unit = "ns " then
+ Time := Time * (10 ** 6);
+ elsif Unit = "us " then
+ Time := Time * (10 ** 9);
+ elsif Unit = "ms " then
+ Time := Time * (10 ** 12);
+ elsif Unit = "sec" then
+ Time := Time * (10 ** 15);
+ elsif Unit = "min" then
+ Time := Time * (10 ** 15) * 60;
+ elsif Unit = "hr " then
+ Time := Time * (10 ** 15) * 3600;
+ else
+ Error_C ("bad unit name for '");
+ Error_C (Option);
+ Error_E ("'");
+ end if;
+ Stop_Time := Std_Time (Time);
+ end;
+ elsif Len > 13 and then Option (1 .. 13) = "--stop-delta=" then
+ declare
+ Ok : Boolean;
+ Pos : Natural;
+ Time : Integer_64;
+ begin
+ Extract_Integer (Option (14 .. Len), Ok, Time, Pos);
+ if not Ok or else Pos <= Len then
+ Error_C ("bad value in '");
+ Error_C (Option);
+ Error_E ("'");
+ else
+ if Time > Integer_64 (Integer'Last) then
+ Stop_Delta := Integer'Last;
+ else
+ Stop_Delta := Integer (Time);
+ end if;
+ end if;
+ end;
+ elsif Len > 15 and then Option (1 .. 15) = "--assert-level=" then
+ if Option (16 .. Len) = "note" then
+ Severity_Level := Note_Severity;
+ elsif Option (16 .. Len) = "warning" then
+ Severity_Level := Warning_Severity;
+ elsif Option (16 .. Len) = "error" then
+ Severity_Level := Error_Severity;
+ elsif Option (16 .. Len) = "failure" then
+ Severity_Level := Failure_Severity;
+ elsif Option (16 .. Len) = "none" then
+ Severity_Level := 4;
+ else
+ Error ("bad argument for --assert-level option, try --help");
+ end if;
+ elsif Len > 15 and then Option (1 .. 15) = "--ieee-asserts=" then
+ if Option (16 .. Len) = "disable" then
+ Ieee_Asserts := Disable_Asserts;
+ elsif Option (16 .. Len) = "enable" then
+ Ieee_Asserts := Enable_Asserts;
+ elsif Option (16 .. Len) = "disable-at-0" then
+ Ieee_Asserts := Disable_Asserts_At_Time_0;
+ else
+ Error ("bad argument for --ieee-asserts option, try --help");
+ end if;
+ elsif Option = "--expect-failure" then
+ Expect_Failure := True;
+ elsif Len >= 13 and then Option (1 .. 13) = "--stack-size=" then
+ Stack_Size := Extract_Size
+ (Option (14 .. Len), "--stack-size");
+ if Stack_Size > Stack_Max_Size then
+ Stack_Max_Size := Stack_Size;
+ end if;
+ elsif Len >= 17 and then Option (1 .. 17) = "--stack-max-size=" then
+ Stack_Max_Size := Extract_Size
+ (Option (18 .. Len), "--stack-size");
+ if Stack_Size > Stack_Max_Size then
+ Stack_Size := Stack_Max_Size;
+ end if;
+ elsif Len >= 11 and then Option (1 .. 11) = "--activity=" then
+ if Option (12 .. Len) = "none" then
+ Flag_Activity := Activity_None;
+ elsif Option (12 .. Len) = "min" then
+ Flag_Activity := Activity_Minimal;
+ elsif Option (12 .. Len) = "all" then
+ Flag_Activity := Activity_All;
+ else
+ Error ("bad argument for --activity, try --help");
+ end if;
+ elsif Len > 10 and then Option (1 .. 10) = "--threads=" then
+ declare
+ Ok : Boolean;
+ Pos : Natural;
+ Val : Integer_64;
+ begin
+ Extract_Integer (Option (11 .. Len), Ok, Val, Pos);
+ if not Ok or else Pos <= Len then
+ Error_C ("bad value in '");
+ Error_C (Option);
+ Error_E ("'");
+ else
+ Nbr_Threads := Integer (Val);
+ end if;
+ end;
+ elsif not Grt.Hooks.Call_Option_Hooks (Option) then
+ Error_C ("unknown option '");
+ Error_C (Option);
+ Error_E ("', try --help");
+ end if;
+ end Decode_Option;
+
+ procedure Decode (Stop : out Boolean)
+ is
+ Arg : Ghdl_C_String;
+ Len : Natural;
+ Status : Decode_Option_Status;
+ begin
+ Stop := False;
+ Last_Opt := Argc - 1;
+ for I in 1 .. Argc - 1 loop
+ Arg := Argv (I);
+ Len := strlen (Arg);
+ declare
+ Argument : constant String := Arg (1 .. Len);
+ begin
+ Decode_Option (Argument, Status);
+ case Status is
+ when Decode_Option_Last =>
+ Last_Opt := I;
+ exit;
+ when Decode_Option_Help =>
+ Stop := True;
+ when Decode_Option_Ok =>
+ null;
+ end case;
+ end;
+ end loop;
+ end Decode;
+end Grt.Options;
diff --git a/src/translate/grt/grt-options.ads b/src/translate/grt/grt-options.ads
new file mode 100644
index 000000000..88b1f5084
--- /dev/null
+++ b/src/translate/grt/grt-options.ads
@@ -0,0 +1,154 @@
+-- GHDL Run Time (GRT) - command line options.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Lib; use Grt.Lib;
+
+package Grt.Options is
+ pragma Preelaborate (Grt.Options);
+
+ -- Name of the program, set by argv[0].
+ -- Must be set before calling DECODE.
+ Progname : Ghdl_C_String;
+
+ -- Arguments.
+ -- This mimics argc/argv of 'main'.
+ -- These must be set before calling DECODE.
+ Argc : Integer;
+
+ type Argv_Array_Type is array (Natural) of Ghdl_C_String;
+ type Argv_Type is access Argv_Array_Type;
+
+ Argv : Argv_Type;
+
+ -- Last option decoded.
+ -- Following arguments are reserved for the program.
+ Last_Opt : Integer;
+
+ -- Consistent flags used for analysis.
+ -- Format is "VVitr", where:
+ -- 'VV' is the version (87, 93 or 08).
+ -- 'i' is the integer size ('i' for 32 bits, 'I' for 64 bits).
+ -- 't' is the time size ('t' for 32 bits, 'T' for 64 bits).
+ -- 'r' is the resolution ('?' for to be set by the user, '-' for any).
+ Flag_String : constant String (1 .. 5);
+ pragma Import (C, Flag_String, "__ghdl_flag_string");
+
+ -- Display options help.
+ -- Should not be called directly.
+ procedure Help;
+
+ -- Status from Decode_Option.
+ type Decode_Option_Status is
+ (
+ -- Last option, next arguments aren't options.
+ Decode_Option_Last,
+
+ -- --help option, program shouldn't run.
+ Decode_Option_Help,
+
+ -- Option was successfuly decoded.
+ Decode_Option_Ok);
+
+ -- Decode option Option and set Status.
+ procedure Decode_Option
+ (Option : String; Status : out Decode_Option_Status);
+
+ -- Decode command line options.
+ -- If STOP is true, there nothing must happen (set by --help).
+ procedure Decode (Stop : out Boolean);
+
+ -- Set by --disp-time (and --trace-signals, --trace-processes) to display
+ -- time and deltas.
+ Disp_Time : Boolean := False;
+
+ -- Set by --trace-signals, to display signals after each cycle.
+ Trace_Signals : Boolean := False;
+
+ -- Set by --trace-processes, to display process name before being run.
+ Trace_Processes : Boolean := False;
+
+ -- Set by --disp-sig-types, to display signals and they types.
+ Disp_Sig_Types : Boolean := False;
+
+ Disp_Sources : Boolean := False;
+ Disp_Signals_Map : Boolean := False;
+ Disp_Signals_Table : Boolean := False;
+ Disp_Sensitivity : Boolean := False;
+
+ -- Set by --disp-order to diplay evaluation order of signals.
+ Disp_Signals_Order : Boolean := False;
+
+ -- Set by --stats to display statistics.
+ Flag_Stats : Boolean := False;
+
+ -- Set by --checks to do internal checks.
+ Checks : Boolean := False;
+
+ -- Level at which an assert stop the simulation.
+ Severity_Level : Integer := Failure_Severity;
+
+ -- How assertions are handled.
+ type Assert_Handling is
+ (Enable_Asserts,
+ Disable_Asserts_At_Time_0,
+ Disable_Asserts);
+
+ -- Handling of assertions from IEEE library.
+ Ieee_Asserts : Assert_Handling := Enable_Asserts;
+
+ -- Set by --stop-time=XXX to stop the simulation at or just after XXX.
+ -- (unit is fs in fact).
+ Stop_Time : Std_Time := Std_Time'Last;
+
+ -- Set by --stop-delta=XXX to stop the simulation after XXX delta cycles.
+ Stop_Delta : Natural := 5000;
+
+ -- The default stack size for non-sensitized processes.
+ Stack_Size : Natural := 8 * 1024;
+
+ -- The maximum stack size for non-sensitized processes.
+ Stack_Max_Size : Natural := 128 * 1024;
+
+ -- Set by --no-run
+ -- If set, do not simulate, only elaborate.
+ Flag_No_Run : Boolean := False;
+
+ type Activity_Mode is (Activity_All, Activity_Minimal, Activity_None);
+ Flag_Activity : Activity_Mode := Activity_Minimal;
+
+ -- Set by --thread=
+ -- Number of threads used to do the simulation.
+ -- 1 mean no additionnal threads, 0 means as many threads as number of
+ -- CPUs.
+ Nbr_Threads : Natural := 1;
+
+ -- Set the time resolution.
+ -- Only call this subprogram if you are allowed to set the time resolution.
+ procedure Set_Time_Resolution (Res : Character);
+private
+ pragma Export (C, Stack_Size);
+ pragma Export (C, Stack_Max_Size);
+ pragma Export (C, Nbr_Threads, "grt_nbr_threads");
+end Grt.Options;
diff --git a/src/translate/grt/grt-processes.adb b/src/translate/grt/grt-processes.adb
new file mode 100644
index 000000000..64db682e2
--- /dev/null
+++ b/src/translate/grt/grt-processes.adb
@@ -0,0 +1,1042 @@
+-- GHDL Run Time (GRT) - processes.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Table;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Disp;
+with Grt.Astdio;
+with Grt.Errors; use Grt.Errors;
+with Grt.Options;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Rtis_Utils;
+with Grt.Hooks;
+with Grt.Disp_Signals;
+with Grt.Stats;
+with Grt.Threads; use Grt.Threads;
+pragma Elaborate_All (Grt.Table);
+
+package body Grt.Processes is
+ Last_Time : constant Std_Time := Std_Time'Last;
+
+ -- Identifier for a process.
+ type Process_Id is new Integer;
+
+ -- Table of processes.
+ package Process_Table is new Grt.Table
+ (Table_Component_Type => Process_Acc,
+ Table_Index_Type => Process_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 16);
+
+ type Finalizer_Type is record
+ -- Subprogram containing process code.
+ Subprg : Proc_Acc;
+
+ -- Instance (THIS parameter) for the subprogram.
+ This : Instance_Acc;
+ end record;
+
+ -- List of finalizer.
+ package Finalizer_Table is new Grt.Table
+ (Table_Component_Type => Finalizer_Type,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 2);
+
+ -- List of processes to be resume at next cycle.
+ type Process_Acc_Array is array (Natural range <>) of Process_Acc;
+ type Process_Acc_Array_Acc is access Process_Acc_Array;
+
+ Resume_Process_Table : Process_Acc_Array_Acc;
+ Last_Resume_Process : Natural := 0;
+ Postponed_Resume_Process_Table : Process_Acc_Array_Acc;
+ Last_Postponed_Resume_Process : Natural := 0;
+
+ -- Number of postponed processes.
+ Nbr_Postponed_Processes : Natural := 0;
+ Nbr_Non_Postponed_Processes : Natural := 0;
+
+ -- Number of resumed processes.
+ Nbr_Resumed_Processes : Natural := 0;
+
+ -- Earliest time out within non-sensitized processes.
+ Process_First_Timeout : Std_Time := Last_Time;
+ Process_Timeout_Chain : Process_Acc := null;
+
+ procedure Init is
+ begin
+ null;
+ end Init;
+
+ function Get_Nbr_Processes return Natural is
+ begin
+ return Natural (Process_Table.Last);
+ end Get_Nbr_Processes;
+
+ function Get_Nbr_Sensitized_Processes return Natural
+ is
+ Res : Natural := 0;
+ begin
+ for I in Process_Table.First .. Process_Table.Last loop
+ if Process_Table.Table (I).State = State_Sensitized then
+ Res := Res + 1;
+ end if;
+ end loop;
+ return Res;
+ end Get_Nbr_Sensitized_Processes;
+
+ function Get_Nbr_Resumed_Processes return Natural is
+ begin
+ return Nbr_Resumed_Processes;
+ end Get_Nbr_Resumed_Processes;
+
+ procedure Process_Register (This : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Rti_Context;
+ State : Process_State;
+ Postponed : Boolean)
+ is
+ Stack : Stack_Type;
+ P : Process_Acc;
+ begin
+ if State /= State_Sensitized and then not One_Stack then
+ Stack := Stack_Create (Proc, This);
+ if Stack = Null_Stack then
+ Internal_Error ("cannot allocate stack: memory exhausted");
+ end if;
+ else
+ Stack := Null_Stack;
+ end if;
+ P := new Process_Type'(Subprg => Proc,
+ This => This,
+ Rti => Ctxt,
+ Sensitivity => null,
+ Resumed => False,
+ Postponed => Postponed,
+ State => State,
+ Timeout => Bad_Time,
+ Timeout_Chain_Next => null,
+ Timeout_Chain_Prev => null,
+ Stack => Stack);
+ Process_Table.Append (P);
+ -- Used to create drivers.
+ Set_Current_Process (P);
+ if Postponed then
+ Nbr_Postponed_Processes := Nbr_Postponed_Processes + 1;
+ else
+ Nbr_Non_Postponed_Processes := Nbr_Non_Postponed_Processes + 1;
+ end if;
+ end Process_Register;
+
+ procedure Ghdl_Process_Register
+ (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address)
+ is
+ begin
+ Process_Register (Instance, Proc, (Addr, Ctxt), State_Ready, False);
+ end Ghdl_Process_Register;
+
+ procedure Ghdl_Sensitized_Process_Register
+ (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address)
+ is
+ begin
+ Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, False);
+ end Ghdl_Sensitized_Process_Register;
+
+ procedure Ghdl_Postponed_Process_Register
+ (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address)
+ is
+ begin
+ Process_Register (Instance, Proc, (Addr, Ctxt), State_Ready, True);
+ end Ghdl_Postponed_Process_Register;
+
+ procedure Ghdl_Postponed_Sensitized_Process_Register
+ (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address)
+ is
+ begin
+ Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, True);
+ end Ghdl_Postponed_Sensitized_Process_Register;
+
+ procedure Verilog_Process_Register (This : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Rti_Context)
+ is
+ P : Process_Acc;
+ begin
+ P := new Process_Type'(Rti => Ctxt,
+ Sensitivity => null,
+ Resumed => False,
+ Postponed => False,
+ State => State_Sensitized,
+ Timeout => Bad_Time,
+ Timeout_Chain_Next => null,
+ Timeout_Chain_Prev => null,
+ Subprg => Proc,
+ This => This,
+ Stack => Null_Stack);
+ Process_Table.Append (P);
+ -- Used to create drivers.
+ Set_Current_Process (P);
+ end Verilog_Process_Register;
+
+ procedure Ghdl_Initial_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc)
+ is
+ begin
+ Verilog_Process_Register (Instance, Proc, Null_Context);
+ end Ghdl_Initial_Register;
+
+ procedure Ghdl_Always_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc)
+ is
+ begin
+ Verilog_Process_Register (Instance, Proc, Null_Context);
+ end Ghdl_Always_Register;
+
+ procedure Ghdl_Process_Add_Sensitivity (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ Resume_Process_If_Event
+ (Sig, Process_Table.Table (Process_Table.Last));
+ end Ghdl_Process_Add_Sensitivity;
+
+ procedure Ghdl_Finalize_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc)
+ is
+ begin
+ Finalizer_Table.Append (Finalizer_Type'(Proc, Instance));
+ end Ghdl_Finalize_Register;
+
+ procedure Call_Finalizers is
+ El : Finalizer_Type;
+ begin
+ for I in Finalizer_Table.First .. Finalizer_Table.Last loop
+ El := Finalizer_Table.Table (I);
+ El.Subprg.all (El.This);
+ end loop;
+ end Call_Finalizers;
+
+ procedure Resume_Process (Proc : Process_Acc)
+ is
+ begin
+ if not Proc.Resumed then
+ Proc.Resumed := True;
+ if Proc.Postponed then
+ Last_Postponed_Resume_Process := Last_Postponed_Resume_Process + 1;
+ Postponed_Resume_Process_Table (Last_Postponed_Resume_Process)
+ := Proc;
+ else
+ Last_Resume_Process := Last_Resume_Process + 1;
+ Resume_Process_Table (Last_Resume_Process) := Proc;
+ end if;
+ end if;
+ end Resume_Process;
+
+ function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type)
+ return System.Address
+ is
+ begin
+ return Grt.Stack2.Allocate (Get_Stack2, Size);
+ end Ghdl_Stack2_Allocate;
+
+ function Ghdl_Stack2_Mark return Mark_Id
+ is
+ St2 : Stack2_Ptr := Get_Stack2;
+ begin
+ if St2 = Null_Stack2_Ptr then
+ St2 := Grt.Stack2.Create;
+ Set_Stack2 (St2);
+ end if;
+ return Grt.Stack2.Mark (St2);
+ end Ghdl_Stack2_Mark;
+
+ procedure Ghdl_Stack2_Release (Mark : Mark_Id) is
+ begin
+ Grt.Stack2.Release (Get_Stack2, Mark);
+ end Ghdl_Stack2_Release;
+
+ procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr)
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ El : Action_List_Acc;
+ begin
+ El := new Action_List'(Dynamic => True,
+ Next => Sig.Event_List,
+ Proc => Proc,
+ Prev => null,
+ Sig => Sig,
+ Chain => Proc.Sensitivity);
+ if Sig.Event_List /= null and then Sig.Event_List.Dynamic then
+ Sig.Event_List.Prev := El;
+ end if;
+ Sig.Event_List := El;
+ Proc.Sensitivity := El;
+ end Ghdl_Process_Wait_Add_Sensitivity;
+
+ procedure Update_Process_First_Timeout (Proc : Process_Acc) is
+ begin
+ if Proc.Timeout < Process_First_Timeout then
+ Process_First_Timeout := Proc.Timeout;
+ end if;
+ Proc.Timeout_Chain_Next := Process_Timeout_Chain;
+ Proc.Timeout_Chain_Prev := null;
+ if Process_Timeout_Chain /= null then
+ Process_Timeout_Chain.Timeout_Chain_Prev := Proc;
+ end if;
+ Process_Timeout_Chain := Proc;
+ end Update_Process_First_Timeout;
+
+ procedure Remove_Process_From_Timeout_Chain (Proc : Process_Acc) is
+ begin
+ -- Remove Proc from the timeout list.
+ if Proc.Timeout_Chain_Prev /= null then
+ Proc.Timeout_Chain_Prev.Timeout_Chain_Next :=
+ Proc.Timeout_Chain_Next;
+ elsif Process_Timeout_Chain = Proc then
+ -- Only if Proc is in the chain.
+ Process_Timeout_Chain := Proc.Timeout_Chain_Next;
+ end if;
+ if Proc.Timeout_Chain_Next /= null then
+ Proc.Timeout_Chain_Next.Timeout_Chain_Prev :=
+ Proc.Timeout_Chain_Prev;
+ Proc.Timeout_Chain_Next := null;
+ end if;
+ -- Be sure a second call won't corrupt the chain.
+ Proc.Timeout_Chain_Prev := null;
+ end Remove_Process_From_Timeout_Chain;
+
+ procedure Ghdl_Process_Wait_Set_Timeout (Time : Std_Time)
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ if Time < 0 then
+ -- LRM93 8.1
+ Error ("negative timeout clause");
+ end if;
+ Proc.Timeout := Current_Time + Time;
+ Update_Process_First_Timeout (Proc);
+ end Ghdl_Process_Wait_Set_Timeout;
+
+ function Ghdl_Process_Wait_Has_Timeout return Boolean
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ -- Note: in case of timeout, the timeout is removed when process is
+ -- woken up.
+ return Proc.State = State_Timeout;
+ end Ghdl_Process_Wait_Has_Timeout;
+
+ procedure Ghdl_Process_Wait_Wait
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ if Proc.State = State_Sensitized then
+ Error ("wait statement in a sensitized process");
+ end if;
+ -- Suspend this process.
+ Proc.State := State_Wait;
+-- if Cur_Proc.Timeout = Bad_Time then
+-- Cur_Proc.Timeout := Std_Time'Last;
+-- end if;
+ end Ghdl_Process_Wait_Wait;
+
+ function Ghdl_Process_Wait_Suspend return Boolean
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ Ghdl_Process_Wait_Wait;
+ if One_Stack then
+ Internal_Error ("wait_suspend");
+ else
+ Stack_Switch (Get_Main_Stack, Proc.Stack);
+ end if;
+ return Ghdl_Process_Wait_Has_Timeout;
+ end Ghdl_Process_Wait_Suspend;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Action_List, Action_List_Acc);
+
+ procedure Ghdl_Process_Wait_Close
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ El : Action_List_Acc;
+ N_El : Action_List_Acc;
+ begin
+ -- Remove the sensitivity.
+ El := Proc.Sensitivity;
+ Proc.Sensitivity := null;
+ while El /= null loop
+ pragma Assert (El.Proc = Get_Current_Process);
+ if El.Prev = null then
+ El.Sig.Event_List := El.Next;
+ else
+ pragma Assert (El.Prev.Dynamic);
+ El.Prev.Next := El.Next;
+ end if;
+ if El.Next /= null and then El.Next.Dynamic then
+ El.Next.Prev := El.Prev;
+ end if;
+ N_El := El.Chain;
+ Free (El);
+ El := N_El;
+ end loop;
+
+ -- Remove Proc from the timeout list.
+ Remove_Process_From_Timeout_Chain (Proc);
+
+ -- This is necessary when the process has been woken-up by an event
+ -- before the timeout triggers.
+ if Process_First_Timeout = Proc.Timeout then
+ -- Remove the timeout.
+ Proc.Timeout := Bad_Time;
+
+ declare
+ Next_Timeout : Std_Time;
+ P : Process_Acc;
+ begin
+ Next_Timeout := Last_Time;
+ P := Process_Timeout_Chain;
+ while P /= null loop
+ case P.State is
+ when State_Delayed
+ | State_Wait =>
+ if P.Timeout > 0
+ and then P.Timeout < Next_Timeout
+ then
+ Next_Timeout := P.Timeout;
+ end if;
+ when others =>
+ null;
+ end case;
+ P := P.Timeout_Chain_Next;
+ end loop;
+ Process_First_Timeout := Next_Timeout;
+ end;
+ else
+ -- Remove the timeout.
+ Proc.Timeout := Bad_Time;
+ end if;
+ Proc.State := State_Ready;
+ end Ghdl_Process_Wait_Close;
+
+ procedure Ghdl_Process_Wait_Exit
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ if Proc.State = State_Sensitized then
+ Error ("wait statement in a sensitized process");
+ end if;
+ -- Mark this process as dead, in order to kill it.
+ -- It cannot be killed now, since this code is still in the process.
+ Proc.State := State_Dead;
+
+ -- Suspend this process.
+ if not One_Stack then
+ Stack_Switch (Get_Main_Stack, Proc.Stack);
+ end if;
+ end Ghdl_Process_Wait_Exit;
+
+ procedure Ghdl_Process_Wait_Timeout (Time : Std_Time)
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ if Proc.State = State_Sensitized then
+ Error ("wait statement in a sensitized process");
+ end if;
+ if Time < 0 then
+ -- LRM93 8.1
+ Error ("negative timeout clause");
+ end if;
+ Proc.Timeout := Current_Time + Time;
+ Proc.State := State_Wait;
+ Update_Process_First_Timeout (Proc);
+ -- Suspend this process.
+ if One_Stack then
+ Internal_Error ("wait_timeout");
+ else
+ Stack_Switch (Get_Main_Stack, Proc.Stack);
+ end if;
+ -- Clean-up.
+ Proc.Timeout := Bad_Time;
+ Remove_Process_From_Timeout_Chain (Proc);
+ Proc.State := State_Ready;
+ end Ghdl_Process_Wait_Timeout;
+
+ -- Verilog.
+ procedure Ghdl_Process_Delay (Del : Ghdl_U32)
+ is
+ Proc : constant Process_Acc := Get_Current_Process;
+ begin
+ Proc.Timeout := Current_Time + Std_Time (Del);
+ Proc.State := State_Delayed;
+ Update_Process_First_Timeout (Proc);
+ end Ghdl_Process_Delay;
+
+ -- Protected object lock.
+ -- Note: there is no real locks, since the kernel is single threading.
+ -- Multi lock is allowed, and rules are just checked.
+ type Object_Lock is record
+ -- The owner of the lock.
+ -- Nul_Process_Id means the lock is free.
+ Process : Process_Acc;
+ -- Number of times the lock has been acquired.
+ Count : Natural;
+ end record;
+
+ type Object_Lock_Acc is access Object_Lock;
+ type Object_Lock_Acc_Acc is access Object_Lock_Acc;
+
+ function To_Lock_Acc_Acc is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Object_Lock_Acc_Acc);
+
+ procedure Ghdl_Protected_Enter (Obj : System.Address)
+ is
+ Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all;
+ begin
+ if Lock.Process = null then
+ if Lock.Count /= 0 then
+ Internal_Error ("protected_enter");
+ end if;
+ Lock.Process := Get_Current_Process;
+ Lock.Count := 1;
+ else
+ if Lock.Process /= Get_Current_Process then
+ Internal_Error ("protected_enter(2)");
+ end if;
+ Lock.Count := Lock.Count + 1;
+ end if;
+ end Ghdl_Protected_Enter;
+
+ procedure Ghdl_Protected_Leave (Obj : System.Address)
+ is
+ Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all;
+ begin
+ if Lock.Process /= Get_Current_Process then
+ Internal_Error ("protected_leave(1)");
+ end if;
+
+ if Lock.Count = 0 then
+ Internal_Error ("protected_leave(2)");
+ end if;
+ Lock.Count := Lock.Count - 1;
+ if Lock.Count = 0 then
+ Lock.Process := null;
+ end if;
+ end Ghdl_Protected_Leave;
+
+ procedure Ghdl_Protected_Init (Obj : System.Address)
+ is
+ Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj);
+ begin
+ Lock.all := new Object_Lock'(Process => null, Count => 0);
+ end Ghdl_Protected_Init;
+
+ procedure Ghdl_Protected_Fini (Obj : System.Address)
+ is
+ procedure Deallocate is new Ada.Unchecked_Deallocation
+ (Object => Object_Lock, Name => Object_Lock_Acc);
+
+ Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj);
+ begin
+ if Lock.all.Count /= 0 or Lock.all.Process /= null then
+ Internal_Error ("protected_fini");
+ end if;
+ Deallocate (Lock.all);
+ end Ghdl_Protected_Fini;
+
+ function Compute_Next_Time return Std_Time
+ is
+ Res : Std_Time;
+ begin
+ -- f) The time of the next simulation cycle, Tn, is determined by
+ -- setting it to the earliest of
+ -- 1) TIME'HIGH
+ Res := Std_Time'Last;
+
+ -- 2) The next time at which a driver becomes active, or
+ Res := Std_Time'Min (Res, Grt.Signals.Find_Next_Time);
+
+ if Res = Current_Time then
+ return Res;
+ end if;
+
+ -- 3) The next time at which a process resumes.
+ if Process_First_Timeout < Res then
+ -- No signals to be updated.
+ Grt.Signals.Flush_Active_List;
+
+ Res := Process_First_Timeout;
+ end if;
+
+ return Res;
+ end Compute_Next_Time;
+
+ procedure Disp_Process_Name (Stream : Grt.Stdio.FILEs; Proc : Process_Acc)
+ is
+ begin
+ Grt.Rtis_Utils.Put (Stream, Proc.Rti);
+ end Disp_Process_Name;
+
+ procedure Disp_All_Processes
+ is
+ use Grt.Stdio;
+ use Grt.Astdio;
+ begin
+ for I in Process_Table.First .. Process_Table.Last loop
+ declare
+ Proc : constant Process_Acc := Process_Table.Table (I);
+ begin
+ Disp_Process_Name (stdout, Proc);
+ New_Line (stdout);
+ Put (stdout, " State: ");
+ case Proc.State is
+ when State_Sensitized =>
+ Put (stdout, "sensitized");
+ when State_Wait =>
+ Put (stdout, "wait");
+ if Proc.Timeout /= Bad_Time then
+ Put (stdout, " until ");
+ Put_Time (stdout, Proc.Timeout);
+ end if;
+ when State_Ready =>
+ Put (stdout, "ready");
+ when State_Timeout =>
+ Put (stdout, "timeout");
+ when State_Delayed =>
+ Put (stdout, "delayed");
+ when State_Dead =>
+ Put (stdout, "dead");
+ end case;
+-- Put (stdout, ": time: ");
+-- Put_U64 (stdout, Proc.Stats_Time);
+-- Put (stdout, ", runs: ");
+-- Put_U32 (stdout, Proc.Stats_Run);
+ New_Line (stdout);
+ end;
+ end loop;
+ end Disp_All_Processes;
+
+ pragma Unreferenced (Disp_All_Processes);
+
+ -- Run resumed processes.
+ -- If POSTPONED is true, resume postponed processes, else resume
+ -- non-posponed processes.
+ -- Returns one of these values:
+ -- No process has been run.
+ Run_None : constant Integer := 1;
+ -- At least one process was run.
+ Run_Resumed : constant Integer := 2;
+ -- Simulation is finished.
+ Run_Finished : constant Integer := 3;
+ -- Failure, simulation should stop.
+ Run_Failure : constant Integer := -1;
+
+ Mt_Last : Natural;
+ Mt_Table : Process_Acc_Array_Acc;
+ Mt_Index : aliased Natural;
+
+ procedure Run_Processes_Threads
+ is
+ Proc : Process_Acc;
+ Idx : Natural;
+ begin
+ loop
+ -- Atomically get a process to be executed
+ Idx := Grt.Threads.Atomic_Inc (Mt_Index'Access);
+ if Idx > Mt_Last then
+ return;
+ end if;
+ Proc := Mt_Table (Idx);
+
+ if Grt.Options.Trace_Processes then
+ Grt.Astdio.Put ("run process ");
+ Disp_Process_Name (Stdio.stdout, Proc);
+ Grt.Astdio.Put (" [");
+ Grt.Astdio.Put (Stdio.stdout, To_Address (Proc.This));
+ Grt.Astdio.Put ("]");
+ Grt.Astdio.New_Line;
+ end if;
+ if not Proc.Resumed then
+ Internal_Error ("run non-resumed process");
+ end if;
+ Proc.Resumed := False;
+ Set_Current_Process (Proc);
+ if Proc.State = State_Sensitized or else One_Stack then
+ Proc.Subprg.all (Proc.This);
+ else
+ Stack_Switch (Proc.Stack, Get_Main_Stack);
+ end if;
+ if Grt.Options.Checks then
+ Ghdl_Signal_Internal_Checks;
+ Grt.Stack2.Check_Empty (Get_Stack2);
+ end if;
+ end loop;
+ end Run_Processes_Threads;
+
+ function Run_Processes (Postponed : Boolean) return Integer
+ is
+ Table : Process_Acc_Array_Acc;
+ Last : Natural;
+ begin
+ if Options.Flag_Stats then
+ Stats.Start_Processes;
+ end if;
+
+ if Postponed then
+ Table := Postponed_Resume_Process_Table;
+ Last := Last_Postponed_Resume_Process;
+ Last_Postponed_Resume_Process := 0;
+ else
+ Table := Resume_Process_Table;
+ Last := Last_Resume_Process;
+ Last_Resume_Process := 0;
+ end if;
+ Nbr_Resumed_Processes := Nbr_Resumed_Processes + Last;
+
+ if Options.Nbr_Threads = 1 then
+ for I in 1 .. Last loop
+ declare
+ Proc : constant Process_Acc := Table (I);
+ begin
+ if not Proc.Resumed then
+ Internal_Error ("run non-resumed process");
+ end if;
+ if Grt.Options.Trace_Processes then
+ Grt.Astdio.Put ("run process ");
+ Disp_Process_Name (Stdio.stdout, Proc);
+ Grt.Astdio.Put (" [");
+ Grt.Astdio.Put (Stdio.stdout, To_Address (Proc.This));
+ Grt.Astdio.Put ("]");
+ Grt.Astdio.New_Line;
+ end if;
+
+ Proc.Resumed := False;
+ Set_Current_Process (Proc);
+ if Proc.State = State_Sensitized or else One_Stack then
+ Proc.Subprg.all (Proc.This);
+ else
+ Stack_Switch (Proc.Stack, Get_Main_Stack);
+ end if;
+ if Grt.Options.Checks then
+ Ghdl_Signal_Internal_Checks;
+ Grt.Stack2.Check_Empty (Get_Stack2);
+ end if;
+ end;
+ end loop;
+ else
+ Mt_Last := Last;
+ Mt_Table := Table;
+ Mt_Index := 1;
+ Threads.Run_Parallel (Run_Processes_Threads'Access);
+ end if;
+
+ if Last >= 1 then
+ return Run_Resumed;
+ else
+ return Run_None;
+ end if;
+ end Run_Processes;
+
+ function Initialization_Phase return Integer
+ is
+ Status : Integer;
+ begin
+ -- Allocate processes arrays.
+ Resume_Process_Table :=
+ new Process_Acc_Array (1 .. Nbr_Non_Postponed_Processes);
+ Postponed_Resume_Process_Table :=
+ new Process_Acc_Array (1 .. Nbr_Postponed_Processes);
+
+ -- LRM93 12.6.4
+ -- At the beginning of initialization, the current time, Tc, is assumed
+ -- to be 0 ns.
+ Current_Time := 0;
+
+ -- The initialization phase consists of the following steps:
+ -- - The driving value and the effective value of each explicitly
+ -- declared signal are computed, and the current value of the signal
+ -- is set to the effective value. This value is assumed to have been
+ -- the value of the signal for an infinite length of time prior to
+ -- the start of the simulation.
+ Init_Signals;
+
+ -- - The value of each implicit signal of the form S'Stable(T) or
+ -- S'Quiet(T) is set to true. The value of each implicit signal of
+ -- the form S'Delayed is set to the initial value of its prefix, S.
+ -- GHDL: already done when the signals are created.
+ null;
+
+ -- - The value of each implicit GUARD signal is set to the result of
+ -- evaluating the corresponding guard expression.
+ null;
+
+ for I in Process_Table.First .. Process_Table.Last loop
+ Resume_Process (Process_Table.Table (I));
+ end loop;
+
+ -- - Each nonpostponed process in the model is executed until it
+ -- suspends.
+ Status := Run_Processes (Postponed => False);
+ if Status = Run_Failure then
+ return Run_Failure;
+ end if;
+
+ -- - Each postponed process in the model is executed until it suspends.
+ Status := Run_Processes (Postponed => True);
+ if Status = Run_Failure then
+ return Run_Failure;
+ end if;
+
+ -- - The time of the next simulation cycle (which in this case is the
+ -- first simulation cycle), Tn, is calculated according to the rules
+ -- of step f of the simulation cycle, below.
+ Current_Time := Compute_Next_Time;
+
+ -- Clear current_delta, will be set by Simulation_Cycle.
+ Current_Delta := 0;
+
+ return Run_Resumed;
+ end Initialization_Phase;
+
+ -- Launch a simulation cycle.
+ -- Set FINISHED to true if this is the last cycle.
+ function Simulation_Cycle return Integer
+ is
+ Tn : Std_Time;
+ Status : Integer;
+ begin
+ -- LRM93 12.6.4
+ -- A simulation cycle consists of the following steps:
+ --
+ -- a) The current time, Tc is set equal to Tn. Simulation is complete
+ -- when Tn = TIME'HIGH and there are no active drivers or process
+ -- resumptions at Tn.
+ -- GHDL: this is done at the last step of the cycle.
+ null;
+
+ -- b) Each active explicit signal in the model is updated. (Events
+ -- may occur on signals as a result).
+ -- c) Each implicit signal in the model is updated. (Events may occur
+ -- on signals as a result.)
+ if Options.Flag_Stats then
+ Stats.Start_Update;
+ end if;
+ Update_Signals;
+ if Options.Flag_Stats then
+ Stats.Start_Resume;
+ end if;
+
+ -- d) For each process P, if P is currently sensitive to a signal S and
+ -- if an event has occured on S in this simulation cycle, then P
+ -- resumes.
+ if Current_Time = Process_First_Timeout then
+ Tn := Last_Time;
+ declare
+ Proc : Process_Acc;
+ begin
+ Proc := Process_Timeout_Chain;
+ while Proc /= null loop
+ case Proc.State is
+ when State_Sensitized =>
+ null;
+ when State_Delayed =>
+ if Proc.Timeout = Current_Time then
+ Proc.Timeout := Bad_Time;
+ Resume_Process (Proc);
+ Proc.State := State_Sensitized;
+ elsif Proc.Timeout > 0 and then Proc.Timeout < Tn then
+ Tn := Proc.Timeout;
+ end if;
+ when State_Wait =>
+ if Proc.Timeout = Current_Time then
+ Proc.Timeout := Bad_Time;
+ Resume_Process (Proc);
+ Proc.State := State_Timeout;
+ elsif Proc.Timeout > 0 and then Proc.Timeout < Tn then
+ Tn := Proc.Timeout;
+ end if;
+ when State_Timeout
+ | State_Ready =>
+ Internal_Error ("process in timeout");
+ when State_Dead =>
+ null;
+ end case;
+ Proc := Proc.Timeout_Chain_Next;
+ end loop;
+ end;
+ Process_First_Timeout := Tn;
+ end if;
+
+ -- e) Each nonpostponed that has resumed in the current simulation cycle
+ -- is executed until it suspends.
+ Status := Run_Processes (Postponed => False);
+ if Status = Run_Failure then
+ return Run_Failure;
+ end if;
+
+ -- f) The time of the next simulation cycle, Tn, is determined by
+ -- setting it to the earliest of
+ -- 1) TIME'HIGH
+ -- 2) The next time at which a driver becomes active, or
+ -- 3) The next time at which a process resumes.
+ -- If Tn = Tc, then the next simulation cycle (if any) will be a
+ -- delta cycle.
+ if Options.Flag_Stats then
+ Stats.Start_Next_Time;
+ end if;
+ Tn := Compute_Next_Time;
+
+ -- g) If the next simulation cycle will be a delta cycle, the remainder
+ -- of the step is skipped.
+ -- Otherwise, each postponed process that has resumed but has not
+ -- been executed since its last resumption is executed until it
+ -- suspends. Then Tn is recalculated according to the rules of
+ -- step f. It is an error if the execution of any postponed
+ -- process causes a delta cycle to occur immediatly after the
+ -- current simulation cycle.
+ if Tn = Current_Time then
+ if Current_Time = Last_Time and then Status = Run_None then
+ return Run_Finished;
+ else
+ Current_Delta := Current_Delta + 1;
+ return Run_Resumed;
+ end if;
+ else
+ Current_Delta := 0;
+ if Nbr_Postponed_Processes /= 0 then
+ Status := Run_Processes (Postponed => True);
+ end if;
+ if Status = Run_Resumed then
+ Flush_Active_List;
+ if Options.Flag_Stats then
+ Stats.Start_Next_Time;
+ end if;
+ Tn := Compute_Next_Time;
+ if Tn = Current_Time then
+ Error ("postponed process causes a delta cycle");
+ end if;
+ elsif Status = Run_Failure then
+ return Run_Failure;
+ end if;
+ Current_Time := Tn;
+ return Run_Resumed;
+ end if;
+ end Simulation_Cycle;
+
+ function Simulation return Integer
+ is
+ use Options;
+ Status : Integer;
+ begin
+ if Nbr_Threads /= 1 then
+ Threads.Init;
+ end if;
+
+-- if Disp_Sig_Types then
+-- Grt.Disp.Disp_Signals_Type;
+-- end if;
+
+ Status := Run_Through_Longjump (Initialization_Phase'Access);
+ if Status /= Run_Resumed then
+ return -1;
+ end if;
+
+ Nbr_Delta_Cycles := 0;
+ Nbr_Cycles := 0;
+ if Trace_Signals then
+ Grt.Disp_Signals.Disp_All_Signals;
+ end if;
+
+ if Current_Time /= 0 then
+ -- This is the end of a cycle. This can happen when the time is not
+ -- zero after initialization.
+ Cycle_Time := 0;
+ Grt.Hooks.Call_Cycle_Hooks;
+ end if;
+
+ loop
+ Cycle_Time := Current_Time;
+ if Disp_Time then
+ Grt.Disp.Disp_Now;
+ end if;
+ Status := Run_Through_Longjump (Simulation_Cycle'Access);
+ exit when Status < 0;
+ if Trace_Signals then
+ Grt.Disp_Signals.Disp_All_Signals;
+ end if;
+
+ -- Statistics.
+ if Current_Delta = 0 then
+ Nbr_Cycles := Nbr_Cycles + 1;
+ else
+ Nbr_Delta_Cycles := Nbr_Delta_Cycles + 1;
+ end if;
+
+ exit when Status = Run_Finished;
+ if Current_Delta = 0 then
+ Grt.Hooks.Call_Cycle_Hooks;
+ end if;
+
+ if Current_Delta >= Stop_Delta then
+ Error ("simulation stopped by --stop-delta");
+ exit;
+ end if;
+ if Current_Time > Stop_Time then
+ if Current_Time /= Last_Time then
+ Info ("simulation stopped by --stop-time");
+ end if;
+ exit;
+ end if;
+ end loop;
+
+ if Nbr_Threads /= 1 then
+ Threads.Finish;
+ end if;
+
+ Call_Finalizers;
+
+ Grt.Hooks.Call_Finish_Hooks;
+
+ if Status = Run_Failure then
+ return -1;
+ else
+ return Exit_Status ;
+ end if;
+ end Simulation;
+
+end Grt.Processes;
diff --git a/src/translate/grt/grt-processes.ads b/src/translate/grt/grt-processes.ads
new file mode 100644
index 000000000..22326eb5e
--- /dev/null
+++ b/src/translate/grt/grt-processes.ads
@@ -0,0 +1,260 @@
+-- GHDL Run Time (GRT) - processes.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+with Grt.Stack2; use Grt.Stack2;
+with Grt.Types; use Grt.Types;
+with Grt.Signals; use Grt.Signals;
+with Grt.Stacks; use Grt.Stacks;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr;
+with Grt.Stdio;
+
+package Grt.Processes is
+ pragma Suppress (All_Checks);
+
+ -- Internal initialisations.
+ procedure Init;
+
+ -- Do the VHDL simulation.
+ -- Return 0 in case of success (end of time reached).
+ function Simulation return Integer;
+
+ -- Number of delta cycles.
+ Nbr_Delta_Cycles : Integer;
+ -- Number of non-delta cycles.
+ Nbr_Cycles : Integer;
+
+ -- If true, the simulation should be stopped.
+ Break_Simulation : Boolean;
+
+ -- If true, there is one stack for all processes. Non-sensitized
+ -- processes must save their state.
+ One_Stack : Boolean := False;
+
+ type Process_Type is private;
+ -- type Process_Acc is access all Process_Type;
+
+ -- Return the identifier of the current process.
+ -- During the elaboration, this is the identifier of the last process
+ -- being elaborated. So, this function can be used to create signal
+ -- drivers.
+
+ -- Return the total number of processes and number of sensitized processes.
+ -- Used for statistics.
+ function Get_Nbr_Processes return Natural;
+ function Get_Nbr_Sensitized_Processes return Natural;
+
+ -- Total number of resumed processes.
+ function Get_Nbr_Resumed_Processes return Natural;
+
+ -- Disp the name of process PROC.
+ procedure Disp_Process_Name (Stream : Grt.Stdio.FILEs; Proc : Process_Acc);
+
+ -- Register a process during elaboration.
+ -- This procedure is called by vhdl elaboration code.
+ procedure Ghdl_Process_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address);
+ procedure Ghdl_Sensitized_Process_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address);
+ procedure Ghdl_Postponed_Process_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address);
+ procedure Ghdl_Postponed_Sensitized_Process_Register
+ (Instance : Instance_Acc;
+ Proc : Proc_Acc;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address);
+
+ -- For verilog processes.
+ procedure Ghdl_Finalize_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc);
+
+ procedure Ghdl_Initial_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc);
+ procedure Ghdl_Always_Register (Instance : Instance_Acc;
+ Proc : Proc_Acc);
+
+ -- Add a simple signal in the sensitivity of the last registered
+ -- (sensitized) process.
+ procedure Ghdl_Process_Add_Sensitivity (Sig : Ghdl_Signal_Ptr);
+
+ -- Resume a process.
+ procedure Resume_Process (Proc : Process_Acc);
+
+ -- Wait without timeout or sensitivity: wait;
+ procedure Ghdl_Process_Wait_Exit;
+ -- Wait for a timeout (without sensitivity): wait for X;
+ procedure Ghdl_Process_Wait_Timeout (Time : Std_Time);
+
+ -- Full wait statement:
+ -- 1. Call Ghdl_Process_Wait_Set_Timeout (if there is a timeout)
+ -- 2. Call Ghdl_Process_Wait_Add_Sensitivity (for each signal)
+ -- 3. Call Ghdl_Process_Wait_Suspend, go to 4 if it returns true (timeout)
+ -- Evaluate the condition and go to 4 if true
+ -- Else, restart 3
+ -- 4. Call Ghdl_Process_Wait_Close
+
+ -- Add a timeout for a wait.
+ procedure Ghdl_Process_Wait_Set_Timeout (Time : Std_Time);
+ -- Add a sensitivity for a wait.
+ procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr);
+ -- Wait until timeout or sensitivity.
+ -- Return TRUE in case of timeout.
+ function Ghdl_Process_Wait_Suspend return Boolean;
+ -- Finish a wait statement.
+ procedure Ghdl_Process_Wait_Close;
+
+ -- For one stack setups, wait_suspend is decomposed into the suspension
+ -- procedure and the function to get resume status.
+ procedure Ghdl_Process_Wait_Wait;
+ function Ghdl_Process_Wait_Has_Timeout return Boolean;
+
+ -- Verilog.
+ procedure Ghdl_Process_Delay (Del : Ghdl_U32);
+
+ -- Secondary stack.
+ function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type)
+ return System.Address;
+ function Ghdl_Stack2_Mark return Mark_Id;
+ procedure Ghdl_Stack2_Release (Mark : Mark_Id);
+
+ -- Protected variables.
+ procedure Ghdl_Protected_Enter (Obj : System.Address);
+ procedure Ghdl_Protected_Leave (Obj : System.Address);
+ procedure Ghdl_Protected_Init (Obj : System.Address);
+ procedure Ghdl_Protected_Fini (Obj : System.Address);
+
+ type Run_Handler is access function return Integer;
+
+ -- Run HAND through a wrapper that catch some errors (in particular on
+ -- windows). Returns < 0 in case of error.
+ function Run_Through_Longjump (Hand : Run_Handler) return Integer;
+ pragma Import (Ada, Run_Through_Longjump, "__ghdl_run_through_longjump");
+
+private
+ -- State of a process.
+ type Process_State is
+ (
+ -- Sensitized process. Its state cannot change.
+ State_Sensitized,
+
+ -- Non-sensitized process, ready to run.
+ State_Ready,
+
+ -- Verilog process, being suspended.
+ State_Delayed,
+
+ -- Non-sensitized process being suspended.
+ State_Wait,
+
+ -- Non-sensitized process being awaked by a wait timeout. This state
+ -- is transcient.
+ -- This is necessary so that the process will exit immediately from the
+ -- wait statements without checking if the wait condition is true.
+ State_Timeout,
+
+ -- Non-sensitized process waiting until end.
+ State_Dead);
+
+ type Process_Type is record
+ -- Stack for the process.
+ -- This must be the first field of the record (and this is the only
+ -- part visible).
+ -- Must be NULL_STACK for sensitized processes.
+ Stack : Stacks.Stack_Type;
+
+ -- Subprogram containing process code.
+ Subprg : Proc_Acc;
+
+ -- Instance (THIS parameter) for the subprogram.
+ This : Instance_Acc;
+
+ -- Name of the process.
+ Rti : Rtis_Addr.Rti_Context;
+
+ -- True if the process is resumed and will be run at next cycle.
+ Resumed : Boolean;
+
+ -- True if the process is postponed.
+ Postponed : Boolean;
+
+ State : Process_State;
+
+ -- Timeout value for wait.
+ Timeout : Std_Time;
+
+ -- Sensitivity list while the (non-sensitized) process is waiting.
+ Sensitivity : Action_List_Acc;
+
+ Timeout_Chain_Next : Process_Acc;
+ Timeout_Chain_Prev : Process_Acc;
+ end record;
+
+ pragma Export (C, Ghdl_Process_Register,
+ "__ghdl_process_register");
+ pragma Export (C, Ghdl_Sensitized_Process_Register,
+ "__ghdl_sensitized_process_register");
+ pragma Export (C, Ghdl_Postponed_Process_Register,
+ "__ghdl_postponed_process_register");
+ pragma Export (C, Ghdl_Postponed_Sensitized_Process_Register,
+ "__ghdl_postponed_sensitized_process_register");
+
+ pragma Export (C, Ghdl_Finalize_Register, "__ghdl_finalize_register");
+
+ pragma Export (C, Ghdl_Always_Register, "__ghdl_always_register");
+ pragma Export (C, Ghdl_Initial_Register, "__ghdl_initial_register");
+
+ pragma Export (C, Ghdl_Process_Add_Sensitivity,
+ "__ghdl_process_add_sensitivity");
+
+ pragma Export (C, Ghdl_Process_Wait_Exit,
+ "__ghdl_process_wait_exit");
+ pragma Export (C, Ghdl_Process_Wait_Timeout,
+ "__ghdl_process_wait_timeout");
+ pragma Export (C, Ghdl_Process_Wait_Add_Sensitivity,
+ "__ghdl_process_wait_add_sensitivity");
+ pragma Export (C, Ghdl_Process_Wait_Set_Timeout,
+ "__ghdl_process_wait_set_timeout");
+ pragma Export (Ada, Ghdl_Process_Wait_Suspend,
+ "__ghdl_process_wait_suspend");
+ pragma Export (C, Ghdl_Process_Wait_Close,
+ "__ghdl_process_wait_close");
+
+ pragma Export (C, Ghdl_Process_Delay, "__ghdl_process_delay");
+
+ pragma Export (C, Ghdl_Stack2_Allocate, "__ghdl_stack2_allocate");
+ pragma Export (C, Ghdl_Stack2_Mark, "__ghdl_stack2_mark");
+ pragma Export (C, Ghdl_Stack2_Release, "__ghdl_stack2_release");
+
+ pragma Export (C, Ghdl_Protected_Enter, "__ghdl_protected_enter");
+ pragma Export (C, Ghdl_Protected_Leave, "__ghdl_protected_leave");
+ pragma Export (C, Ghdl_Protected_Init, "__ghdl_protected_init");
+ pragma Export (C, Ghdl_Protected_Fini, "__ghdl_protected_fini");
+end Grt.Processes;
diff --git a/src/translate/grt/grt-readline.ads b/src/translate/grt/grt-readline.ads
new file mode 100644
index 000000000..1a3083981
--- /dev/null
+++ b/src/translate/grt/grt-readline.ads
@@ -0,0 +1,30 @@
+-- Although being part of GRT, the readline binding should be independent of
+-- it (for easier reuse).
+
+with System; use System;
+
+package Grt.Readline is
+ subtype Fat_String is String (Positive);
+ type Char_Ptr is access Fat_String;
+ pragma Convention (C, Char_Ptr);
+ -- A C string (which is NUL terminated) is represented as a (thin) access
+ -- to a fat string (a string whose range is 1 .. integer'Last).
+ -- The use of an access to a constrained array allows a representation
+ -- compatible with C. Indexing of object of that type is safe only for
+ -- indexes until the NUL character.
+
+ function Readline (Prompt : Char_Ptr) return Char_Ptr;
+ function Readline (Prompt : Address) return Char_Ptr;
+ pragma Import (C, Readline);
+
+ procedure Free (Buf : Char_Ptr);
+ pragma Import (C, Free);
+
+ procedure Add_History (Line : Char_Ptr);
+ pragma Import (C, Add_History);
+
+ function Strlen (Str : Char_Ptr) return Natural;
+ pragma Import (C, Strlen);
+
+ pragma Linker_Options ("-lreadline");
+end Grt.Readline;
diff --git a/src/translate/grt/grt-rtis.adb b/src/translate/grt/grt-rtis.adb
new file mode 100644
index 000000000..26d976459
--- /dev/null
+++ b/src/translate/grt/grt-rtis.adb
@@ -0,0 +1,45 @@
+-- GHDL Run Time (GRT) - Run Time Informations.
+-- Copyright (C) 2013 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package body Grt.Rtis is
+ procedure Ghdl_Rti_Add_Package (Pkg : Ghdl_Rti_Access) is
+ begin
+ Ghdl_Rti_Top.Children (Ghdl_Rti_Top.Nbr_Child) := Pkg;
+ Ghdl_Rti_Top.Nbr_Child := Ghdl_Rti_Top.Nbr_Child + 1;
+ end Ghdl_Rti_Add_Package;
+
+ procedure Ghdl_Rti_Add_Top (Max_Pkg : Ghdl_Index_Type;
+ Pkgs : Ghdl_Rti_Arr_Acc;
+ Top : Ghdl_Rti_Access;
+ Instance : Address)
+ is
+ pragma Unreferenced (Max_Pkg);
+ begin
+ Ghdl_Rti_Top.Parent := Top;
+ Ghdl_Rti_Top.Children := Pkgs;
+ Ghdl_Rti_Top_Instance := Instance;
+ end Ghdl_Rti_Add_Top;
+
+end Grt.Rtis;
diff --git a/src/translate/grt/grt-rtis.ads b/src/translate/grt/grt-rtis.ads
new file mode 100644
index 000000000..6bb76597e
--- /dev/null
+++ b/src/translate/grt/grt-rtis.ads
@@ -0,0 +1,379 @@
+-- GHDL Run Time (GRT) - Run Time Informations.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Ada.Unchecked_Conversion;
+
+package Grt.Rtis is
+ pragma Preelaborate (Grt.Rtis);
+
+ type Ghdl_Rtik is
+ (Ghdl_Rtik_Top,
+ Ghdl_Rtik_Library, -- use scalar
+ Ghdl_Rtik_Package,
+ Ghdl_Rtik_Package_Body,
+ Ghdl_Rtik_Entity,
+ Ghdl_Rtik_Architecture,
+ Ghdl_Rtik_Process,
+ Ghdl_Rtik_Block,
+ Ghdl_Rtik_If_Generate,
+ Ghdl_Rtik_For_Generate,
+ Ghdl_Rtik_Instance, --10
+ Ghdl_Rtik_Constant,
+ Ghdl_Rtik_Iterator,
+ Ghdl_Rtik_Variable,
+ Ghdl_Rtik_Signal,
+ Ghdl_Rtik_File, -- 15
+ Ghdl_Rtik_Port,
+ Ghdl_Rtik_Generic,
+ Ghdl_Rtik_Alias,
+ Ghdl_Rtik_Guard,
+ Ghdl_Rtik_Component, -- 20
+ Ghdl_Rtik_Attribute,
+ Ghdl_Rtik_Type_B1, -- Enum
+ Ghdl_Rtik_Type_E8,
+ Ghdl_Rtik_Type_E32,
+ Ghdl_Rtik_Type_I32, -- 25 Scalar
+ Ghdl_Rtik_Type_I64,
+ Ghdl_Rtik_Type_F64,
+ Ghdl_Rtik_Type_P32,
+ Ghdl_Rtik_Type_P64,
+ Ghdl_Rtik_Type_Access,
+ Ghdl_Rtik_Type_Array,
+ Ghdl_Rtik_Type_Record,
+ Ghdl_Rtik_Type_File,
+ Ghdl_Rtik_Subtype_Scalar,
+ Ghdl_Rtik_Subtype_Array,
+ Ghdl_Rtik_Subtype_Unconstrained_Array,
+ Ghdl_Rtik_Subtype_Record,
+ Ghdl_Rtik_Subtype_Access,
+ Ghdl_Rtik_Type_Protected,
+ Ghdl_Rtik_Element,
+ Ghdl_Rtik_Unit64,
+ Ghdl_Rtik_Unitptr,
+ Ghdl_Rtik_Attribute_Transaction,
+ Ghdl_Rtik_Attribute_Quiet,
+ Ghdl_Rtik_Attribute_Stable,
+ Ghdl_Rtik_Error);
+ for Ghdl_Rtik'Size use 8;
+
+ type Ghdl_Rti_Depth is range 0 .. 255;
+ for Ghdl_Rti_Depth'Size use 8;
+
+ type Ghdl_Rti_U8 is mod 2 ** 8;
+ for Ghdl_Rti_U8'Size use 8;
+
+ -- This structure is common to all RTI nodes.
+ type Ghdl_Rti_Common is record
+ -- Kind of the RTI, list is above.
+ Kind : Ghdl_Rtik;
+
+ Depth : Ghdl_Rti_Depth;
+
+ -- * array types and subtypes, record types, protected types:
+ -- bit 0: set for complex type
+ -- bit 1: set for anonymous type definition
+ -- bit 2: set only for physical type with non-static units (time)
+ -- * signals:
+ -- bit 0-3: mode (1: linkage, 2: buffer, 3 : out, 4 : inout, 5: in)
+ -- bit 4-5: kind (0 : none, 1 : register, 2 : bus)
+ -- bit 6: set if has 'active attributes
+ Mode : Ghdl_Rti_U8;
+
+ -- * Types and subtypes definition:
+ -- maximum depth of all RTIs referenced.
+ -- * Others:
+ -- 0
+ Max_Depth : Ghdl_Rti_Depth;
+ end record;
+
+ type Ghdl_Rti_Access is access all Ghdl_Rti_Common;
+
+ -- Fat array of rti accesses.
+ type Ghdl_Rti_Array is array (Ghdl_Index_Type) of Ghdl_Rti_Access;
+ type Ghdl_Rti_Arr_Acc is access Ghdl_Rti_Array;
+
+ subtype Ghdl_Rti_Loc is Integer_Address;
+ Null_Rti_Loc : constant Ghdl_Rti_Loc := 0;
+
+ type Ghdl_C_String_Array is array (Ghdl_Index_Type) of Ghdl_C_String;
+ type Ghdl_C_String_Array_Ptr is access Ghdl_C_String_Array;
+
+ type Ghdl_Rtin_Block is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Loc : Ghdl_Rti_Loc;
+ Parent : Ghdl_Rti_Access;
+ Size : Ghdl_Index_Type;
+ Nbr_Child : Ghdl_Index_Type;
+ Children : Ghdl_Rti_Arr_Acc;
+ end record;
+ type Ghdl_Rtin_Block_Acc is access Ghdl_Rtin_Block;
+ function To_Ghdl_Rtin_Block_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Block_Acc);
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rtin_Block_Acc, Target => Ghdl_Rti_Access);
+
+ type Ghdl_Rtin_Object is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Loc : Ghdl_Rti_Loc;
+ Obj_Type : Ghdl_Rti_Access;
+ end record;
+ type Ghdl_Rtin_Object_Acc is access Ghdl_Rtin_Object;
+ function To_Ghdl_Rtin_Object_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Object_Acc);
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rtin_Object_Acc, Target => Ghdl_Rti_Access);
+
+ type Ghdl_Rtin_Instance is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Loc : Ghdl_Rti_Loc;
+ Parent : Ghdl_Rti_Access;
+ Instance : Ghdl_Rti_Access;
+ end record;
+ type Ghdl_Rtin_Instance_Acc is access Ghdl_Rtin_Instance;
+ function To_Ghdl_Rtin_Instance_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Instance_Acc);
+
+ -- Must be kept in sync with grt.types.mode_signal_type.
+ Ghdl_Rti_Signal_Mode_Mask : constant Ghdl_Rti_U8 := 15;
+ Ghdl_Rti_Signal_Mode_None : constant Ghdl_Rti_U8 := 0;
+ Ghdl_Rti_Signal_Mode_Linkage : constant Ghdl_Rti_U8 := 1;
+ Ghdl_Rti_Signal_Mode_Buffer : constant Ghdl_Rti_U8 := 2;
+ Ghdl_Rti_Signal_Mode_Out : constant Ghdl_Rti_U8 := 3;
+ Ghdl_Rti_Signal_Mode_Inout : constant Ghdl_Rti_U8 := 4;
+ Ghdl_Rti_Signal_Mode_In : constant Ghdl_Rti_U8 := 5;
+
+ Ghdl_Rti_Signal_Kind_Mask : constant Ghdl_Rti_U8 := 3 * 16;
+ Ghdl_Rti_Signal_Kind_Offset : constant Ghdl_Rti_U8 := 1 * 16;
+ Ghdl_Rti_Signal_Kind_No : constant Ghdl_Rti_U8 := 0 * 16;
+ Ghdl_Rti_Signal_Kind_Register : constant Ghdl_Rti_U8 := 1 * 16;
+ Ghdl_Rti_Signal_Kind_Bus : constant Ghdl_Rti_U8 := 2 * 16;
+
+ Ghdl_Rti_Signal_Has_Active : constant Ghdl_Rti_U8 := 64;
+
+ type Ghdl_Rtin_Component is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Nbr_Child : Ghdl_Index_Type;
+ Children : Ghdl_Rti_Arr_Acc;
+ end record;
+ type Ghdl_Rtin_Component_Acc is access Ghdl_Rtin_Component;
+ function To_Ghdl_Rtin_Component_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Component_Acc);
+
+ type Ghdl_Rtin_Type_Enum is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Nbr : Ghdl_Index_Type;
+ -- Characters are represented as 'X', identifiers are represented as is,
+ -- extended identifiers are represented as is too.
+ Names : Ghdl_C_String_Array_Ptr;
+ end record;
+ type Ghdl_Rtin_Type_Enum_Acc is access Ghdl_Rtin_Type_Enum;
+ function To_Ghdl_Rtin_Type_Enum_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Enum_Acc);
+
+ type Ghdl_Rtin_Type_Scalar is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ end record;
+ type Ghdl_Rtin_Type_Scalar_Acc is access Ghdl_Rtin_Type_Scalar;
+ function To_Ghdl_Rtin_Type_Scalar_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Scalar_Acc);
+
+ type Ghdl_Rtin_Subtype_Scalar is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Basetype : Ghdl_Rti_Access;
+ Range_Loc : Ghdl_Rti_Loc;
+ end record;
+ type Ghdl_Rtin_Subtype_Scalar_Acc is access Ghdl_Rtin_Subtype_Scalar;
+ function To_Ghdl_Rtin_Subtype_Scalar_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Scalar_Acc);
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rtin_Subtype_Scalar_Acc, Target => Ghdl_Rti_Access);
+
+ -- True if the type is complex, set in Mode field.
+ Ghdl_Rti_Type_Complex_Mask : constant Ghdl_Rti_U8 := 1;
+ Ghdl_Rti_Type_Complex : constant Ghdl_Rti_U8 := 1;
+
+ -- True if the type is anonymous
+ Ghdl_Rti_Type_Anonymous_Mask : constant Ghdl_Rti_U8 := 2;
+ Ghdl_Rti_Type_Anonymous : constant Ghdl_Rti_U8 := 2;
+
+ type Ghdl_Rtin_Type_Array is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Element : Ghdl_Rti_Access;
+ Nbr_Dim : Ghdl_Index_Type;
+ Indexes : Ghdl_Rti_Arr_Acc;
+ end record;
+ type Ghdl_Rtin_Type_Array_Acc is access Ghdl_Rtin_Type_Array;
+ function To_Ghdl_Rtin_Type_Array_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Array_Acc);
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rtin_Type_Array_Acc, Target => Ghdl_Rti_Access);
+
+ type Ghdl_Rtin_Subtype_Array is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Basetype : Ghdl_Rtin_Type_Array_Acc;
+ Bounds : Ghdl_Rti_Loc;
+ Valsize : Ghdl_Rti_Loc;
+ Sigsize : Ghdl_Rti_Loc;
+ end record;
+ type Ghdl_Rtin_Subtype_Array_Acc is access Ghdl_Rtin_Subtype_Array;
+ function To_Ghdl_Rtin_Subtype_Array_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Array_Acc);
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rtin_Subtype_Array_Acc, Target => Ghdl_Rti_Access);
+
+ type Ghdl_Rtin_Type_Fileacc is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Base : Ghdl_Rti_Access;
+ end record;
+ type Ghdl_Rtin_Type_Fileacc_Acc is access Ghdl_Rtin_Type_Fileacc;
+ function To_Ghdl_Rtin_Type_Fileacc_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Fileacc_Acc);
+
+ type Ghdl_Rtin_Element is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Eltype : Ghdl_Rti_Access;
+ Val_Off : Ghdl_Index_Type;
+ Sig_Off : Ghdl_Index_Type;
+ end record;
+ type Ghdl_Rtin_Element_Acc is access Ghdl_Rtin_Element;
+ function To_Ghdl_Rtin_Element_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Element_Acc);
+
+ type Ghdl_Rtin_Type_Record is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Nbrel : Ghdl_Index_Type;
+ Elements : Ghdl_Rti_Arr_Acc;
+ end record;
+ type Ghdl_Rtin_Type_Record_Acc is access Ghdl_Rtin_Type_Record;
+ function To_Ghdl_Rtin_Type_Record_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Record_Acc);
+
+ type Ghdl_Rtin_Unit64 is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Value : Ghdl_I64;
+ end record;
+ type Ghdl_Rtin_Unit64_Acc is access Ghdl_Rtin_Unit64;
+ function To_Ghdl_Rtin_Unit64_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unit64_Acc);
+
+ type Ghdl_Rtin_Unitptr is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Addr : Ghdl_Value_Ptr;
+ end record;
+ type Ghdl_Rtin_Unitptr_Acc is access Ghdl_Rtin_Unitptr;
+ function To_Ghdl_Rtin_Unitptr_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unitptr_Acc);
+
+ -- Mode field is set to 4 if units value is per address. Otherwise,
+ -- mode is 0.
+ type Ghdl_Rtin_Type_Physical is record
+ Common : Ghdl_Rti_Common;
+ Name : Ghdl_C_String;
+ Nbr : Ghdl_Index_Type;
+ Units : Ghdl_Rti_Arr_Acc;
+ end record;
+ type Ghdl_Rtin_Type_Physical_Acc is access Ghdl_Rtin_Type_Physical;
+ function To_Ghdl_Rtin_Type_Physical_Acc is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Physical_Acc);
+
+ -- Instance linkage.
+
+ -- At the beginning of a component structure (or the object for a direct
+ -- instantiation), there is a Ghdl_Component_Link_Type record.
+ -- These record contains a pointer to the instance (down link),
+ -- and RTIS to the statement and its parent (up link).
+ type Ghdl_Component_Link_Type;
+ type Ghdl_Component_Link_Acc is access Ghdl_Component_Link_Type;
+
+ -- At the beginning of an entity structure, there is a Ghdl_Link_Type,
+ -- which contains the RTI for the architecture (down-link) and a pointer
+ -- to the instantiation object (up-link).
+ type Ghdl_Entity_Link_Type is record
+ Rti : Ghdl_Rti_Access;
+ Parent : Ghdl_Component_Link_Acc;
+ end record;
+
+ type Ghdl_Entity_Link_Acc is access Ghdl_Entity_Link_Type;
+
+ function To_Ghdl_Entity_Link_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Entity_Link_Acc);
+
+ type Ghdl_Component_Link_Type is record
+ Instance : Ghdl_Entity_Link_Acc;
+ Stmt : Ghdl_Rti_Access;
+ end record;
+
+ function To_Ghdl_Component_Link_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Component_Link_Acc);
+
+ -- TOP rti.
+ Ghdl_Rti_Top : Ghdl_Rtin_Block :=
+ (Common => (Ghdl_Rtik_Top, 0, 0, 0),
+ Name => null,
+ Loc => Null_Rti_Loc,
+ Parent => null,
+ Size => 0,
+ Nbr_Child => 0,
+ Children => null);
+
+ -- Address of the top instance.
+ Ghdl_Rti_Top_Instance : Address;
+
+ -- Instances have a pointer to their RTI at offset 0.
+ type Ghdl_Rti_Acc_Acc is access Ghdl_Rti_Access;
+ function To_Ghdl_Rti_Acc_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Rti_Acc_Acc);
+
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Rti_Access, Target => Address);
+
+ function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Rti_Access);
+
+ procedure Ghdl_Rti_Add_Top (Max_Pkg : Ghdl_Index_Type;
+ Pkgs : Ghdl_Rti_Arr_Acc;
+ Top : Ghdl_Rti_Access;
+ Instance : Address);
+ pragma Export (C, Ghdl_Rti_Add_Top, "__ghdl_rti_add_top");
+
+ -- Register a package
+ procedure Ghdl_Rti_Add_Package (Pkg : Ghdl_Rti_Access);
+ pragma Export (C, Ghdl_Rti_Add_Package, "__ghdl_rti_add_package");
+end Grt.Rtis;
diff --git a/src/translate/grt/grt-rtis_addr.adb b/src/translate/grt/grt-rtis_addr.adb
new file mode 100644
index 000000000..70a0e2118
--- /dev/null
+++ b/src/translate/grt/grt-rtis_addr.adb
@@ -0,0 +1,299 @@
+-- GHDL Run Time (GRT) - RTI address handling.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Rtis_Addr is
+ function "+" (L : Address; R : Ghdl_Rti_Loc) return Address
+ is
+ begin
+ return To_Address (To_Integer (L) + R);
+ end "+";
+
+ function "+" (L : Address; R : Ghdl_Index_Type) return Address
+ is
+ begin
+ return To_Address (To_Integer (L) + Integer_Address (R));
+ end "+";
+
+ function "-" (L : Address; R : Ghdl_Rti_Loc) return Address
+ is
+ begin
+ return To_Address (To_Integer (L) - R);
+ end "-";
+
+ function Align (L : Address; R : Ghdl_Rti_Loc) return Address
+ is
+ Nad : Integer_Address;
+ begin
+ Nad := To_Integer (L + (R - 1));
+ return To_Address (Nad - (Nad mod R));
+ end Align;
+
+ function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+ case Ctxt.Block.Kind is
+ when Ghdl_Rtik_Process
+ | Ghdl_Rtik_Block =>
+ return (Base => Ctxt.Base - Blk.Loc,
+ Block => Blk.Parent);
+ when Ghdl_Rtik_Architecture =>
+ if Blk.Loc /= Null_Rti_Loc then
+ Internal_Error ("get_parent_context(3)");
+ end if;
+ return (Base => Ctxt.Base + Blk.Loc,
+ Block => Blk.Parent);
+ when Ghdl_Rtik_For_Generate
+ | Ghdl_Rtik_If_Generate =>
+ declare
+ Nbase : Address;
+ Parent : Ghdl_Rti_Access;
+ Blk1 : Ghdl_Rtin_Block_Acc;
+ begin
+ -- Read the pointer to the parent.
+ -- This is the first field.
+ Nbase := To_Addr_Acc (Ctxt.Base).all;
+ -- Since the parent may be a grant-parent, adjust
+ -- the base.
+ Parent := Blk.Parent;
+ loop
+ case Parent.Kind is
+ when Ghdl_Rtik_Architecture
+ | Ghdl_Rtik_For_Generate
+ | Ghdl_Rtik_If_Generate =>
+ exit;
+ when Ghdl_Rtik_Block =>
+ Blk1 := To_Ghdl_Rtin_Block_Acc (Parent);
+ Nbase := Nbase + Blk1.Loc;
+ Parent := Blk1.Parent;
+ when others =>
+ Internal_Error ("get_parent_context(2)");
+ end case;
+ end loop;
+ return (Base => Nbase,
+ Block => Blk.Parent);
+ end;
+ when others =>
+ Internal_Error ("get_parent_context(1)");
+ end case;
+ end Get_Parent_Context;
+
+ procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc;
+ Ctxt : out Rti_Context;
+ Stmt : out Ghdl_Rti_Access)
+ is
+ Obj : Ghdl_Rtin_Instance_Acc;
+ begin
+ if Link.Parent = null then
+ -- Top entity.
+ Stmt := null;
+ Ctxt := (Base => Null_Address, Block => null);
+ else
+ Stmt := Link.Parent.Stmt;
+ Obj := To_Ghdl_Rtin_Instance_Acc (Stmt);
+ Ctxt := (Base => Link.Parent.all'Address - Obj.Loc,
+ Block => Obj.Parent);
+ end if;
+ end Get_Instance_Link;
+
+ function Loc_To_Addr (Depth : Ghdl_Rti_Depth;
+ Loc : Ghdl_Rti_Loc;
+ Ctxt : Rti_Context)
+ return Address
+ is
+ Cur_Ctxt : Rti_Context;
+ Nctxt : Rti_Context;
+ begin
+ if Depth = 0 then
+ return To_Address (Loc);
+ elsif Ctxt.Block.Depth = Depth then
+ --Addr := Base + Storage_Offset (Obj.Loc.Off);
+ return Ctxt.Base + Loc;
+ else
+ if Ctxt.Block.Depth < Depth then
+ Internal_Error ("loc_to_addr");
+ end if;
+ Cur_Ctxt := Ctxt;
+ loop
+ Nctxt := Get_Parent_Context (Cur_Ctxt);
+ if Nctxt.Block.Depth = Depth then
+ return Nctxt.Base + Loc;
+ end if;
+ Cur_Ctxt := Nctxt;
+ end loop;
+ end if;
+ end Loc_To_Addr;
+
+ function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access)
+ return Ghdl_Index_Type
+ is
+ begin
+ case Base_Type.Kind is
+ when Ghdl_Rtik_Type_B1 =>
+ return Rng.B1.Len;
+ when Ghdl_Rtik_Type_E8 =>
+ return Rng.E8.Len;
+ when Ghdl_Rtik_Type_E32 =>
+ return Rng.E32.Len;
+ when Ghdl_Rtik_Type_I32 =>
+ return Rng.I32.Len;
+ when others =>
+ Internal_Error ("range_to_length");
+ end case;
+ end Range_To_Length;
+
+ function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc;
+ Ctxt : Rti_Context)
+ return Ghdl_Index_Type
+ is
+ Iter_Type : Ghdl_Rtin_Subtype_Scalar_Acc;
+ Rng : Ghdl_Range_Ptr;
+ begin
+ Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc
+ (To_Ghdl_Rtin_Object_Acc (Blk.Children (0)).Obj_Type);
+ if Iter_Type.Common.Kind /= Ghdl_Rtik_Subtype_Scalar then
+ Internal_Error ("get_for_generate_length(1)");
+ end if;
+ Rng := To_Ghdl_Range_Ptr
+ (Loc_To_Addr (Iter_Type.Common.Depth, Iter_Type.Range_Loc, Ctxt));
+ return Range_To_Length (Rng, Iter_Type.Basetype);
+ end Get_For_Generate_Length;
+
+ procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc;
+ Ctxt : Rti_Context;
+ Sub_Ctxt : out Rti_Context)
+ is
+ Inst_Addr : Address;
+ Inst_Base : Address;
+ begin
+ -- Address of the field containing the address of the instance.
+ Inst_Addr := Ctxt.Base + Inst.Loc;
+ -- Read sub instance address.
+ Inst_Base := To_Addr_Acc (Inst_Addr).all;
+ -- Read instance RTI.
+ if Inst_Base = Null_Address then
+ Sub_Ctxt := (Base => Null_Address, Block => null);
+ else
+ Sub_Ctxt := (Base => Inst_Base,
+ Block => To_Ghdl_Rti_Acc_Acc (Inst_Base).all);
+ end if;
+ end Get_Instance_Context;
+
+ procedure Bound_To_Range (Bounds_Addr : Address;
+ Def : Ghdl_Rtin_Type_Array_Acc;
+ Res : out Ghdl_Range_Array)
+ is
+ Bounds : Address;
+
+ procedure Align (A : Ghdl_Index_Type) is
+ begin
+ Bounds := Align (Bounds, Ghdl_Rti_Loc (A));
+ end Align;
+
+ procedure Update (S : Ghdl_Index_Type) is
+ begin
+ Bounds := Bounds + (S / Storage_Unit);
+ end Update;
+
+ Idx_Def : Ghdl_Rti_Access;
+ begin
+ if Res'Length /= Def.Nbr_Dim or else Res'First /= 0 then
+ Internal_Error ("disp_rti.bound_to_range");
+ end if;
+
+ Bounds := Bounds_Addr;
+
+ for I in 0 .. Def.Nbr_Dim - 1 loop
+ Idx_Def := Def.Indexes (I);
+
+ if Bounds = Null_Address then
+ Res (I) := null;
+ else
+ Idx_Def := Get_Base_Type (Idx_Def);
+ case Idx_Def.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Align (Ghdl_Range_I32'Alignment);
+ Res (I) := To_Ghdl_Range_Ptr (Bounds);
+ Update (Ghdl_Range_I32'Size);
+ when Ghdl_Rtik_Type_E8 =>
+ Align (Ghdl_Range_E8'Alignment);
+ Res (I) := To_Ghdl_Range_Ptr (Bounds);
+ Update (Ghdl_Range_E8'Size);
+ when Ghdl_Rtik_Type_E32 =>
+ Align (Ghdl_Range_E32'Alignment);
+ Res (I) := To_Ghdl_Range_Ptr (Bounds);
+ Update (Ghdl_Range_E32'Size);
+ when others =>
+ -- Bounds are not known anymore.
+ Bounds := Null_Address;
+ end case;
+ end if;
+ end loop;
+ end Bound_To_Range;
+
+ function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access
+ is
+ begin
+ case Atype.Kind is
+ when Ghdl_Rtik_Subtype_Scalar =>
+ return To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype;
+ when Ghdl_Rtik_Subtype_Array =>
+ return To_Ghdl_Rti_Access
+ (To_Ghdl_Rtin_Subtype_Array_Acc (Atype).Basetype);
+ when Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32
+ | Ghdl_Rtik_Type_B1 =>
+ return Atype;
+ when others =>
+ Internal_Error ("rtis_addr.get_base_type");
+ end case;
+ end Get_Base_Type;
+
+ function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean
+ is
+ begin
+ return (Atype.Mode and Ghdl_Rti_Type_Complex_Mask)
+ = Ghdl_Rti_Type_Complex;
+ end Rti_Complex_Type;
+
+ function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean
+ is
+ begin
+ return (Atype.Mode and Ghdl_Rti_Type_Anonymous_Mask)
+ = Ghdl_Rti_Type_Anonymous;
+ end Rti_Anonymous_Type;
+
+ function Get_Top_Context return Rti_Context
+ is
+ Ctxt : Rti_Context;
+ begin
+ Ctxt := (Base => Ghdl_Rti_Top_Instance,
+ Block => Ghdl_Rti_Top.Parent);
+ return Ctxt;
+ end Get_Top_Context;
+
+end Grt.Rtis_Addr;
diff --git a/src/translate/grt/grt-rtis_addr.ads b/src/translate/grt/grt-rtis_addr.ads
new file mode 100644
index 000000000..3fa2792af
--- /dev/null
+++ b/src/translate/grt/grt-rtis_addr.ads
@@ -0,0 +1,110 @@
+-- GHDL Run Time (GRT) - RTI address handling.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Ada.Unchecked_Conversion;
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+
+-- Addresses handling.
+package Grt.Rtis_Addr is
+ function "+" (L : Address; R : Ghdl_Rti_Loc) return Address;
+ function "+" (L : Address; R : Ghdl_Index_Type) return Address;
+
+ function "-" (L : Address; R : Ghdl_Rti_Loc) return Address;
+
+ function Align (L : Address; R : Ghdl_Rti_Loc) return Address;
+
+ -- An RTI context contains a pointer (BASE) to or into an instance.
+ -- BLOCK describes data being pointed. If a reference is made to a field
+ -- described by a parent of BLOCK, BASE must be modified.
+ type Rti_Context is record
+ Base : Address;
+ Block : Ghdl_Rti_Access;
+ end record;
+
+ Null_Context : constant Rti_Context;
+
+ -- Access to an address.
+ type Addr_Acc is access Address;
+ function To_Addr_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Addr_Acc);
+
+ type Ghdl_Index_Acc is access Ghdl_Index_Type;
+ function To_Ghdl_Index_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Index_Acc);
+
+ -- Get the parent context of CTXT.
+ -- The parent of an architecture is its entity.
+ function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context;
+
+ -- From an entity link, extract context and instantiation statement.
+ procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc;
+ Ctxt : out Rti_Context;
+ Stmt : out Ghdl_Rti_Access);
+
+ -- Convert a location to an address.
+ function Loc_To_Addr (Depth : Ghdl_Rti_Depth;
+ Loc : Ghdl_Rti_Loc;
+ Ctxt : Rti_Context)
+ return Address;
+
+ -- Get the length of for_generate BLK.
+ function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc;
+ Ctxt : Rti_Context)
+ return Ghdl_Index_Type;
+
+ -- Get the context of instance INST.
+ procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc;
+ Ctxt : Rti_Context;
+ Sub_Ctxt : out Rti_Context);
+
+ -- Extract range of every dimension from bounds.
+ procedure Bound_To_Range (Bounds_Addr : Address;
+ Def : Ghdl_Rtin_Type_Array_Acc;
+ Res : out Ghdl_Range_Array);
+
+ function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access)
+ return Ghdl_Index_Type;
+
+ -- Get the base type of ATYPE.
+ function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access;
+
+ -- Return true iff ATYPE is anonymous.
+ -- Valid only on type and subtype definitions.
+ function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean;
+ pragma Inline (Rti_Anonymous_Type);
+
+ -- Return true iff ATYPE is complex.
+ -- Valid only on type and subtype definitions.
+ function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean;
+ pragma Inline (Rti_Complex_Type);
+
+ -- Get the top context.
+ function Get_Top_Context return Rti_Context;
+
+private
+ Null_Context : constant Rti_Context := (Base => Null_Address,
+ Block => null);
+end Grt.Rtis_Addr;
diff --git a/src/translate/grt/grt-rtis_binding.ads b/src/translate/grt/grt-rtis_binding.ads
new file mode 100644
index 000000000..7e90eeafc
--- /dev/null
+++ b/src/translate/grt/grt-rtis_binding.ads
@@ -0,0 +1,67 @@
+-- GHDL Run Time (GRT) - Well known RTIs.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Rtis; use Grt.Rtis;
+
+-- Set RTI_ptr defined in grt.rtis_types.
+
+package Grt.Rtis_Binding is
+ pragma Preelaborate (Grt.Rtis_Binding);
+
+ -- Define and set bit and boolean RTIs.
+ Std_Standard_Bit_RTI : aliased Ghdl_Rti_Common;
+
+ Std_Standard_Boolean_RTI : aliased Ghdl_Rti_Common;
+
+ pragma Import (C, Std_Standard_Bit_RTI,
+ "std__standard__bit__RTI");
+
+ pragma Import (C, Std_Standard_Boolean_RTI,
+ "std__standard__boolean__RTI");
+
+ Std_Standard_Bit_RTI_Ptr : Ghdl_Rti_Access
+ := Std_Standard_Bit_RTI'Access;
+
+ Std_Standard_Boolean_RTI_Ptr : Ghdl_Rti_Access
+ := Std_Standard_Boolean_RTI'Access;
+
+ pragma Export (C, Std_Standard_Bit_RTI_Ptr,
+ "std__standard__bit__RTI_ptr");
+
+ pragma Export (C, Std_Standard_Boolean_RTI_Ptr,
+ "std__standard__boolean__RTI_ptr");
+
+
+ -- Define and set Resolved_Resolv_Ptr.
+ procedure Ieee_Std_Logic_1164_Resolved_RESOLV;
+ pragma Import (C, Ieee_Std_Logic_1164_Resolved_RESOLV,
+ "ieee__std_logic_1164__resolved_RESOLV");
+
+ Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address :=
+ Ieee_Std_Logic_1164_Resolved_RESOLV'Address;
+ pragma Export (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr,
+ "ieee__std_logic_1164__resolved_RESOLV_ptr");
+
+end Grt.Rtis_Binding;
diff --git a/src/translate/grt/grt-rtis_types.adb b/src/translate/grt/grt-rtis_types.adb
new file mode 100644
index 000000000..f22a309bc
--- /dev/null
+++ b/src/translate/grt/grt-rtis_types.adb
@@ -0,0 +1,118 @@
+-- GHDL Run Time (GRT) - Well known RTI types.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Astdio;
+with Grt.Avhpi; use Grt.Avhpi;
+
+package body Grt.Rtis_Types is
+
+ procedure Avhpi_Error (Err : AvhpiErrorT)
+ is
+ use Grt.Astdio;
+ pragma Unreferenced (Err);
+ begin
+ Put_Line ("grt.rtis_utils.Avhpi_Error!");
+ end Avhpi_Error;
+
+ -- Extract std_ulogic type.
+ procedure Search_Types (Pack : VhpiHandleT)
+ is
+ Decl_It : VhpiHandleT;
+ Decl : VhpiHandleT;
+
+ Error : AvhpiErrorT;
+ Name : String (1 .. 16);
+ Name_Len : Natural;
+ Rti : Ghdl_Rti_Access;
+ begin
+ Vhpi_Get_Str (VhpiLibLogicalNameP, Pack, Name, Name_Len);
+ if not (Name_Len = 4 and then Name (1 .. 4)= "ieee") then
+ return;
+ end if;
+
+ Vhpi_Iterator (VhpiDecls, Pack, Decl_It, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ -- Extract packages.
+ loop
+ Vhpi_Scan (Decl_It, Decl, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ if Vhpi_Get_Kind (Decl) = VhpiEnumTypeDeclK then
+ Vhpi_Get_Str (VhpiNameP, Decl, Name, Name_Len);
+ Rti := Avhpi_Get_Rti (Decl);
+ if Name_Len = 10 and then Name (1 .. 10) = "std_ulogic" then
+ Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr := Rti;
+ end if;
+ end if;
+ end loop;
+ end Search_Types;
+
+ procedure Search_Packages
+ is
+ Pack : VhpiHandleT;
+ Pack_It : VhpiHandleT;
+
+ Error : AvhpiErrorT;
+ Name : String (1 .. 16);
+ Name_Len : Natural;
+ begin
+ Get_Package_Inst (Pack_It);
+
+ -- Extract packages.
+ loop
+ Vhpi_Scan (Pack_It, Pack, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ Vhpi_Get_Str (VhpiNameP, Pack, Name, Name_Len);
+ if Name_Len = 14 and then Name (1 .. 14) = "std_logic_1164" then
+ Search_Types (Pack);
+ end if;
+ end loop;
+ end Search_Packages;
+
+ Search_Types_RTI_Done : Boolean := False;
+
+ procedure Search_Types_RTI is
+ begin
+ if Search_Types_RTI_Done then
+ return;
+ else
+ Search_Types_RTI_Done := True;
+ end if;
+
+ Search_Packages;
+ end Search_Types_RTI;
+end Grt.Rtis_Types;
diff --git a/src/translate/grt/grt-rtis_types.ads b/src/translate/grt/grt-rtis_types.ads
new file mode 100644
index 000000000..f64b17324
--- /dev/null
+++ b/src/translate/grt/grt-rtis_types.ads
@@ -0,0 +1,55 @@
+-- GHDL Run Time (GRT) - Well known RTI types.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Rtis; use Grt.Rtis;
+
+-- This package allow access to RTIs of some types.
+-- This is used to recognize some VHDL logic types.
+-- This is also used by grt.signals to set types of some implicit signals
+-- (such as 'stable or 'transation).
+
+package Grt.Rtis_Types is
+ -- RTIs for some logic types.
+ Std_Standard_Bit_RTI_Ptr : Ghdl_Rti_Access;
+
+ Std_Standard_Boolean_RTI_Ptr : Ghdl_Rti_Access;
+
+ -- std_ulogic.
+ -- A VHDL may not contain ieee.std_logic_1164 package. So, this RTI
+ -- must be dynamicaly searched.
+ Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr : Ghdl_Rti_Access := null;
+
+ -- Search RTI for types.
+ -- If a type is not found, its RTI is set to null.
+ -- If this procedure has already been called, then this is a noop.
+ procedure Search_Types_RTI;
+private
+ -- These are set either by grt.rtis_binding or by ghdlrun.
+ -- This is not very clean...
+ pragma Import (C, Std_Standard_Bit_RTI_Ptr,
+ "std__standard__bit__RTI_ptr");
+
+ pragma Import (C, Std_Standard_Boolean_RTI_Ptr,
+ "std__standard__boolean__RTI_ptr");
+end Grt.Rtis_Types;
diff --git a/src/translate/grt/grt-rtis_utils.adb b/src/translate/grt/grt-rtis_utils.adb
new file mode 100644
index 000000000..0d4328e7e
--- /dev/null
+++ b/src/translate/grt/grt-rtis_utils.adb
@@ -0,0 +1,660 @@
+-- GHDL Run Time (GRT) - RTI utilities.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+--with Grt.Disp; use Grt.Disp;
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Rtis_Utils is
+
+ function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result
+ is
+ function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result;
+
+ function Traverse_Blocks_1 (Ctxt : Rti_Context) return Traverse_Result
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+
+ Res : Traverse_Result;
+ Nctxt : Rti_Context;
+ Index : Ghdl_Index_Type;
+ Child : Ghdl_Rti_Access;
+ begin
+ Res := Process (Ctxt, Ctxt.Block);
+ if Res /= Traverse_Ok then
+ return Res;
+ end if;
+
+ Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+ Index := 0;
+ while Index < Blk.Nbr_Child loop
+ Child := Blk.Children (Index);
+ Index := Index + 1;
+ case Child.Kind is
+ when Ghdl_Rtik_Process
+ | Ghdl_Rtik_Block =>
+ declare
+ Nblk : Ghdl_Rtin_Block_Acc;
+ begin
+ Nblk := To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt := (Base => Ctxt.Base + Nblk.Loc,
+ Block => Child);
+ Res := Traverse_Blocks_1 (Nctxt);
+ end;
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Nblk : Ghdl_Rtin_Block_Acc;
+ Length : Ghdl_Index_Type;
+ begin
+ Nblk := To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt :=
+ (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all,
+ Block => Child);
+ Length := Get_For_Generate_Length (Nblk, Ctxt);
+ for I in 1 .. Length loop
+ Res := Traverse_Blocks_1 (Nctxt);
+ exit when Res = Traverse_Stop;
+ Nctxt.Base := Nctxt.Base + Nblk.Size;
+ end loop;
+ end;
+ when Ghdl_Rtik_If_Generate =>
+ declare
+ Nblk : Ghdl_Rtin_Block_Acc;
+ begin
+ Nblk := To_Ghdl_Rtin_Block_Acc (Child);
+ Nctxt :=
+ (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all,
+ Block => Child);
+ if Nctxt.Base /= Null_Address then
+ Res := Traverse_Blocks_1 (Nctxt);
+ end if;
+ end;
+ when Ghdl_Rtik_Instance =>
+ Res := Process (Ctxt, Child);
+ if Res = Traverse_Ok then
+ declare
+ Obj : Ghdl_Rtin_Instance_Acc;
+ begin
+ Obj := To_Ghdl_Rtin_Instance_Acc (Child);
+
+ Get_Instance_Context (Obj, Ctxt, Nctxt);
+ if Nctxt /= Null_Context then
+ Res := Traverse_Instance (Nctxt);
+ end if;
+ end;
+ end if;
+ when Ghdl_Rtik_Package
+ | Ghdl_Rtik_Entity
+ | Ghdl_Rtik_Architecture =>
+ Internal_Error ("traverse_blocks");
+ when Ghdl_Rtik_Port
+ | Ghdl_Rtik_Signal
+ | Ghdl_Rtik_Guard
+ | Ghdl_Rtik_Attribute_Quiet
+ | Ghdl_Rtik_Attribute_Stable
+ | Ghdl_Rtik_Attribute_Transaction =>
+ Res := Process (Ctxt, Child);
+ when others =>
+ null;
+ end case;
+ exit when Res = Traverse_Stop;
+ end loop;
+
+ return Res;
+ end Traverse_Blocks_1;
+
+ function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+
+ Res : Traverse_Result;
+ Nctxt : Rti_Context;
+
+ begin
+ Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+ case Blk.Common.Kind is
+ when Ghdl_Rtik_Architecture =>
+ Nctxt := (Base => Ctxt.Base,
+ Block => Blk.Parent);
+ -- The entity.
+ Res := Traverse_Blocks_1 (Nctxt);
+ if Res /= Traverse_Stop then
+ -- The architecture.
+ Res := Traverse_Blocks_1 (Ctxt);
+ end if;
+ when Ghdl_Rtik_Package_Body =>
+ Nctxt := (Base => Ctxt.Base,
+ Block => Blk.Parent);
+ Res := Traverse_Blocks_1 (Nctxt);
+ when others =>
+ Internal_Error ("traverse_blocks");
+ end case;
+ return Res;
+ end Traverse_Instance;
+ begin
+ return Traverse_Instance (Ctxt);
+ end Traverse_Blocks;
+
+ -- Disp value stored at ADDR and whose type is described by RTI.
+ procedure Get_Enum_Value
+ (Vstr : in out Vstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type)
+ is
+ Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+ begin
+ Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Append (Vstr, Enum_Rti.Names (Val));
+ end Get_Enum_Value;
+
+
+ procedure Foreach_Scalar (Ctxt : Rti_Context;
+ Obj_Type : Ghdl_Rti_Access;
+ Obj_Addr : Address;
+ Is_Sig : Boolean;
+ Param : Param_Type)
+ is
+ -- Current address.
+ Addr : Address;
+
+ Name : Vstring;
+
+ procedure Handle_Any (Rti : Ghdl_Rti_Access);
+
+ procedure Handle_Scalar (Rti : Ghdl_Rti_Access)
+ is
+ procedure Update (S : Ghdl_Index_Type) is
+ begin
+ Addr := Addr + (S / Storage_Unit);
+ end Update;
+ begin
+ Process (Addr, Name, Rti, Param);
+
+ if Is_Sig then
+ Update (Address'Size);
+ else
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ Update (32);
+ when Ghdl_Rtik_Type_E8 =>
+ Update (8);
+ when Ghdl_Rtik_Type_E32 =>
+ Update (32);
+ when Ghdl_Rtik_Type_B1 =>
+ Update (8);
+ when Ghdl_Rtik_Type_F64 =>
+ Update (64);
+ when Ghdl_Rtik_Type_P64 =>
+ Update (64);
+ when others =>
+ Internal_Error ("handle_scalar");
+ end case;
+ end if;
+ end Handle_Scalar;
+
+ procedure Range_Pos_To_Val (Rti : Ghdl_Rti_Access;
+ Rng : Ghdl_Range_Ptr;
+ Pos : Ghdl_Index_Type;
+ Val : out Value_Union)
+ is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ case Rng.I32.Dir is
+ when Dir_To =>
+ Val.I32 := Rng.I32.Left + Ghdl_I32 (Pos);
+ when Dir_Downto =>
+ Val.I32 := Rng.I32.Left - Ghdl_I32 (Pos);
+ end case;
+ when Ghdl_Rtik_Type_E8 =>
+ case Rng.E8.Dir is
+ when Dir_To =>
+ Val.E8 := Rng.E8.Left + Ghdl_E8 (Pos);
+ when Dir_Downto =>
+ Val.E8 := Rng.E8.Left - Ghdl_E8 (Pos);
+ end case;
+ when Ghdl_Rtik_Type_E32 =>
+ case Rng.E32.Dir is
+ when Dir_To =>
+ Val.E32 := Rng.E32.Left + Ghdl_E32 (Pos);
+ when Dir_Downto =>
+ Val.E32 := Rng.E32.Left - Ghdl_E32 (Pos);
+ end case;
+ when Ghdl_Rtik_Type_B1 =>
+ case Pos is
+ when 0 =>
+ Val.B1 := Rng.B1.Left;
+ when 1 =>
+ Val.B1 := Rng.B1.Right;
+ when others =>
+ Val.B1 := False;
+ end case;
+ when others =>
+ Internal_Error ("grt.rtis_utils.range_pos_to_val");
+ end case;
+ end Range_Pos_To_Val;
+
+ procedure Pos_To_Vstring
+ (Vstr : in out Vstring;
+ Rti : Ghdl_Rti_Access;
+ Rng : Ghdl_Range_Ptr;
+ Pos : Ghdl_Index_Type)
+ is
+ V : Value_Union;
+ begin
+ Range_Pos_To_Val (Rti, Rng, Pos, V);
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ declare
+ S : String (1 .. 12);
+ F : Natural;
+ begin
+ To_String (S, F, V.I32);
+ Append (Vstr, S (F .. S'Last));
+ end;
+ when Ghdl_Rtik_Type_E8 =>
+ Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E8));
+ when Ghdl_Rtik_Type_E32 =>
+ Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E32));
+ when Ghdl_Rtik_Type_B1 =>
+ Get_Enum_Value (Vstr, Rti, Ghdl_B1'Pos (V.B1));
+ when others =>
+ Append (Vstr, '?');
+ end case;
+ end Pos_To_Vstring;
+
+ procedure Handle_Array_1 (El_Rti : Ghdl_Rti_Access;
+ Rngs : Ghdl_Range_Array;
+ Rtis : Ghdl_Rti_Arr_Acc;
+ Index : Ghdl_Index_Type)
+ is
+ Len : Ghdl_Index_Type;
+ P : Natural;
+ Base_Type : Ghdl_Rti_Access;
+ begin
+ P := Length (Name);
+ if Index = 0 then
+ Append (Name, '(');
+ else
+ Append (Name, ',');
+ end if;
+
+ Base_Type := Get_Base_Type (Rtis (Index));
+ Len := Range_To_Length (Rngs (Index), Base_Type);
+
+ for I in 1 .. Len loop
+ Pos_To_Vstring (Name, Base_Type, Rngs (Index), I - 1);
+ if Index = Rngs'Last then
+ Append (Name, ')');
+ Handle_Any (El_Rti);
+ else
+ Handle_Array_1 (El_Rti, Rngs, Rtis, Index + 1);
+ end if;
+ Truncate (Name, P + 1);
+ end loop;
+ Truncate (Name, P);
+ end Handle_Array_1;
+
+ procedure Handle_Array (Rti : Ghdl_Rtin_Type_Array_Acc;
+ Vals : Ghdl_Uc_Array_Acc)
+ is
+ Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim;
+ Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1);
+ begin
+ Bound_To_Range (Vals.Bounds, Rti, Rngs);
+ Addr := Vals.Base;
+ Handle_Array_1 (Rti.Element, Rngs, Rti.Indexes, 0);
+ end Handle_Array;
+
+ procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc)
+ is
+ El : Ghdl_Rtin_Element_Acc;
+ Obj_Addr : Address;
+ Last_Addr : Address;
+ P : Natural;
+ begin
+ P := Length (Name);
+ Obj_Addr := Addr;
+ Last_Addr := Addr;
+ for I in 1 .. Rti.Nbrel loop
+ El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1));
+ if Is_Sig then
+ Addr := Obj_Addr + El.Sig_Off;
+ else
+ Addr := Obj_Addr + El.Val_Off;
+ end if;
+ if Rti_Complex_Type (El.Eltype) then
+ Addr := Obj_Addr + To_Ghdl_Index_Acc (Addr).all;
+ end if;
+ Append (Name, '.');
+ Append (Name, El.Name);
+ Handle_Any (El.Eltype);
+ if Addr > Last_Addr then
+ Last_Addr := Addr;
+ end if;
+ Truncate (Name, P);
+ end loop;
+ Addr := Last_Addr;
+ end Handle_Record;
+
+ procedure Handle_Any (Rti : Ghdl_Rti_Access) is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Handle_Scalar (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype);
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32
+ | Ghdl_Rtik_Type_B1 =>
+ Handle_Scalar (Rti);
+ when Ghdl_Rtik_Type_Array =>
+ Handle_Array (To_Ghdl_Rtin_Type_Array_Acc (Rti),
+ To_Ghdl_Uc_Array_Acc (Addr));
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ St : constant Ghdl_Rtin_Subtype_Array_Acc :=
+ To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype;
+ Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
+ begin
+ Bound_To_Range
+ (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs);
+ Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0);
+ end;
+-- when Ghdl_Rtik_Type_File =>
+-- declare
+-- Vptr : Ghdl_Value_Ptr;
+-- begin
+-- Vptr := To_Ghdl_Value_Ptr (Obj);
+-- Put (Stream, "File#");
+-- Put_I32 (Stream, Vptr.I32);
+-- -- FIXME: update OBJ (not very useful since never in a
+-- -- composite type).
+-- end;
+ when Ghdl_Rtik_Type_Record =>
+ Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti));
+ when others =>
+ Internal_Error ("grt.rtis_utils.foreach_scalar.handle_any");
+ end case;
+ end Handle_Any;
+ begin
+ if Rti_Complex_Type (Obj_Type) then
+ Addr := To_Addr_Acc (Obj_Addr).all;
+ else
+ Addr := Obj_Addr;
+ end if;
+ Handle_Any (Obj_Type);
+ Free (Name);
+ end Foreach_Scalar;
+
+ procedure Get_Value (Str : in out Vstring;
+ Value : Value_Union;
+ Type_Rti : Ghdl_Rti_Access)
+ is
+ begin
+ case Type_Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ declare
+ S : String (1 .. 12);
+ F : Natural;
+ begin
+ To_String (S, F, Value.I32);
+ Append (Str, S (F .. S'Last));
+ end;
+ when Ghdl_Rtik_Type_E8 =>
+ Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E8));
+ when Ghdl_Rtik_Type_E32 =>
+ Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E32));
+ when Ghdl_Rtik_Type_B1 =>
+ Get_Enum_Value
+ (Str, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1)));
+ when Ghdl_Rtik_Type_F64 =>
+ declare
+ S : String (1 .. 32);
+ L : Integer;
+
+ function Snprintf_G (Cstr : Address;
+ Size : Natural;
+ Arg : Ghdl_F64)
+ return Integer;
+ pragma Import (C, Snprintf_G, "__ghdl_snprintf_g");
+
+ begin
+ L := Snprintf_G (S'Address, S'Length, Value.F64);
+ if L < 0 then
+ -- FIXME.
+ Append (Str, "?");
+ else
+ Append (Str, S (1 .. L));
+ end if;
+ end;
+ when Ghdl_Rtik_Type_P32 =>
+ declare
+ S : String (1 .. 12);
+ F : Natural;
+ begin
+ To_String (S, F, Value.I32);
+ Append (Str, S (F .. S'Last));
+ Append
+ (Str, Get_Physical_Unit_Name
+ (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0)));
+ end;
+ when Ghdl_Rtik_Type_P64 =>
+ declare
+ S : String (1 .. 21);
+ F : Natural;
+ begin
+ To_String (S, F, Value.I64);
+ Append (Str, S (F .. S'Last));
+ Append
+ (Str, Get_Physical_Unit_Name
+ (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0)));
+ end;
+ when others =>
+ Internal_Error ("grt.rtis_utils.get_value");
+ end case;
+ end Get_Value;
+
+ procedure Disp_Value (Stream : FILEs;
+ Value : Value_Union;
+ Type_Rti : Ghdl_Rti_Access)
+ is
+ Name : Vstring;
+ begin
+ Rtis_Utils.Get_Value (Name, Value, Type_Rti);
+ Put (Stream, Name);
+ Free (Name);
+ end Disp_Value;
+
+ function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access)
+ return Ghdl_C_String
+ is
+ begin
+ case Unit.Kind is
+ when Ghdl_Rtik_Unit64 =>
+ return To_Ghdl_Rtin_Unit64_Acc (Unit).Name;
+ when Ghdl_Rtik_Unitptr =>
+ return To_Ghdl_Rtin_Unitptr_Acc (Unit).Name;
+ when others =>
+ Internal_Error ("rtis_utils.physical_unit_name");
+ end case;
+ end Get_Physical_Unit_Name;
+
+ function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access;
+ Type_Rti : Ghdl_Rti_Access)
+ return Ghdl_I64 is
+ begin
+ case Unit.Kind is
+ when Ghdl_Rtik_Unit64 =>
+ return To_Ghdl_Rtin_Unit64_Acc (Unit).Value;
+ when Ghdl_Rtik_Unitptr =>
+ case Type_Rti.Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ return To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64;
+ when Ghdl_Rtik_Type_P32 =>
+ return Ghdl_I64
+ (To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32);
+ when others =>
+ Internal_Error ("get_physical_unit_value(1)");
+ end case;
+ when others =>
+ Internal_Error ("get_physical_unit_value(2)");
+ end case;
+ end Get_Physical_Unit_Value;
+
+ procedure Get_Enum_Value
+ (Rstr : in out Rstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type)
+ is
+ Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
+ begin
+ Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Prepend (Rstr, Enum_Rti.Names (Val));
+ end Get_Enum_Value;
+
+
+ procedure Get_Value (Rstr : in out Rstring;
+ Addr : Address;
+ Type_Rti : Ghdl_Rti_Access)
+ is
+ Value : constant Ghdl_Value_Ptr := To_Ghdl_Value_Ptr (Addr);
+ begin
+ case Type_Rti.Kind is
+ when Ghdl_Rtik_Type_I32 =>
+ declare
+ S : String (1 .. 12);
+ F : Natural;
+ begin
+ To_String (S, F, Value.I32);
+ Prepend (Rstr, S (F .. S'Last));
+ end;
+ when Ghdl_Rtik_Type_E8 =>
+ Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E8));
+ when Ghdl_Rtik_Type_E32 =>
+ Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E32));
+ when Ghdl_Rtik_Type_B1 =>
+ Get_Enum_Value
+ (Rstr, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1)));
+ when others =>
+ Internal_Error ("grt.rtis_utils.get_value(rstr)");
+ end case;
+ end Get_Value;
+
+ procedure Get_Path_Name (Rstr : in out Rstring;
+ Last_Ctxt : Rti_Context;
+ Sep : Character;
+ Is_Instance : Boolean := True)
+ is
+ Blk : Ghdl_Rtin_Block_Acc;
+ Ctxt : Rti_Context;
+ begin
+ Ctxt := Last_Ctxt;
+ loop
+ Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
+ case Ctxt.Block.Kind is
+ when Ghdl_Rtik_Process
+ | Ghdl_Rtik_Block
+ | Ghdl_Rtik_If_Generate =>
+ Prepend (Rstr, Blk.Name);
+ Prepend (Rstr, Sep);
+ Ctxt := Get_Parent_Context (Ctxt);
+ when Ghdl_Rtik_Entity =>
+ declare
+ Link : Ghdl_Entity_Link_Acc;
+ begin
+ Link := To_Ghdl_Entity_Link_Acc (Ctxt.Base);
+ Ctxt := (Base => Ctxt.Base,
+ Block => Link.Rti);
+ if Ctxt.Block = null then
+ -- Process in an entity.
+ -- FIXME: check.
+ Prepend (Rstr, Blk.Name);
+ return;
+ end if;
+ end;
+ when Ghdl_Rtik_Architecture =>
+ declare
+ Entity_Ctxt: Rti_Context;
+ Link : Ghdl_Entity_Link_Acc;
+ Parent_Inst : Ghdl_Rti_Access;
+ begin
+ -- Architecture name.
+ if Is_Instance then
+ Prepend (Rstr, ')');
+ Prepend (Rstr, Blk.Name);
+ Prepend (Rstr, '(');
+ end if;
+
+ Entity_Ctxt := Get_Parent_Context (Ctxt);
+
+ -- Instance parent.
+ Link := To_Ghdl_Entity_Link_Acc (Entity_Ctxt.Base);
+ Get_Instance_Link (Link, Ctxt, Parent_Inst);
+
+ -- Add entity name.
+ if Is_Instance or Parent_Inst = null then
+ Prepend (Rstr,
+ To_Ghdl_Rtin_Block_Acc (Entity_Ctxt.Block).Name);
+ end if;
+
+ if Parent_Inst = null then
+ -- Top reached.
+ Prepend (Rstr, Sep);
+ return;
+ else
+ -- Instantiation statement label.
+ if Is_Instance then
+ Prepend (Rstr, '@');
+ end if;
+ Prepend (Rstr,
+ To_Ghdl_Rtin_Object_Acc (Parent_Inst).Name);
+ Prepend (Rstr, Sep);
+ end if;
+ end;
+ when Ghdl_Rtik_For_Generate =>
+ declare
+ Iter : Ghdl_Rtin_Object_Acc;
+ Addr : Address;
+ begin
+ Prepend (Rstr, ')');
+ Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
+ Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
+ Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type));
+ Prepend (Rstr, '(');
+ Prepend (Rstr, Blk.Name);
+ Prepend (Rstr, Sep);
+ Ctxt := Get_Parent_Context (Ctxt);
+ end;
+ when others =>
+ Internal_Error ("grt.rtis_utils.get_path_name");
+ end case;
+ end loop;
+ end Get_Path_Name;
+
+ procedure Put (Stream : FILEs; Ctxt : Rti_Context)
+ is
+ Rstr : Rstring;
+ begin
+ Get_Path_Name (Rstr, Ctxt, '.');
+ Put (Stream, Rstr);
+ Free (Rstr);
+ end Put;
+
+end Grt.Rtis_Utils;
diff --git a/src/translate/grt/grt-rtis_utils.ads b/src/translate/grt/grt-rtis_utils.ads
new file mode 100644
index 000000000..10c1a0f28
--- /dev/null
+++ b/src/translate/grt/grt-rtis_utils.ads
@@ -0,0 +1,92 @@
+-- GHDL Run Time (GRT) - RTI utilities.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Vstrings; use Grt.Vstrings;
+with Grt.Stdio; use Grt.Stdio;
+
+package Grt.Rtis_Utils is
+ -- Action to perform after a node was handled by the user function:
+ -- Traverse_Ok: continue to process.
+ -- Traverse_Skip: do not traverse children.
+ -- Traverse_Stop: end of walk.
+ type Traverse_Result is (Traverse_Ok, Traverse_Skip, Traverse_Stop);
+
+ -- An RTI object is a context and an RTI declaration.
+ type Rti_Object is record
+ Obj : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ end record;
+
+ -- Traverse all blocks (package, entities, architectures, block, generate,
+ -- processes).
+ generic
+ with function Process (Ctxt : Rti_Context;
+ Obj : Ghdl_Rti_Access)
+ return Traverse_Result;
+ function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result;
+
+ generic
+ type Param_Type is private;
+ with procedure Process (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param : Param_Type);
+ procedure Foreach_Scalar (Ctxt : Rti_Context;
+ Obj_Type : Ghdl_Rti_Access;
+ Obj_Addr : Address;
+ Is_Sig : Boolean;
+ Param : Param_Type);
+
+ procedure Get_Value (Str : in out Vstring;
+ Value : Value_Union;
+ Type_Rti : Ghdl_Rti_Access);
+
+ -- Get the name of a physical unit.
+ function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access)
+ return Ghdl_C_String;
+
+ -- Get the value of a physical unit.
+ function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access;
+ Type_Rti : Ghdl_Rti_Access)
+ return Ghdl_I64;
+
+ -- Disp a value.
+ procedure Disp_Value (Stream : FILEs;
+ Value : Value_Union;
+ Type_Rti : Ghdl_Rti_Access);
+
+ -- Get context as a path name.
+ -- If IS_INSTANCE is true, the architecture name of entities is added.
+ procedure Get_Path_Name (Rstr : in out Rstring;
+ Last_Ctxt : Rti_Context;
+ Sep : Character;
+ Is_Instance : Boolean := True);
+
+ -- Disp a context as a path.
+ procedure Put (Stream : FILEs; Ctxt : Rti_Context);
+end Grt.Rtis_Utils;
diff --git a/src/translate/grt/grt-sdf.adb b/src/translate/grt/grt-sdf.adb
new file mode 100644
index 000000000..73534e3eb
--- /dev/null
+++ b/src/translate/grt/grt-sdf.adb
@@ -0,0 +1,1389 @@
+-- GHDL Run Time (GRT) - SDF parser.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Stdio; use Grt.Stdio;
+with Grt.C; use Grt.C;
+with Grt.Errors; use Grt.Errors;
+with Ada.Characters.Latin_1;
+with Ada.Unchecked_Deallocation;
+with Grt.Vital_Annotate;
+
+package body Grt.Sdf is
+ EOT : constant Character := Character'Val (4);
+
+ type Sdf_Token_Type is
+ (
+ Tok_Oparen, -- (
+ Tok_Cparen, -- )
+ Tok_Qstring,
+ Tok_Identifier,
+ Tok_Rnumber,
+ Tok_Dnumber,
+ Tok_Div, -- /
+ Tok_Dot, -- .
+ Tok_Cln, -- :
+
+ Tok_Error,
+ Tok_Eof
+ );
+
+ type Sdf_Context_Acc is access Sdf_Context_Type;
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Name => Sdf_Context_Acc, Object => Sdf_Context_Type);
+
+ Sdf_Context : Sdf_Context_Acc;
+
+ -- Current data read from the file.
+ Buf : String_Access (1 .. Buf_Size) := null;
+
+ -- Length of the buffer, including the EOT.
+ Buf_Len : Natural;
+ Pos : Natural;
+ Line_Start : Integer;
+
+ Sdf_Stream : FILEs := NULL_Stream;
+ Sdf_Filename : String_Access := null;
+ Sdf_Line : Natural;
+
+ function Open_Sdf (Filename : String) return Boolean
+ is
+ N_Filename : String (1 .. Filename'Length + 1);
+ Mode : constant String := "rt" & NUL;
+ begin
+ N_Filename (1 .. Filename'Length) := Filename;
+ N_Filename (N_Filename'Last) := NUL;
+ Sdf_Stream := fopen (N_Filename'Address, Mode'Address);
+ if Sdf_Stream = NULL_Stream then
+ Error_C ("cannot open SDF file '");
+ Error_C (Filename);
+ Error_E ("'");
+ return False;
+ end if;
+ Sdf_Context := new Sdf_Context_Type;
+
+ Sdf_Context.Version := Sdf_Version_Unknown;
+
+ -- Set the timescale to 1 ns.
+ Sdf_Context.Timescale := 1000;
+
+ Buf := new String (1 .. Buf_Size);
+ Buf_Len := 1;
+ Buf (1) := EOT;
+ Sdf_Line := 1;
+ Sdf_Filename := new String'(Filename);
+ Pos := 1;
+ Line_Start := 1;
+ return True;
+ end Open_Sdf;
+
+ procedure Close_Sdf
+ is
+ begin
+ fclose (Sdf_Stream);
+ Sdf_Stream := NULL_Stream;
+ Unchecked_Deallocation (Sdf_Context);
+ Unchecked_Deallocation (Buf);
+ end Close_Sdf;
+
+ procedure Read_Sdf
+ is
+ Res : size_t;
+ begin
+ Res := fread (Buf (Pos)'Address, 1, size_t (Read_Size), Sdf_Stream);
+ Line_Start := Line_Start - Buf_Len + Pos;
+ Buf_Len := Pos + Natural (Res);
+ Buf (Buf_Len) := EOT;
+ end Read_Sdf;
+
+
+ Ident_Start : Natural;
+ Ident_End : Natural;
+
+ procedure Read_Append
+ is
+ Len : Natural;
+ begin
+ Len := Pos - Ident_Start;
+ if Ident_Start = 1 or Len >= 1024 then
+ Error_C ("SDF line ");
+ Error_C (Sdf_Line);
+ Error_E (" is too long");
+ return;
+ end if;
+ Buf (1 .. Len) := Buf (Ident_Start .. Ident_Start + Len - 1);
+ Pos := Len + 1;
+ Ident_Start := 1;
+ Read_Sdf;
+ end Read_Append;
+
+ procedure Error_Sdf_C is
+ begin
+ Error_C (Sdf_Filename.all);
+ Error_C (":");
+ Error_C (Sdf_Line);
+ Error_C (":");
+ Error_C (Pos - Line_Start);
+ Error_C (": ");
+ end Error_Sdf_C;
+
+ procedure Error_Sdf (Msg : String) is
+ begin
+ Error_Sdf_C;
+ Error_E (Msg);
+ end Error_Sdf;
+
+ procedure Error_Bad_Character is
+ begin
+ Error_Sdf ("bad character in SDF file");
+ end Error_Bad_Character;
+
+ procedure Scan_Identifier
+ is
+ begin
+ Ident_Start := Pos;
+ loop
+ Pos := Pos + 1;
+ case Buf (Pos) is
+ when 'a' .. 'z'
+ | 'A' .. 'Z'
+ | '0' .. '9'
+ | '_' =>
+ null;
+ when '\' =>
+ Error_Sdf ("escape character not handled");
+ Ident_End := Pos - 1;
+ return;
+ when EOT =>
+ Read_Append;
+ Pos := Pos - 1;
+ when others =>
+ Ident_End := Pos - 1;
+ return;
+ end case;
+ end loop;
+ end Scan_Identifier;
+
+ function Ident_Length return Natural is
+ begin
+ return Ident_End - Ident_Start + 1;
+ end Ident_Length;
+
+ function Is_Ident (Str : String) return Boolean
+ is
+ begin
+ if Ident_Length /= Str'Length then
+ return False;
+ end if;
+ return Buf (Ident_Start .. Ident_End) = Str;
+ end Is_Ident;
+
+ procedure Scan_Qstring
+ is
+ begin
+ Ident_Start := Pos + 1;
+ loop
+ Pos := Pos + 1;
+ case Buf (Pos) is
+ when EOT =>
+ Read_Append;
+ when NUL .. Character'Val (3)
+ | Character'Val (5) .. Character'Val (31)
+ | Character'Val (127) .. Character'Val (255) =>
+ Error_Bad_Character;
+ when ' '
+ | '!'
+ | '#' .. '~' =>
+ null;
+ when '"' => -- "
+ Ident_End := Pos - 1;
+ Pos := Pos + 1;
+ exit;
+ end case;
+ end loop;
+ end Scan_Qstring;
+
+ Scan_Int : Integer;
+ Scan_Exp : Integer;
+
+ function Scan_Number return Sdf_Token_Type
+ is
+ Has_Dot : Boolean;
+ begin
+ Has_Dot := False;
+ Scan_Int := 0;
+ Scan_Exp := 0;
+ loop
+ case Buf (Pos) is
+ when '0' .. '9' =>
+ Scan_Int := Scan_Int * 10
+ + Character'Pos (Buf (Pos)) - Character'Pos ('0');
+ if Has_Dot then
+ Scan_Exp := Scan_Exp - 1;
+ end if;
+ Pos := Pos + 1;
+ when '.' =>
+ if Has_Dot then
+ Error_Bad_Character;
+ return Tok_Error;
+ else
+ Has_Dot := True;
+ end if;
+ Pos := Pos + 1;
+ when EOT =>
+ if Pos /= Buf_Len then
+ Error_Bad_Character;
+ return Tok_Error;
+ end if;
+ Pos := 1;
+ Read_Sdf;
+ exit when Buf_Len = 1;
+ when others =>
+ exit;
+ end case;
+ end loop;
+ if Has_Dot then
+ return Tok_Rnumber;
+ else
+ return Tok_Dnumber;
+ end if;
+ end Scan_Number;
+
+ procedure Refill_Buf is
+ begin
+ Buf (1 .. Buf_Len - Pos) := Buf (Pos .. Buf_Len - 1);
+ Pos := Buf_Len - Pos + 1;
+ Read_Sdf;
+ Pos := 1;
+ end Refill_Buf;
+
+ procedure Skip_Spaces
+ is
+ use Ada.Characters.Latin_1;
+ begin
+ -- Fast blanks skipping.
+ while Buf (Pos) = ' ' loop
+ Pos := Pos + 1;
+ end loop;
+
+ loop
+ -- Be sure there is at least 1 character.
+ if Pos + 1 >= Buf_Len then
+ Refill_Buf;
+ end if;
+
+ case Buf (Pos) is
+ when EOT =>
+ if Pos /= Buf_Len then
+ return;
+ end if;
+ Pos := 1;
+ Read_Sdf;
+ if Buf_Len = 1 then
+ return;
+ end if;
+ when LF =>
+ Pos := Pos + 1;
+ if Buf (Pos) = CR then
+ Pos := Pos + 1;
+ end if;
+ Line_Start := Pos;
+ Sdf_Line := Sdf_Line + 1;
+ when CR =>
+ Pos := Pos + 1;
+ if Buf (Pos) = LF then
+ Pos := Pos + 1;
+ end if;
+ Line_Start := Pos;
+ Sdf_Line := Sdf_Line + 1;
+ when ' '
+ | HT =>
+ Pos := Pos + 1;
+ when '/' =>
+ if Buf (Pos + 1) = '/' then
+ Pos := Pos + 2;
+ -- Skip line comment.
+ loop
+ exit when Buf (Pos) = CR;
+ exit when Buf (Pos) = LF;
+ exit when Buf (Pos) = EOT;
+ Pos := Pos + 1;
+ if Pos >= Buf_Len then
+ Refill_Buf;
+ end if;
+ end loop;
+ else
+ return;
+ end if;
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Skip_Spaces;
+
+ function Get_Token return Sdf_Token_Type
+ is
+ use Ada.Characters.Latin_1;
+ begin
+ Skip_Spaces;
+
+ -- Be sure there is at least 4 characters.
+ if Pos + 4 >= Buf_Len then
+ Refill_Buf;
+ end if;
+
+ case Buf (Pos) is
+ when EOT =>
+ if Buf_Len = 1 then
+ return Tok_Eof;
+ else
+ Error_Bad_Character;
+ return Tok_Error;
+ end if;
+ when '"' => -- "
+ Scan_Qstring;
+ return Tok_Qstring;
+ when '/' =>
+ -- Skip_Spaces has already handled line comments.
+ Pos := Pos + 1;
+ return Tok_Div;
+ when '.' =>
+ Pos := Pos + 1;
+ return Tok_Dot;
+ when ':' =>
+ Pos := Pos + 1;
+ return Tok_Cln;
+ when '(' =>
+ Pos := Pos + 1;
+ return Tok_Oparen;
+ when ')' =>
+ Pos := Pos + 1;
+ return Tok_Cparen;
+ when 'a' .. 'z'
+ | 'A' .. 'Z' =>
+ Scan_Identifier;
+ return Tok_Identifier;
+ when '0' .. '9' =>
+ return Scan_Number;
+ when others =>
+ Error_Bad_Character;
+ return Tok_Error;
+ end case;
+ end Get_Token;
+
+ function Is_White_Space (C : Character) return Boolean
+ is
+ use Ada.Characters.Latin_1;
+ begin
+ case C is
+ when ' '
+ | HT
+ | CR
+ | LF =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Is_White_Space;
+
+ function Get_Edge_Token return Edge_Type
+ is
+ use Ada.Characters.Latin_1;
+ begin
+ Skip_Spaces;
+
+ -- Be sure there is at least 4 characters.
+ if Pos + 4 >= Buf_Len then
+ Refill_Buf;
+ end if;
+
+ case Buf (Pos) is
+ when '0' =>
+ if Is_White_Space (Buf (Pos + 2)) then
+ if Buf (Pos + 1) = 'z' then
+ Pos := Pos + 2;
+ return Edge_0z;
+ elsif Buf (Pos + 1) = '1' then
+ Pos := Pos + 2;
+ return Edge_01;
+ end if;
+ end if;
+ when '1' =>
+ if Is_White_Space (Buf (Pos + 2)) then
+ if Buf (Pos + 1) = 'z' then
+ Pos := Pos + 2;
+ return Edge_1z;
+ elsif Buf (Pos + 1) = '0' then
+ Pos := Pos + 2;
+ return Edge_10;
+ end if;
+ end if;
+ when 'z' =>
+ if Is_White_Space (Buf (Pos + 2)) then
+ if Buf (Pos + 1) = '0' then
+ Pos := Pos + 2;
+ return Edge_Z0;
+ elsif Buf (Pos + 1) = '1' then
+ Pos := Pos + 2;
+ return Edge_Z1;
+ end if;
+ end if;
+ when 'p' =>
+ Scan_Identifier;
+ if Is_Ident ("posedge") then
+ return Edge_Posedge;
+ end if;
+ when 'n' =>
+ Scan_Identifier;
+ if Is_Ident ("negedge") then
+ return Edge_Negedge;
+ end if;
+ when others =>
+ null;
+ end case;
+ Error_Sdf ("edge_identifier expected");
+ return Edge_Error;
+ end Get_Edge_Token;
+
+ procedure Error_Sdf (Tok : Sdf_Token_Type)
+ is
+ begin
+ case Tok is
+ when Tok_Qstring =>
+ Error_Sdf ("qstring expected");
+ when Tok_Oparen =>
+ Error_Sdf ("'(' expected");
+ when Tok_Identifier =>
+ Error_Sdf ("identifier expected");
+ when Tok_Cln =>
+ Error_Sdf ("':' (colon) expected");
+ when others =>
+ Error_Sdf ("parse error");
+ end case;
+ end Error_Sdf;
+
+ function Expect (Tok : Sdf_Token_Type) return Boolean
+ is
+ begin
+ if Get_Token = Tok then
+ return True;
+ end if;
+ Error_Sdf (Tok);
+ return False;
+ end Expect;
+
+ function Expect_Cp_Op_Ident (Tok : Sdf_Token_Type) return Boolean
+ is
+ begin
+ if Tok /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ return False;
+ end if;
+ if not Expect (Tok_Oparen)
+ or else not Expect (Tok_Identifier)
+ then
+ return False;
+ end if;
+ return True;
+ end Expect_Cp_Op_Ident;
+
+ function Expect_Qstr_Cp_Op_Ident (Str : String) return Boolean
+ is
+ Tok : Sdf_Token_Type;
+ begin
+ if not Is_Ident (Str) then
+ return True;
+ end if;
+
+ Tok := Get_Token;
+ if Tok = Tok_Qstring then
+ Tok := Get_Token;
+ end if;
+
+ return Expect_Cp_Op_Ident (Tok);
+ end Expect_Qstr_Cp_Op_Ident;
+
+ procedure Start_Generic_Name (Kind : Timing_Generic_Kind) is
+ begin
+ Sdf_Context.Kind := Kind;
+ Sdf_Context.Port_Num := 0;
+ Sdf_Context.Ports (1).L := Invalid_Dnumber;
+ Sdf_Context.Ports (2).L := Invalid_Dnumber;
+ Sdf_Context.Ports (1).Edge := Edge_None;
+ Sdf_Context.Ports (2).Edge := Edge_None;
+ end Start_Generic_Name;
+
+ -- Status of a parsing.
+ -- ERROR: parse error (syntax is not correct)
+ -- ALTERN: alternate construct parsed (ie simple RNUMBER for tc_rvalue).
+ -- OPTIONAL: the construct is absent.
+ -- FOUND: the construct is present.
+ -- SET: the construct is present and a value was extracted from.
+ type Parse_Status_Type is
+ (
+ Status_Error,
+ Status_Altern,
+ Status_Optional,
+ Status_Found,
+ Status_Set
+ );
+
+ function Num_To_Time return Ghdl_I64
+ is
+ Res : Ghdl_I64;
+ begin
+ Res := Ghdl_I64 (Scan_Int) * Ghdl_I64 (Sdf_Context.Timescale);
+ while Scan_Exp < 0 loop
+ Res := Res / 10;
+ Scan_Exp := Scan_Exp + 1;
+ end loop;
+ return Res;
+ end Num_To_Time;
+
+ -- Parse: REXPRESSION? ')'
+ procedure Parse_Rexpression
+ (Status : out Parse_Status_Type; Val : out Ghdl_I64)
+ is
+ Tok : Sdf_Token_Type;
+
+ procedure Pr_Rnumber (Mtm : Mtm_Type)
+ is
+ begin
+ if Tok = Tok_Rnumber or Tok = Tok_Dnumber then
+ if Mtm = Sdf_Mtm then
+ Val := Num_To_Time;
+ Status := Status_Set;
+ elsif Status /= Status_Set then
+ Status := Status_Found;
+ end if;
+ Tok := Get_Token;
+ end if;
+ end Pr_Rnumber;
+
+ function Pr_Colon return Boolean
+ is
+ begin
+ if Tok /= Tok_Cln then
+ Error_Sdf (Tok_Cln);
+ Status := Status_Error;
+ return False;
+ else
+ Tok := Get_Token;
+ return True;
+ end if;
+ end Pr_Colon;
+
+ begin
+ Val := 0;
+ Tok := Get_Token;
+ Status := Status_Error;
+ if Tok = Tok_Cparen then
+ Status := Status_Optional;
+ return;
+ end if;
+
+ Pr_Rnumber (Minimum);
+
+ if not Pr_Colon then
+ return;
+ end if;
+
+ Pr_Rnumber (Typical);
+
+ if not Pr_Colon then
+ return;
+ end if;
+
+ Pr_Rnumber (Maximum);
+
+ if Status = Status_Error then
+ Error_Sdf ("at least one number required in an rexpression");
+ return;
+ end if;
+
+ if Tok /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ Status := Status_Error;
+ end if;
+ end Parse_Rexpression;
+
+ function Expect_Rexpr_Cp_Op_Ident return Boolean
+ is
+ Status : Parse_Status_Type;
+ Val : Ghdl_I64;
+ begin
+ Parse_Rexpression (Status, Val);
+ if Status = Status_Error then
+ return False;
+ end if;
+ if not Expect (Tok_Oparen)
+ or else not Expect (Tok_Identifier)
+ then
+ Error_Sdf (Tok_Identifier);
+ return False;
+ end if;
+ return True;
+ end Expect_Rexpr_Cp_Op_Ident;
+
+ function To_Lower (C : Character) return Character is
+ begin
+ if C >= 'A' and C <= 'Z' then
+ return Character'Val (Character'Pos (C)
+ - Character'Pos ('A') + Character'Pos ('a'));
+ else
+ return C;
+ end if;
+ end To_Lower;
+
+ function Parse_Port_Path1 (Tok : Sdf_Token_Type) return Boolean
+ is
+ Port_Spec : Port_Spec_Type
+ renames Sdf_Context.Ports (Sdf_Context.Port_Num);
+ Len : Natural;
+ begin
+ if Tok /= Tok_Identifier then
+ Error_Sdf ("port path expected");
+ return False;
+ end if;
+ Len := 0;
+ for I in Ident_Start .. Ident_End loop
+ Len := Len + 1;
+ Port_Spec.Name (Len) := To_Lower (Buf (I));
+ end loop;
+ Port_Spec.Name_Len := Len;
+
+ -- Parse [ DNUMBER ]
+ -- | [ DNUMBER : DNUMBER ]
+ Skip_Spaces;
+ if Buf (Pos) = '[' then
+ Port_Spec.R := Invalid_Dnumber;
+ Pos := Pos + 1;
+ if Get_Token /= Tok_Dnumber then
+ Error_Sdf (Tok);
+ else
+ Port_Spec.L := Ghdl_I32 (Scan_Int);
+ end if;
+ Skip_Spaces;
+ if Buf (Pos) = ':' then
+ Pos := Pos + 1;
+ if Get_Token /= Tok_Dnumber then
+ Error_Sdf (Tok);
+ else
+ Port_Spec.R := Ghdl_I32 (Scan_Int);
+ end if;
+ Skip_Spaces;
+ end if;
+ if Buf (Pos) /= ']' then
+ Error_Sdf ("']' expected");
+ else
+ Pos := Pos + 1;
+ end if;
+ end if;
+
+ return True;
+ end Parse_Port_Path1;
+
+ function Parse_Port_Path return Boolean
+ is
+ begin
+ Sdf_Context.Port_Num := Sdf_Context.Port_Num + 1;
+ return Parse_Port_Path1 (Get_Token);
+ end Parse_Port_Path;
+
+ function Parse_Port_Spec return Boolean
+ is
+ Tok : Sdf_Token_Type;
+ Edge : Edge_Type;
+ begin
+ Sdf_Context.Port_Num := Sdf_Context.Port_Num + 1;
+ Tok := Get_Token;
+ if Tok = Tok_Identifier then
+ return Parse_Port_Path1 (Tok);
+ elsif Tok /= Tok_Oparen then
+ Error_Sdf ("port spec expected");
+ return False;
+ end if;
+ Edge := Get_Edge_Token;
+ if Edge = Edge_Error then
+ return False;
+ end if;
+ Sdf_Context.Ports (Sdf_Context.Port_Num).Edge := Edge;
+ if not Parse_Port_Path1 (Get_Token) then
+ return False;
+ end if;
+ if Get_Token /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ return False;
+ end if;
+ return True;
+ end Parse_Port_Spec;
+
+ function Parse_Port_Tchk return Boolean renames Parse_Port_Spec;
+
+ -- tc_rvalue ::= ( RNUMBER )
+ -- ||= ( rexpression )
+ -- Return status_optional for ( )
+ function Parse_Tc_Rvalue return Parse_Status_Type
+ is
+ Tok : Sdf_Token_Type;
+ Res : Parse_Status_Type;
+ begin
+ -- '('
+ if Get_Token /= Tok_Oparen then
+ Error_Sdf (Tok_Oparen);
+ return Status_Error;
+ end if;
+ Res := Status_Found;
+ Tok := Get_Token;
+ if Tok = Tok_Rnumber or Tok = Tok_Dnumber then
+ Sdf_Context.Timing (1) := Num_To_Time;
+ Tok := Get_Token;
+ if Tok = Tok_Cparen then
+ -- This is a simple RNUMBER.
+ return Status_Altern;
+ end if;
+ if Sdf_Mtm = Minimum then
+ Res := Status_Set;
+ end if;
+ end if;
+ if Tok = Tok_Cparen then
+ return Status_Optional;
+ end if;
+ if Tok /= Tok_Cln then
+ Error_Sdf (Tok_Cln);
+ return Status_Error;
+ end if;
+ Tok := Get_Token;
+ if Tok = Tok_Rnumber or Tok = Tok_Dnumber then
+ if Sdf_Mtm = Typical then
+ Sdf_Context.Timing (1) := Num_To_Time;
+ Res := Status_Set;
+ end if;
+ Tok := Get_Token;
+ end if;
+ if Tok /= Tok_Cln then
+ Error_Sdf (Tok_Cln);
+ return Status_Error;
+ end if;
+ Tok := Get_Token;
+ if Tok = Tok_Rnumber or Tok = Tok_Dnumber then
+ if Sdf_Mtm = Maximum then
+ Sdf_Context.Timing (1) := Num_To_Time;
+ Res := Status_Set;
+ end if;
+ Tok := Get_Token;
+ end if;
+ if Tok /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ return Status_Error;
+ end if;
+ return Res;
+ end Parse_Tc_Rvalue;
+
+ function Parse_Simple_Tc_Rvalue return Boolean is
+ begin
+ Sdf_Context.Timing_Nbr := 0;
+
+ case Parse_Tc_Rvalue is
+ when Status_Error
+ | Status_Optional =>
+ return False;
+ when Status_Altern =>
+ null;
+ when Status_Found =>
+ Sdf_Context.Timing_Set (1) := False;
+ when Status_Set =>
+ Sdf_Context.Timing_Set (1) := True;
+ end case;
+ return True;
+ end Parse_Simple_Tc_Rvalue;
+
+ -- rvalue ::= ( RNUMBER )
+ -- ||= rexp_list
+ -- Parse: rvalue )
+ function Parse_Rvalue return Boolean
+ is
+ Tok : Sdf_Token_Type;
+ begin
+ Sdf_Context.Timing_Nbr := 0;
+ Sdf_Context.Timing_Set := (others => False);
+
+ case Parse_Tc_Rvalue is
+ when Status_Error =>
+ return False;
+ when Status_Altern =>
+ Sdf_Context.Timing_Nbr := 1;
+ if Get_Token /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ end if;
+ return True;
+ when Status_Found
+ | Status_Optional =>
+ null;
+ when Status_Set =>
+ Sdf_Context.Timing_Set (1) := True;
+ end case;
+
+ Sdf_Context.Timing_Nbr := 1;
+ loop
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ if Tok /= Tok_Oparen then
+ Error_Sdf (Tok_Oparen);
+ return False;
+ end if;
+
+ Sdf_Context.Timing_Nbr := Sdf_Context.Timing_Nbr + 1;
+ declare
+ Status : Parse_Status_Type;
+ Val : Ghdl_I64;
+ begin
+ Parse_Rexpression (Status, Val);
+ case Status is
+ when Status_Error
+ | Status_Altern =>
+ return False;
+ when Status_Optional
+ | Status_Found =>
+ null;
+ when Status_Set =>
+ Sdf_Context.Timing_Set (Sdf_Context.Timing_Nbr) := True;
+ Sdf_Context.Timing (Sdf_Context.Timing_Nbr) := Val;
+ end case;
+ end;
+ end loop;
+ if Boolean'(False) then
+ -- Do not expand here, since the most used is 01.
+ case Sdf_Context.Timing_Nbr is
+ when 1 =>
+ for I in 2 .. 6 loop
+ Sdf_Context.Timing (I) := Sdf_Context.Timing (1);
+ Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (1);
+ end loop;
+ when 2 =>
+ for I in 3 .. 4 loop
+ Sdf_Context.Timing (I) := Sdf_Context.Timing (1);
+ Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (1);
+ end loop;
+ for I in 5 .. 6 loop
+ Sdf_Context.Timing (I) := Sdf_Context.Timing (2);
+ Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (2);
+ end loop;
+ when 3 =>
+ for I in 4 .. 6 loop
+ Sdf_Context.Timing (I) := Sdf_Context.Timing (I - 3);
+ Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (I - 3);
+ end loop;
+ when 6
+ | 12 =>
+ null;
+ when others =>
+ Error_Sdf ("bad number of rvalue");
+ return False;
+ end case;
+ end if;
+ return True;
+ end Parse_Rvalue;
+
+ function Handle_Generic return Boolean
+ is
+ Name : String (1 .. 1024);
+ Len : Natural;
+
+ procedure Start (Str : String) is
+ begin
+ Name (1 .. Str'Length) := Str;
+ Len := Str'Length;
+ end Start;
+
+ procedure Add (Str : String)
+ is
+ Nlen : Natural;
+ begin
+ Len := Len + 1;
+ Name (Len) := '_';
+ Nlen := Len + Str'Length;
+ Name (Len + 1 .. Nlen) := Str;
+ Len := Nlen;
+ end Add;
+
+ procedure Add_Edge (Edge : Edge_Type; Force : Boolean) is
+ begin
+ case Edge is
+ when Edge_Posedge =>
+ Add ("posedge");
+ when Edge_Negedge =>
+ Add ("negedge");
+ when Edge_01 =>
+ Add ("01");
+ when Edge_10 =>
+ Add ("10");
+ when Edge_0z =>
+ Add ("0z");
+ when Edge_Z1 =>
+ Add ("Z1");
+ when Edge_1z =>
+ Add ("1z");
+ when Edge_Z0 =>
+ Add ("ZO");
+ when Edge_None =>
+ if Force then
+ Add ("noedge");
+ end if;
+ when Edge_Error =>
+ Add ("?");
+ end case;
+ end Add_Edge;
+
+ Ok : Boolean;
+ begin
+ case Sdf_Context.Kind is
+ when Delay_Iopath =>
+ Start ("tpd");
+ when Delay_Port =>
+ Start ("tipd");
+ when Timingcheck_Setup =>
+ Start ("tsetup");
+ when Timingcheck_Hold =>
+ Start ("thold");
+ when Timingcheck_Setuphold =>
+ Start ("tsetup");
+ when Timingcheck_Recovery =>
+ Start ("trecovery");
+ when Timingcheck_Skew =>
+ Start ("tskew");
+ when Timingcheck_Width =>
+ Start ("tpw");
+ when Timingcheck_Period =>
+ Start ("tperiod");
+ when Timingcheck_Nochange =>
+ Start ("tncsetup");
+ end case;
+ for I in 1 .. Sdf_Context.Port_Num loop
+ Add (Sdf_Context.Ports (I).Name
+ (1 .. Sdf_Context.Ports (I).Name_Len));
+ end loop;
+ if Sdf_Context.Kind in Timing_Generic_Full_Condition then
+ Add_Edge (Sdf_Context.Ports (1).Edge, True);
+ Add_Edge (Sdf_Context.Ports (2).Edge, False);
+ elsif Sdf_Context.Kind in Timing_Generic_Simple_Condition then
+ Add_Edge (Sdf_Context.Ports (1).Edge, False);
+ end if;
+ Vital_Annotate.Sdf_Generic (Sdf_Context.all, Name (1 .. Len), Ok);
+ if not Ok then
+ Error_Sdf_C;
+ Error_C ("could not annotate generic ");
+ Error_E (Name (1 .. Len));
+ return False;
+ end if;
+ return True;
+ end Handle_Generic;
+
+ function Parse_Sdf return Boolean
+ is
+ Tok : Sdf_Token_Type;
+ Ok : Boolean;
+ begin
+ if Get_Token /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ or else not Is_Ident ("DELAYFILE")
+ or else Get_Token /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf ("not an SDF file");
+ return False;
+ end if;
+
+ if Is_Ident ("SDFVERSION") then
+ Tok := Get_Token;
+ if Tok = Tok_Qstring then
+ Sdf_Context.Version := Sdf_Version_Bad;
+ if Ident_Length = 3 and then Buf (Ident_Start + 1) = '.' then
+ -- Version has the format '"X.Y"' (without simple quote).
+ if Buf (Ident_Start) = '2'
+ and then Buf (Ident_Start + 2) = '1'
+ then
+ Sdf_Context.Version := Sdf_2_1;
+ end if;
+ end if;
+ Tok := Get_Token;
+ end if;
+
+ if not Expect_Cp_Op_Ident (Tok) then
+ return False;
+ end if;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("DESIGN") then
+ return False;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("DATE") then
+ return False;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("VENDOR") then
+ return False;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("PROGRAM") then
+ return False;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("VERSION") then
+ return False;
+ end if;
+
+ if Is_Ident ("DIVIDER") then
+ Tok := Get_Token;
+ if Tok = Tok_Div or Tok = Tok_Dot then
+ Tok := Get_Token;
+ end if;
+ if not Expect_Cp_Op_Ident (Tok) then
+ return False;
+ end if;
+ end if;
+
+ if Is_Ident ("VOLTAGE") then
+ if not Expect_Rexpr_Cp_Op_Ident then
+ return False;
+ end if;
+ end if;
+
+ if not Expect_Qstr_Cp_Op_Ident ("PROCESS") then
+ return False;
+ end if;
+
+ if Is_Ident ("TEMPERATURE") then
+ if not Expect_Rexpr_Cp_Op_Ident then
+ return False;
+ end if;
+ end if;
+
+ if Is_Ident ("TIMESCALE") then
+ Tok := Get_Token;
+ if Tok = Tok_Rnumber or Tok = Tok_Dnumber then
+ if Scan_Exp = 0 and (Scan_Int = 1
+ or Scan_Int = 10
+ or Scan_Int = 100)
+ then
+ Sdf_Context.Timescale := Scan_Int;
+ else
+ Error_Sdf ("bad timescale value");
+ return False;
+ end if;
+ Tok := Get_Token;
+ if Tok /= Tok_Identifier then
+ Error_Sdf (Tok_Identifier);
+ end if;
+ if Is_Ident ("ps") then
+ null;
+ elsif Is_Ident ("ns") then
+ Sdf_Context.Timescale := Sdf_Context.Timescale * 1000;
+ elsif Is_Ident ("us") then
+ Sdf_Context.Timescale := Sdf_Context.Timescale * 1000_000;
+ else
+ Error_Sdf ("bad timescale unit");
+ return False;
+ end if;
+ Tok := Get_Token;
+ end if;
+ if not Expect_Cp_Op_Ident (Tok) then
+ return False;
+ end if;
+ end if;
+
+ Vital_Annotate.Sdf_Header (Sdf_Context.all);
+
+ -- Parse cell+
+ loop
+ if not Is_Ident ("CELL") then
+ Error_Sdf ("CELL expected");
+ return False;
+ end if;
+ -- Parse celltype
+ if Get_Token /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ or else not Is_Ident ("CELLTYPE")
+ or else Get_Token /= Tok_Qstring
+ then
+ Error_Sdf ("CELLTYPE expected");
+ return False;
+ end if;
+ Sdf_Context.Celltype_Len := Ident_Length;
+ if Sdf_Context.Celltype_Len > Sdf_Context.Celltype'Length then
+ Error_Sdf ("CELLTYPE qstring is too long");
+ return False;
+ end if;
+ for I in Ident_Start .. Ident_End loop
+ Sdf_Context.Celltype (I - Ident_Start + 1) := To_Lower (Buf (I));
+ end loop;
+ Vital_Annotate.Sdf_Celltype (Sdf_Context.all);
+ if Get_Token /= Tok_Cparen
+ or else Get_Token /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ or else not Is_Ident ("INSTANCE")
+ then
+ Error_Sdf ("INSTANCE expected");
+ return False;
+ end if;
+ -- Parse instance+
+ loop
+ exit when not Is_Ident ("INSTANCE");
+ Tok := Get_Token;
+ if Tok /= Tok_Cparen then
+ loop
+ if Tok /= Tok_Identifier then
+ Error_Sdf ("instance identifier expected");
+ return False;
+ end if;
+ for I in Ident_Start .. Ident_End loop
+ Buf (I) := To_Lower (Buf (I));
+ end loop;
+ Vital_Annotate.Sdf_Instance
+ (Sdf_Context.all, Buf (Ident_Start .. Ident_End), Ok);
+ if not Ok then
+ Error_Sdf ("cannot find instance");
+ return False;
+ end if;
+ Tok := Get_Token;
+ exit when Tok /= Tok_Dot;
+ Tok := Get_Token;
+ end loop;
+ end if;
+ if Tok /= Tok_Cparen
+ or else Get_Token /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf ("instance or timing_spec expected");
+ return False;
+ end if;
+ end loop;
+ Vital_Annotate.Sdf_Instance_End (Sdf_Context.all, Ok);
+ if not Ok then
+ Error_Sdf ("bad instance or celltype mistmatch");
+ return False;
+ end if;
+
+ -- Parse timing_spec+
+ loop
+ if Is_Ident ("DELAY") then
+ -- Parse deltype+
+ Tok := Get_Token;
+ loop
+ if Tok /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf ("deltype expected");
+ return False;
+ end if;
+ if Is_Ident ("PATHPULSE")
+ or else Is_Ident ("GLOBALPATHPULSE")
+ then
+ Error_Sdf ("PATHPULSE and GLOBALPATHPULSE not allowed");
+ return False;
+ end if;
+ if Is_Ident ("ABSOLUTE") then
+ null;
+ elsif Is_Ident ("INCREMENT") then
+ null;
+ else
+ Error_Sdf ("ABSOLUTE or INCREMENT expected");
+ return False;
+ end if;
+ -- Parse absvals+ or incvals+
+ Tok := Get_Token;
+ loop
+ if Tok /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf ("absvals or incvals expected");
+ return False;
+ end if;
+ if Is_Ident ("IOPATH") then
+ Start_Generic_Name (Delay_Iopath);
+ if not Parse_Port_Spec
+ or else not Parse_Port_Path
+ or else not Parse_Rvalue
+ then
+ return False;
+ end if;
+ elsif Is_Ident ("PORT") then
+ Start_Generic_Name (Delay_Port);
+ if not Parse_Port_Path
+ or else not Parse_Rvalue
+ then
+ return False;
+ end if;
+ elsif Is_Ident ("COND")
+ or else Is_Ident ("INTERCONNECT")
+ or else Is_Ident ("DEVICE")
+ then
+ Error_Sdf
+ ("COND, INTERCONNECT, or DEVICE not handled");
+ return False;
+ elsif Is_Ident ("NETDELAY") then
+ Error_Sdf ("NETDELAY not allowed in VITAL SDF");
+ return False;
+ else
+ Error_Sdf ("absvals or incvals expected");
+ return False;
+ end if;
+
+ if not Handle_Generic then
+ return False;
+ end if;
+
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ end loop;
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ end loop;
+ elsif Is_Ident ("TIMINGCHECK") then
+ -- parse tc_def+
+ Tok := Get_Token;
+ loop
+ if Tok /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf ("tc_def expected");
+ return False;
+ end if;
+ if Is_Ident ("SETUP") then
+ Start_Generic_Name (Timingcheck_Setup);
+ elsif Is_Ident ("HOLD") then
+ Start_Generic_Name (Timingcheck_Hold);
+ elsif Is_Ident ("SETUPHOLD") then
+ Start_Generic_Name (Timingcheck_Setuphold);
+ elsif Is_Ident ("RECOVERY") then
+ Start_Generic_Name (Timingcheck_Recovery);
+ elsif Is_Ident ("SKEW") then
+ Start_Generic_Name (Timingcheck_Skew);
+ elsif Is_Ident ("WIDTH") then
+ Start_Generic_Name (Timingcheck_Width);
+ elsif Is_Ident ("PERIOD") then
+ Start_Generic_Name (Timingcheck_Period);
+ elsif Is_Ident ("NOCHANGE") then
+ Start_Generic_Name (Timingcheck_Nochange);
+ elsif Is_Ident ("PATHCONSTRAINT")
+ or else Is_Ident ("SUM")
+ or else Is_Ident ("DIFF")
+ or else Is_Ident ("SKEWCONSTRAINT")
+ then
+ Error_Sdf ("non-VITAL tc_def");
+ return False;
+ else
+ Error_Sdf ("bad tc_def");
+ return False;
+ end if;
+
+ case Sdf_Context.Kind is
+ when Timingcheck_Setup
+ | Timingcheck_Hold
+ | Timingcheck_Recovery
+ | Timingcheck_Skew
+ | Timingcheck_Setuphold
+ | Timingcheck_Nochange =>
+ if not Parse_Port_Tchk
+ or else not Parse_Port_Tchk
+ or else not Parse_Simple_Tc_Rvalue
+ then
+ return False;
+ end if;
+ when Timingcheck_Width
+ | Timingcheck_Period =>
+ if not Parse_Port_Tchk
+ or else not Parse_Simple_Tc_Rvalue
+ then
+ return False;
+ end if;
+ when others =>
+ Internal_Error ("sdf_parse");
+ end case;
+
+ if not Handle_Generic then
+ return False;
+ end if;
+
+ case Sdf_Context.Kind is
+ when Timingcheck_Setuphold
+ | Timingcheck_Nochange =>
+ if not Parse_Simple_Tc_Rvalue then
+ return False;
+ end if;
+ Error_Sdf ("setuphold and nochange not yet handled");
+ return False;
+ when others =>
+ null;
+ end case;
+
+ if Get_Token /= Tok_Cparen then
+ Error_Sdf (Tok_Cparen);
+ return False;
+ end if;
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ end loop;
+ end if;
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ if Tok /= Tok_Oparen then
+ Error_Sdf (Tok_Oparen);
+ return False;
+ end if;
+ if Get_Token /= Tok_Identifier then
+ Error_Sdf (Tok_Identifier);
+ return False;
+ end if;
+ end loop;
+ Tok := Get_Token;
+ exit when Tok = Tok_Cparen;
+ if Tok /= Tok_Oparen
+ or else Get_Token /= Tok_Identifier
+ then
+ Error_Sdf (Tok_Identifier);
+ end if;
+ end loop;
+ if Get_Token /= Tok_Eof then
+ Error_Sdf ("EOF expected");
+ return False;
+ end if;
+ return True;
+ end Parse_Sdf;
+
+ function Parse_Sdf_File (Filename : String) return Boolean
+ is
+ Res : Boolean;
+ begin
+ if not Open_Sdf (Filename) then
+ return False;
+ end if;
+ Res := Parse_Sdf;
+ Close_Sdf;
+ return Res;
+ end Parse_Sdf_File;
+
+end Grt.Sdf;
diff --git a/src/translate/grt/grt-sdf.ads b/src/translate/grt/grt-sdf.ads
new file mode 100644
index 000000000..fd05b9e20
--- /dev/null
+++ b/src/translate/grt/grt-sdf.ads
@@ -0,0 +1,131 @@
+-- GHDL Run Time (GRT) - SDF parser.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+
+package Grt.Sdf is
+ type Edge_Type is
+ (
+ Edge_Error,
+ Edge_None,
+ Edge_Posedge,
+ Edge_Negedge,
+ Edge_01,
+ Edge_10,
+ Edge_0z,
+ Edge_Z1,
+ Edge_1z,
+ Edge_Z0
+ );
+
+ type Timing_Generic_Kind is
+ (
+ Delay_Port,
+ --Delay_Interconnect,
+ --Delay_Device,
+
+ -- Simple condition
+ Delay_Iopath,
+ Timingcheck_Width,
+ Timingcheck_Period,
+
+ -- Full condition
+ Timingcheck_Setup,
+ Timingcheck_Hold,
+ Timingcheck_Recovery,
+ Timingcheck_Skew,
+ Timingcheck_Nochange,
+ Timingcheck_Setuphold
+ );
+
+ subtype Timing_Generic_Simple_Condition is Timing_Generic_Kind
+ range Delay_Iopath .. Timingcheck_Period;
+
+ subtype Timing_Generic_Full_Condition is Timing_Generic_Kind
+ range Timingcheck_Setup .. Timingcheck_Setuphold;
+
+ type Sdf_Version_Type is
+ (
+ Sdf_2_1,
+ Sdf_Version_Unknown,
+ Sdf_Version_Bad
+ );
+
+ Read_Size : constant Natural := 4096;
+ Buf_Size : constant Natural := Read_Size + 1024 + 1;
+
+ Invalid_Dnumber : constant Ghdl_I32 := -1;
+
+ type Port_Spec_Type is record
+ -- Port identifier.
+ Name : String (1 .. 128);
+ Name_Len : Natural;
+
+ -- Left and Right range.
+ -- If L = R = Invalid_Dnumber, this is a simple scalar port.
+ -- If R = Invalid_Dnumber, this is a scalar port (from a vector)
+ -- Otherwise, this is a bus port.
+ L, R : Ghdl_I32;
+
+ -- Cond : String (1 .. 1024);
+ -- Cond_Len : Natural;
+
+ Edge : Edge_Type;
+ end record;
+
+ type Port_Spec_Array_Type is array (Natural range <>) of Port_Spec_Type;
+
+ type Ghdl_I64_Array is array (1 .. 12) of Ghdl_I64;
+ type Boolean_Array is array (1 .. 12) of Boolean;
+
+ type Sdf_Context_Type is record
+ -- Version of the SDF file.
+ Version : Sdf_Version_Type;
+
+ -- Timescale; 1 corresponds to 1 ps.
+ -- Default is 1000 (1 ns).
+ Timescale : Natural;
+
+ Kind : Timing_Generic_Kind;
+
+ -- Cell type.
+ Celltype : String (1 .. 128);
+ Celltype_Len : Natural;
+
+ -- Current port.
+ Port_Num : Natural;
+ Ports : Port_Spec_Array_Type (1 .. 2);
+
+ -- timing spec.
+ Timing : Ghdl_I64_Array;
+ Timing_Set : Boolean_Array;
+ Timing_Nbr : Natural;
+ end record;
+
+ -- Which value is extracted.
+ type Mtm_Type is (Minimum, Typical, Maximum);
+ Sdf_Mtm : Mtm_Type := Typical;
+
+ function Parse_Sdf_File (Filename : String) return Boolean;
+end Grt.Sdf;
diff --git a/src/translate/grt/grt-shadow_ieee.adb b/src/translate/grt/grt-shadow_ieee.adb
new file mode 100644
index 000000000..32af4be5d
--- /dev/null
+++ b/src/translate/grt/grt-shadow_ieee.adb
@@ -0,0 +1,32 @@
+-- GHDL Run Time (GRT) - ghost declarations for ieee.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Shadow_Ieee is
+ procedure Ieee_Std_Logic_1164_Resolved_RESOLV is
+ begin
+ Internal_Error ("resolved_RESOLV from shadow ieee called");
+ end Ieee_Std_Logic_1164_Resolved_RESOLV;
+end Grt.Shadow_Ieee;
diff --git a/src/translate/grt/grt-shadow_ieee.ads b/src/translate/grt/grt-shadow_ieee.ads
new file mode 100644
index 000000000..f12b4792f
--- /dev/null
+++ b/src/translate/grt/grt-shadow_ieee.ads
@@ -0,0 +1,41 @@
+-- GHDL Run Time (GRT) - ghost declarations for ieee.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+-- This packages provides dummy declaration for main IEEE.STD_LOGIC_1164
+-- type descriptors.
+-- The package must not have elaboration code, since the actual type
+-- descriptors are not writable (they are constant). Making it preelaborated
+-- is not enough, the variables must be initialized. This current
+-- implementation provides bad values; this is not a problem since they are
+-- not read in grt.
+
+package Grt.Shadow_Ieee is
+ pragma Preelaborate (Grt.Shadow_Ieee);
+
+ procedure Ieee_Std_Logic_1164_Resolved_RESOLV;
+private
+ pragma Export (C, Ieee_Std_Logic_1164_Resolved_RESOLV,
+ "ieee__std_logic_1164__resolved_RESOLV");
+end Grt.Shadow_Ieee;
diff --git a/src/translate/grt/grt-signals.adb b/src/translate/grt/grt-signals.adb
new file mode 100644
index 000000000..9698d8178
--- /dev/null
+++ b/src/translate/grt/grt-signals.adb
@@ -0,0 +1,3400 @@
+-- GHDL Run Time (GRT) - signals management.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Ada.Unchecked_Deallocation;
+with Grt.Errors; use Grt.Errors;
+with Grt.Processes; use Grt.Processes;
+with Grt.Options; use Grt.Options;
+with Grt.Rtis_Types; use Grt.Rtis_Types;
+with Grt.Disp_Signals;
+with Grt.Astdio;
+with Grt.Stdio;
+with Grt.Threads; use Grt.Threads;
+
+package body Grt.Signals is
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Transaction, Name => Transaction_Acc);
+
+ procedure Free_In (Trans : Transaction_Acc)
+ is
+ Ntrans : Transaction_Acc;
+ begin
+ Ntrans := Trans;
+ Free (Ntrans);
+ end Free_In;
+ pragma Inline (Free_In);
+
+ -- RTI for the current signal.
+ Sig_Rti : Ghdl_Rtin_Object_Acc;
+
+ -- Signal mode (and flags) for the current signal.
+ Sig_Mode : Mode_Signal_Type;
+ Sig_Has_Active : Boolean;
+ Sig_Kind : Kind_Signal_Type;
+
+ -- Last created implicit signal. This is used to add dependencies on
+ -- the prefix.
+ Last_Implicit_Signal : Ghdl_Signal_Ptr;
+
+ -- Current signal resolver.
+ Current_Resolv : Resolved_Signal_Acc := null;
+
+ function Get_Current_Mode_Signal return Mode_Signal_Type is
+ begin
+ return Sig_Mode;
+ end Get_Current_Mode_Signal;
+
+ procedure Ghdl_Signal_Name_Rti (Sig : Ghdl_Rti_Access;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : Address)
+ is
+ pragma Unreferenced (Ctxt);
+ pragma Unreferenced (Addr);
+ begin
+ Sig_Rti := To_Ghdl_Rtin_Object_Acc (Sig);
+ Sig_Mode := Mode_Signal_Type'Val
+ (Sig.Mode and Ghdl_Rti_Signal_Mode_Mask);
+ Sig_Kind := Kind_Signal_Type'Val
+ ((Sig.Mode and Ghdl_Rti_Signal_Kind_Mask)
+ / Ghdl_Rti_Signal_Kind_Offset);
+ Sig_Has_Active :=
+ (Sig_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0;
+ end Ghdl_Signal_Name_Rti;
+
+ procedure Ghdl_Signal_Set_Mode (Mode : Mode_Signal_Type;
+ Kind : Kind_Signal_Type;
+ Has_Active : Boolean) is
+ begin
+ Sig_Rti := null;
+ Sig_Mode := Mode;
+ Sig_Kind := Kind;
+ Sig_Has_Active := Has_Active;
+ end Ghdl_Signal_Set_Mode;
+
+ function Is_Signal_Guarded (Sig : Ghdl_Signal_Ptr) return Boolean is
+ begin
+ return Sig.Sig_Kind /= Kind_Signal_No;
+ end Is_Signal_Guarded;
+
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Signal_Ptr, Target => Address);
+
+ function Create_Signal
+ (Mode : Mode_Type;
+ Init_Val : Value_Union;
+ Mode_Sig : Mode_Signal_Type;
+ Resolv_Proc : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ Res : Ghdl_Signal_Ptr;
+ Resolv : Resolved_Signal_Acc;
+ S : Ghdl_Signal_Data (Mode_Sig);
+ begin
+ Sig_Table.Increment_Last;
+
+ if Current_Resolv = null then
+ if Resolv_Proc /= null then
+ Resolv := new Resolved_Signal_Type'
+ (Resolv_Proc => Resolv_Proc,
+ Resolv_Inst => Resolv_Inst,
+ Resolv_Ptr => Null_Address,
+ Sig_Range => (Sig_Table.Last, Sig_Table.Last),
+ Disconnect_Time => Bad_Time);
+ else
+ Resolv := null;
+ end if;
+ else
+ if Resolv_Proc /= null then
+ -- Only one resolution function is allowed!
+ Internal_Error ("create_signal");
+ end if;
+ Resolv := Current_Resolv;
+ if Current_Resolv.Sig_Range.Last = Sig_Table.Last then
+ Current_Resolv := null;
+ end if;
+ end if;
+
+ case Mode_Sig is
+ when Mode_Signal_User =>
+ S.Nbr_Drivers := 0;
+ S.Drivers := null;
+ S.Effective := null;
+ S.Resolv := Resolv;
+ when Mode_Conv_In
+ | Mode_Conv_Out =>
+ S.Conv := null;
+ when Mode_Stable
+ | Mode_Quiet
+ | Mode_Delayed =>
+ S.Time := 0;
+ when Mode_Guard =>
+ S.Guard_Func := null;
+ S.Guard_Instance := System.Null_Address;
+ when Mode_Transaction
+ | Mode_End =>
+ null;
+ end case;
+
+ Res := new Ghdl_Signal'(Value => Init_Val,
+ Driving_Value => Init_Val,
+ Last_Value => Init_Val,
+ -- Note: use -Std_Time'last instead of
+ -- Std_Time'First so that NOW - x'last_event
+ -- returns time'high at initialization!
+ Last_Event => -Std_Time'Last,
+ Last_Active => -Std_Time'Last,
+ Event => False,
+ Active => False,
+ Has_Active => False,
+ Sig_Kind => Sig_Kind,
+
+ Is_Direct_Active => False,
+ Mode => Mode,
+ Flags => (Propag => Propag_None,
+ Is_Dumped => False,
+ Cyc_Event => False,
+ Seen => False),
+
+ Net => No_Signal_Net,
+ Link => null,
+ Alink => null,
+ Flink => null,
+
+ Event_List => null,
+ Rti => Sig_Rti,
+
+ Nbr_Ports => 0,
+ Ports => null,
+
+ S => S);
+
+ if Resolv /= null and then Resolv.Resolv_Ptr = System.Null_Address then
+ Resolv.Resolv_Ptr := To_Address (Res);
+ end if;
+
+ case Flag_Activity is
+ when Activity_All =>
+ Res.Has_Active := True;
+ when Activity_Minimal =>
+ Res.Has_Active := Sig_Has_Active;
+ when Activity_None =>
+ Res.Has_Active := False;
+ end case;
+
+ -- Put the signal in the table.
+ Sig_Table.Table (Sig_Table.Last) := Res;
+
+ return Res;
+ end Create_Signal;
+
+ procedure Ghdl_Signal_Init (Sig : Ghdl_Signal_Ptr; Val : Value_Union) is
+ begin
+ Sig.Value := Val;
+ Sig.Driving_Value := Val;
+ Sig.Last_Value := Val;
+ end Ghdl_Signal_Init;
+
+ procedure Ghdl_Signal_Merge_Rti (Sig : Ghdl_Signal_Ptr;
+ Rti : Ghdl_Rti_Access)
+ is
+ S_Rti : Ghdl_Rtin_Object_Acc;
+ begin
+ S_Rti := To_Ghdl_Rtin_Object_Acc (Rti);
+ if Flag_Activity = Activity_Minimal then
+ if (S_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0 then
+ Sig.Has_Active := True;
+ end if;
+ end if;
+ end Ghdl_Signal_Merge_Rti;
+
+ procedure Ghdl_Signal_Create_Resolution (Proc : Resolver_Acc;
+ Instance : System.Address;
+ Sig : System.Address;
+ Nbr_Sig : Ghdl_Index_Type)
+ is
+ begin
+ if Current_Resolv /= null then
+ Internal_Error ("Ghdl_Signal_Create_Resolution");
+ end if;
+ Current_Resolv := new Resolved_Signal_Type'
+ (Resolv_Proc => Proc,
+ Resolv_Inst => Instance,
+ Resolv_Ptr => Sig,
+ Sig_Range => (First => Sig_Table.Last + 1,
+ Last => Sig_Table.Last + Sig_Table_Index (Nbr_Sig)),
+ Disconnect_Time => Bad_Time);
+ end Ghdl_Signal_Create_Resolution;
+
+ procedure Check_New_Source (Sig : Ghdl_Signal_Ptr)
+ is
+ use Grt.Stdio;
+ use Grt.Astdio;
+ begin
+ if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 0 then
+ if Sig.S.Resolv = null then
+ -- LRM 4.3.1.2 Signal Declaration
+ -- It is an error if, after the elaboration of a description, a
+ -- signal has multiple sources and it is not a resolved signal.
+ if Sig.Rti /= null then
+ Put ("for signal: ");
+ Disp_Signals.Put_Signal_Name (stderr, Sig);
+ New_Line (stderr);
+ end if;
+ Error ("several sources for unresolved signal");
+ elsif Sig.S.Mode_Sig = Mode_Buffer and False then
+ -- LRM 1.1.1.2 Ports
+ -- A BUFFER port may have at most one source.
+
+ -- FIXME: this is not true with VHDL-02.
+ -- With VHDL-87/93, should also check that: any actual associated
+ -- with a formal buffer port may have at most one source.
+ Error ("buffer port which more than one source");
+ end if;
+ end if;
+ end Check_New_Source;
+
+ -- Return TRUE if already present.
+ function Ghdl_Signal_Add_Driver (Sign : Ghdl_Signal_Ptr;
+ Trans : Transaction_Acc)
+ return Boolean
+ is
+ type Size_T is mod 2**Standard'Address_Size;
+
+ function Malloc (Size : Size_T) return Driver_Arr_Ptr;
+ pragma Import (C, Malloc);
+
+ function Realloc (Ptr : Driver_Arr_Ptr; Size : Size_T)
+ return Driver_Arr_Ptr;
+ pragma Import (C, Realloc);
+
+ function Size (N : Ghdl_Index_Type) return Size_T is
+ begin
+ return Size_T (N * Driver_Fat_Array'Component_Size
+ / System.Storage_Unit);
+ end Size;
+
+ Proc : Process_Acc;
+ begin
+ Proc := Get_Current_Process;
+ if Sign.S.Nbr_Drivers = 0 then
+ Check_New_Source (Sign);
+ Sign.S.Drivers := Malloc (Size (1));
+ Sign.S.Nbr_Drivers := 1;
+ else
+ -- Do not create a driver twice.
+ for I in 0 .. Sign.S.Nbr_Drivers - 1 loop
+ if Sign.S.Drivers (I).Proc = Proc then
+ return True;
+ end if;
+ end loop;
+ Check_New_Source (Sign);
+ Sign.S.Nbr_Drivers := Sign.S.Nbr_Drivers + 1;
+ Sign.S.Drivers := Realloc (Sign.S.Drivers, Size (Sign.S.Nbr_Drivers));
+ end if;
+ Sign.S.Drivers (Sign.S.Nbr_Drivers - 1) :=
+ (First_Trans => Trans,
+ Last_Trans => Trans,
+ Proc => Proc);
+ return False;
+ end Ghdl_Signal_Add_Driver;
+
+ procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Sign.Value);
+ if Ghdl_Signal_Add_Driver (Sign, Trans) then
+ Free (Trans);
+ end if;
+ end Ghdl_Process_Add_Driver;
+
+ procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr;
+ Drv : Ghdl_Value_Ptr)
+ is
+ Trans : Transaction_Acc;
+ Trans1 : Transaction_Acc;
+ begin
+ -- Create transaction for current driving value.
+ Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Sign.Value);
+ if Ghdl_Signal_Add_Driver (Sign, Trans) then
+ Free (Trans);
+ return;
+ end if;
+ -- Create transaction for the next driving value.
+ Trans1 := new Transaction'(Kind => Trans_Direct,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val_Ptr => Drv);
+ Sign.S.Drivers (Sign.S.Nbr_Drivers - 1).Last_Trans := Trans1;
+ Trans.Next := Trans1;
+ end Ghdl_Signal_Add_Direct_Driver;
+
+ procedure Append_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr)
+ is
+ type Size_T is new Integer;
+
+ function Malloc (Size : Size_T) return Signal_Arr_Ptr;
+ pragma Import (C, Malloc);
+
+ function Realloc (Ptr : Signal_Arr_Ptr; Size : Size_T)
+ return Signal_Arr_Ptr;
+ pragma Import (C, Realloc);
+
+ function Size (N : Ghdl_Index_Type) return Size_T is
+ begin
+ return Size_T (N * Ghdl_Signal_Ptr'Size / System.Storage_Unit);
+ end Size;
+ begin
+ if Targ.Nbr_Ports = 0 then
+ Targ.Ports := Malloc (Size (1));
+ Targ.Nbr_Ports := 1;
+ else
+ Targ.Nbr_Ports := Targ.Nbr_Ports + 1;
+ Targ.Ports := Realloc (Targ.Ports, Size (Targ.Nbr_Ports));
+ end if;
+ Targ.Ports (Targ.Nbr_Ports - 1) := Src;
+ end Append_Port;
+
+ -- Add SRC to port list of TARG, but only if not already in this list.
+ procedure Add_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr)
+ is
+ begin
+ for I in 1 .. Targ.Nbr_Ports loop
+ if Targ.Ports (I - 1) = Src then
+ return;
+ end if;
+ end loop;
+ Append_Port (Targ, Src);
+ end Add_Port;
+
+ procedure Ghdl_Signal_Add_Source (Targ : Ghdl_Signal_Ptr;
+ Src : Ghdl_Signal_Ptr)
+ is
+ begin
+ Check_New_Source (Targ);
+ Append_Port (Targ, Src);
+ end Ghdl_Signal_Add_Source;
+
+ procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr;
+ Time : Std_Time) is
+ begin
+ if Sign.S.Resolv = null then
+ Internal_Error ("ghdl_signal_set_disconnect: not resolved");
+ end if;
+ if Sign.S.Resolv.Disconnect_Time /= Bad_Time then
+ Error ("disconnection already specified for signal");
+ end if;
+ if Time < 0 then
+ Error ("disconnection time is negative");
+ end if;
+ Sign.S.Resolv.Disconnect_Time := Time;
+ end Ghdl_Signal_Set_Disconnect;
+
+ procedure Direct_Assign
+ (Targ : out Value_Union; Val : Ghdl_Value_Ptr; Mode : Mode_Type)
+ is
+ begin
+ case Mode is
+ when Mode_B1 =>
+ Targ.B1 := Val.B1;
+ when Mode_E8 =>
+ Targ.E8 := Val.E8;
+ when Mode_E32 =>
+ Targ.E32 := Val.E32;
+ when Mode_I32 =>
+ Targ.I32 := Val.I32;
+ when Mode_I64 =>
+ Targ.I64 := Val.I64;
+ when Mode_F64 =>
+ Targ.F64 := Val.F64;
+ end case;
+ end Direct_Assign;
+
+ function Value_Equal (Left, Right : Value_Union; Mode : Mode_Type)
+ return Boolean
+ is
+ begin
+ case Mode is
+ when Mode_B1 =>
+ return Left.B1 = Right.B1;
+ when Mode_E8 =>
+ return Left.E8 = Right.E8;
+ when Mode_E32 =>
+ return Left.E32 = Right.E32;
+ when Mode_I32 =>
+ return Left.I32 = Right.I32;
+ when Mode_I64 =>
+ return Left.I64 = Right.I64;
+ when Mode_F64 =>
+ return Left.F64 = Right.F64;
+ end case;
+ end Value_Equal;
+
+ procedure Error_Trans_Error (Trans : Transaction_Acc) is
+ begin
+ Error_C ("range check error on signal at ");
+ Error_C (Trans.File);
+ Error_C (":");
+ Error_C (Natural (Trans.Line));
+ Error_E ("");
+ end Error_Trans_Error;
+ pragma No_Return (Error_Trans_Error);
+
+ function Find_Driver (Sig : Ghdl_Signal_Ptr) return Ghdl_Index_Type
+ is
+ Proc : Process_Acc;
+ begin
+ if Sig.S.Drivers = null then
+ Error ("assignment to a signal without any driver");
+ end if;
+ Proc := Get_Current_Process;
+ for I in 0 .. Sig.S.Nbr_Drivers - 1 loop
+ if Sig.S.Drivers (I).Proc = Proc then
+ return I;
+ end if;
+ end loop;
+ Error ("assignment to a signal without a driver for the process");
+ end Find_Driver;
+
+ function Get_Driver (Sig : Ghdl_Signal_Ptr) return Driver_Acc
+ is
+ Proc : Process_Acc;
+ begin
+ if Sig.S.Drivers = null then
+ return null;
+ end if;
+ Proc := Get_Current_Process;
+ for I in 0 .. Sig.S.Nbr_Drivers - 1 loop
+ if Sig.S.Drivers (I).Proc = Proc then
+ return Sig.S.Drivers (I)'Access;
+ end if;
+ end loop;
+ return null;
+ end Get_Driver;
+
+ -- Return TRUE iff SIG has a future transaction for the current time,
+ -- ie iff SIG will be active in the next delta cycle. This is used to
+ -- recompute wether SIG must be in the active chain. SIG must be a user
+ -- signal.
+ function Has_Transaction_In_Next_Delta (Sig : Ghdl_Signal_Ptr)
+ return Boolean is
+ begin
+ if Sig.Is_Direct_Active then
+ return True;
+ end if;
+
+ for I in 1 .. Sig.S.Nbr_Drivers loop
+ declare
+ Trans : constant Transaction_Acc :=
+ Sig.S.Drivers (I - 1).First_Trans.Next;
+ begin
+ if Trans.Kind /= Trans_Direct
+ and then Trans.Time = Current_Time
+ then
+ return True;
+ end if;
+ end;
+ end loop;
+ return False;
+ end Has_Transaction_In_Next_Delta;
+
+ -- Unused but well-known signal which always terminate
+ -- ghdl_signal_active_chain.
+ -- As a consequence, every element of the chain has a link field set to
+ -- a non-null value (this is of course not true for SIGNAL_END). This may
+ -- be used to quickly check if a signal is in the list.
+ -- This signal is not in the signal table.
+ Signal_End : Ghdl_Signal_Ptr;
+
+ -- List of signals which have projected waveforms in the future (beyond
+ -- the next delta cycle).
+ Future_List : aliased Ghdl_Signal_Ptr;
+
+ procedure Ghdl_Signal_Start_Assign (Sign : Ghdl_Signal_Ptr;
+ Reject : Std_Time;
+ Trans : Transaction_Acc;
+ After : Std_Time)
+ is
+ Assign_Time : Std_Time;
+ Drv : constant Ghdl_Index_Type := Find_Driver (Sign);
+ Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers;
+ Driver : Driver_Type renames Drv_Ptr (Drv);
+ begin
+ -- LRM93 8.4.1
+ -- It is an error if the time expression in a waveform element
+ -- evaluates to a negative value.
+ if After < 0 then
+ Error ("negative time expression in signal assignment");
+ end if;
+
+ if After = 0 then
+ -- Put SIGN on the active list if the transaction is scheduled
+ -- for the next delta cycle.
+ if Sign.Link = null then
+ Sign.Link := Grt.Threads.Atomic_Insert
+ (Ghdl_Signal_Active_Chain'access, Sign);
+ end if;
+ else
+ -- AFTER > 0.
+ -- Put SIGN on the future list.
+ if Sign.Flink = null then
+ Sign.Flink := Grt.Threads.Atomic_Insert (Future_List'access, Sign);
+ end if;
+ end if;
+
+ Assign_Time := Current_Time + After;
+ if Assign_Time < 0 then
+ -- Beyond the future
+ Free_In (Trans);
+ return;
+ end if;
+
+ -- Handle sign as direct driver.
+ if Driver.Last_Trans.Kind = Trans_Direct then
+ if After /= 0 then
+ Internal_Error ("direct assign with non-0 after");
+ end if;
+ -- FIXME: can be a bound-error too!
+ if Trans.Kind = Trans_Value then
+ case Sign.Mode is
+ when Mode_B1 =>
+ Driver.Last_Trans.Val_Ptr.B1 := Trans.Val.B1;
+ when Mode_E8 =>
+ Driver.Last_Trans.Val_Ptr.E8 := Trans.Val.E8;
+ when Mode_E32 =>
+ Driver.Last_Trans.Val_Ptr.E32 := Trans.Val.E32;
+ when Mode_I32 =>
+ Driver.Last_Trans.Val_Ptr.I32 := Trans.Val.I32;
+ when Mode_I64 =>
+ Driver.Last_Trans.Val_Ptr.I64 := Trans.Val.I64;
+ when Mode_F64 =>
+ Driver.Last_Trans.Val_Ptr.F64 := Trans.Val.F64;
+ end case;
+ Free_In (Trans);
+ elsif Trans.Kind = Trans_Error then
+ Error_Trans_Error (Trans);
+ else
+ Internal_Error ("direct assign with non-value");
+ end if;
+ return;
+ end if;
+
+ -- LRM93 8.4.1
+ -- 1. All old transactions that are projected to occur at or after the
+ -- time at which the earliest new transaction is projected to occur
+ -- are deleted from the projected output waveform.
+ if Driver.Last_Trans.Time >= Assign_Time then
+ declare
+ -- LAST is the last transaction to keep.
+ Last : Transaction_Acc;
+ Next : Transaction_Acc;
+ begin
+ Last := Driver.First_Trans;
+ -- Find the first transaction to be deleted.
+ Next := Last.Next;
+ while Next /= null and then Next.Time < Assign_Time loop
+ Last := Next;
+ Next := Next.Next;
+ end loop;
+ -- Delete old transactions.
+ if Next /= null then
+ -- Set the last transaction of the driver.
+ Driver.Last_Trans := Last;
+ -- Cut the chain. This is not strickly necessary, since
+ -- it will be overriden below, by appending TRANS to the
+ -- driver.
+ Last.Next := null;
+ -- Free removed transactions.
+ loop
+ Last := Next.Next;
+ Free (Next);
+ exit when Last = null;
+ Next := Last;
+ end loop;
+ end if;
+ end;
+ end if;
+
+ -- 2. The new transaction are then appended to the projected output
+ -- waveform in the order of their projected occurence.
+ Trans.Time := Assign_Time;
+ Driver.Last_Trans.Next := Trans;
+ Driver.Last_Trans := Trans;
+
+ -- If the initial delay is inertial delay according to the definitions
+ -- of section 8.4, the projected output waveform is further modified
+ -- as follows:
+ -- 1. All of the new transactions are marked.
+ -- 2. An old transaction is marked if the time at which it is projected
+ -- to occur is less than the time at which the first new transaction
+ -- is projected to occur minus the pulse rejection limit.
+ -- 3. For each remaining unmarked, old transaction, the old transaction
+ -- is marked if it immediatly precedes a marked transaction and its
+ -- value component is the same as that of the marked transaction;
+ -- 4. The transaction that determines the current value of the driver
+ -- is marked.
+ -- 5. All unmarked transactions (all of which are old transactions) are
+ -- deleted from the projected output waveform.
+ --
+ -- GHDL: only transactions that are projected to occur at [T-R, T[
+ -- can be deleted (R is the reject time, T is now + after time).
+ if Reject > 0 then
+ -- LRM93 8.4
+ -- It is an error if the pulse rejection limit for any inertially
+ -- delayed signal assignment statement is [...] or greater than the
+ -- time expression associated with the first waveform element.
+ if Reject > After then
+ Error ("pulse rejection greater than first waveform delay");
+ end if;
+
+ declare
+ Prev : Transaction_Acc;
+ Next : Transaction_Acc;
+ begin
+ -- Find the first transaction after the project time less the
+ -- rejection time.
+ -- PREV will be the last old transaction which is projected to
+ -- occur before T - R.
+ Prev := Driver.First_Trans;
+ loop
+ Next := Prev.Next;
+ exit when Next.Time >= Assign_Time - Reject;
+ Prev := Next;
+ end loop;
+
+ -- Scan every transaction until TRANS. If a transaction value is
+ -- different from the TRANS value, then delete all previous
+ -- transactions (from T - R to the currently scanned transaction),
+ -- since they are not marked.
+ while Next /= Trans loop
+ if Next.Kind /= Trans.Kind
+ or else
+ (Trans.Kind = Trans_Value
+ and then not Value_Equal (Next.Val, Trans.Val, Sign.Mode))
+ then
+ -- NEXT is different from TRANS.
+ -- Delete ]PREV;NEXT].
+ declare
+ D, N : Transaction_Acc;
+ begin
+ D := Prev.Next;
+ Next := Next.Next;
+ Prev.Next := Next;
+ loop
+ N := D.Next;
+ Free (D);
+ exit when N = Next;
+ D := N;
+ end loop;
+ end;
+ else
+ Next := Next.Next;
+ end if;
+ end loop;
+
+ -- A previous assignment (with a 0 after time) may have put this
+ -- signal on the active chain. But maybe this previous
+ -- transaction has been removed (due to rejection) and therefore
+ -- this signal won't be active at the next delta. So remove it
+ -- from the active chain. This is a little bit costly (because
+ -- the chain is simply linked), but that issue doesn't appear
+ -- frequently.
+ if Sign.Link /= null
+ and then not Has_Transaction_In_Next_Delta (Sign)
+ then
+ if Ghdl_Signal_Active_Chain = Sign then
+ -- At the head of the chain.
+ -- FIXME: this is not atomic.
+ Ghdl_Signal_Active_Chain := Sign.Link;
+ else
+ -- In the middle of the chain.
+ declare
+ Prev : Ghdl_Signal_Ptr := Ghdl_Signal_Active_Chain;
+ begin
+ while Prev.Link /= Sign loop
+ Prev := Prev.Link;
+ end loop;
+ Prev.Link := Sign.Link;
+ end;
+ end if;
+ Sign.Link := null;
+ end if;
+ end;
+ elsif Reject /= 0 then
+ -- LRM93 8.4
+ -- It is an error if the pulse rejection limit for any inertially
+ -- delayed signal assignment statement is either negative or [...].
+ Error ("pulse rejection is negative");
+ end if;
+
+ -- Do some checks.
+ if Driver.Last_Trans.Next /= null then
+ Error ("ghdl_signal_start_assign internal_error");
+ end if;
+ end Ghdl_Signal_Start_Assign;
+
+ procedure Ghdl_Signal_Next_Assign (Sign : Ghdl_Signal_Ptr;
+ Val : Value_Union;
+ After : Std_Time)
+ is
+ Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers;
+ Driver : Driver_Type renames Drv_Ptr (Find_Driver (Sign));
+
+ Trans : Transaction_Acc;
+ begin
+ if After > 0 and then Sign.Flink = null then
+ -- Put SIGN on the future list.
+ Sign.Flink := Future_List;
+ Future_List := Sign;
+ end if;
+
+ Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => Current_Time + After,
+ Next => null,
+ Val => Val);
+ if Trans.Time <= Driver.Last_Trans.Time then
+ Error ("transactions not in ascending order");
+ end if;
+ Driver.Last_Trans.Next := Trans;
+ Driver.Last_Trans := Trans;
+ end Ghdl_Signal_Next_Assign;
+
+ procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr) is
+ begin
+ if Sign.Link = null then
+ Sign.Link := Grt.Threads.Atomic_Insert
+ (Ghdl_Signal_Active_Chain'access, Sign);
+ end if;
+
+ -- Must be always set (as Sign.Link may be set by a regular driver).
+ Sign.Is_Direct_Active := True;
+ end Ghdl_Signal_Direct_Assign;
+
+ procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'(Kind => Trans_Error,
+ Line => Line,
+ Time => 0,
+ Next => null,
+ File => File);
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_Error;
+
+ procedure Ghdl_Signal_Start_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ After : Std_Time;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'(Kind => Trans_Error,
+ Line => Line,
+ Time => 0,
+ Next => null,
+ File => File);
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_Error;
+
+ procedure Ghdl_Signal_Next_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ After : Std_Time;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32)
+ is
+ Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers;
+ Driver : Driver_Type renames Drv_Ptr (Find_Driver (Sign));
+
+ Trans : Transaction_Acc;
+ begin
+ if After > 0 and then Sign.Flink = null then
+ -- Put SIGN on the future list.
+ Sign.Flink := Future_List;
+ Future_List := Sign;
+ end if;
+
+ Trans := new Transaction'(Kind => Trans_Error,
+ Line => Line,
+ Time => Current_Time + After,
+ Next => null,
+ File => File);
+ if Trans.Time <= Driver.Last_Trans.Time then
+ Error ("transactions not in ascending order");
+ end if;
+ Driver.Last_Trans.Next := Trans;
+ Driver.Last_Trans := Trans;
+ end Ghdl_Signal_Next_Assign_Error;
+
+ procedure Ghdl_Signal_Start_Assign_Null (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Is_Signal_Guarded (Sign) then
+ Error ("null transaction for a non-guarded target");
+ end if;
+ Trans := new Transaction'(Kind => Trans_Null,
+ Line => 0,
+ Time => 0,
+ Next => null);
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_Null;
+
+ procedure Ghdl_Signal_Disconnect (Sign : Ghdl_Signal_Ptr)
+ is
+ Trans : Transaction_Acc;
+ Time : Std_Time;
+ begin
+ if not Is_Signal_Guarded (Sign) then
+ Error ("null transaction for a non-guarded target");
+ end if;
+ Trans := new Transaction'(Kind => Trans_Null,
+ Line => 0,
+ Time => 0,
+ Next => null);
+ Time := Sign.S.Resolv.Disconnect_Time;
+ Ghdl_Signal_Start_Assign (Sign, Time, Trans, Time);
+ end Ghdl_Signal_Disconnect;
+
+ procedure Ghdl_Signal_Associate (Sig : Ghdl_Signal_Ptr; Val : Value_Union)
+ is
+ begin
+ Sig.Value := Val;
+ Sig.Driving_Value := Val;
+ end Ghdl_Signal_Associate;
+
+ function Ghdl_Create_Signal_B1
+ (Init_Val : Ghdl_B1;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_B1;
+
+ procedure Ghdl_Signal_Init_B1 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_B1) is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_B1, B1 => Init_Val));
+ end Ghdl_Signal_Init_B1;
+
+ procedure Ghdl_Signal_Associate_B1 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_B1) is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_B1, B1 => Val));
+ end Ghdl_Signal_Associate_B1;
+
+ procedure Ghdl_Signal_Simple_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_B1)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.B1
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_B1, B1 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_B1;
+
+ procedure Ghdl_Signal_Start_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_B1;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_B1, B1 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_B1;
+
+ procedure Ghdl_Signal_Next_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_B1;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_B1, B1 => Val), After);
+ end Ghdl_Signal_Next_Assign_B1;
+
+ function Ghdl_Create_Signal_E8
+ (Init_Val : Ghdl_E8;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_E8, Value_Union'(Mode => Mode_E8, E8 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_E8;
+
+ procedure Ghdl_Signal_Init_E8 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E8) is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_E8, E8 => Init_Val));
+ end Ghdl_Signal_Init_E8;
+
+ procedure Ghdl_Signal_Associate_E8 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E8) is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_E8, E8 => Val));
+ end Ghdl_Signal_Associate_E8;
+
+ procedure Ghdl_Signal_Simple_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E8)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.E8
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_E8, E8 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_E8;
+
+ procedure Ghdl_Signal_Start_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_E8;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_E8, E8 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_E8;
+
+ procedure Ghdl_Signal_Next_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E8;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_E8, E8 => Val), After);
+ end Ghdl_Signal_Next_Assign_E8;
+
+ function Ghdl_Create_Signal_E32
+ (Init_Val : Ghdl_E32;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_E32, Value_Union'(Mode => Mode_E32, E32 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_E32;
+
+ procedure Ghdl_Signal_Init_E32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E32)
+ is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_E32, E32 => Init_Val));
+ end Ghdl_Signal_Init_E32;
+
+ procedure Ghdl_Signal_Associate_E32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E32)
+ is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_E32, E32 => Val));
+ end Ghdl_Signal_Associate_E32;
+
+ procedure Ghdl_Signal_Simple_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E32)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.E32
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_E32, E32 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_E32;
+
+ procedure Ghdl_Signal_Start_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_E32;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_E32, E32 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_E32;
+
+ procedure Ghdl_Signal_Next_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E32;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_E32, E32 => Val), After);
+ end Ghdl_Signal_Next_Assign_E32;
+
+ function Ghdl_Create_Signal_I32
+ (Init_Val : Ghdl_I32;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_I32, Value_Union'(Mode => Mode_I32, I32 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_I32;
+
+ procedure Ghdl_Signal_Init_I32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I32)
+ is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_I32, I32 => Init_Val));
+ end Ghdl_Signal_Init_I32;
+
+ procedure Ghdl_Signal_Associate_I32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I32)
+ is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_I32, I32 => Val));
+ end Ghdl_Signal_Associate_I32;
+
+ procedure Ghdl_Signal_Simple_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I32)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.I32
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_I32, I32 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_I32;
+
+ procedure Ghdl_Signal_Start_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_I32;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_I32, I32 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_I32;
+
+ procedure Ghdl_Signal_Next_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I32;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_I32, I32 => Val), After);
+ end Ghdl_Signal_Next_Assign_I32;
+
+ function Ghdl_Create_Signal_I64
+ (Init_Val : Ghdl_I64;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_I64, Value_Union'(Mode => Mode_I64, I64 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_I64;
+
+ procedure Ghdl_Signal_Init_I64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I64)
+ is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_I64, I64 => Init_Val));
+ end Ghdl_Signal_Init_I64;
+
+ procedure Ghdl_Signal_Associate_I64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I64)
+ is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_I64, I64 => Val));
+ end Ghdl_Signal_Associate_I64;
+
+ procedure Ghdl_Signal_Simple_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I64)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.I64
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_I64, I64 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_I64;
+
+ procedure Ghdl_Signal_Start_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_I64;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_I64, I64 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_I64;
+
+ procedure Ghdl_Signal_Next_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I64;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_I64, I64 => Val), After);
+ end Ghdl_Signal_Next_Assign_I64;
+
+ function Ghdl_Create_Signal_F64
+ (Init_Val : Ghdl_F64;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr
+ is
+ begin
+ return Create_Signal
+ (Mode_F64, Value_Union'(Mode => Mode_F64, F64 => Init_Val),
+ Get_Current_Mode_Signal,
+ Resolv_Func, Resolv_Inst);
+ end Ghdl_Create_Signal_F64;
+
+ procedure Ghdl_Signal_Init_F64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_F64)
+ is
+ begin
+ Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_F64, F64 => Init_Val));
+ end Ghdl_Signal_Init_F64;
+
+ procedure Ghdl_Signal_Associate_F64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_F64)
+ is
+ begin
+ Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_F64, F64 => Val));
+ end Ghdl_Signal_Associate_F64;
+
+ procedure Ghdl_Signal_Simple_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_F64)
+ is
+ Trans : Transaction_Acc;
+ begin
+ if not Sign.Has_Active
+ and then Sign.Net = Net_One_Driver
+ and then Val = Sign.Value.F64
+ and then Sign.S.Drivers (0).First_Trans.Next = null
+ then
+ return;
+ end if;
+
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_F64, F64 => Val));
+
+ Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0);
+ end Ghdl_Signal_Simple_Assign_F64;
+
+ procedure Ghdl_Signal_Start_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_F64;
+ After : Std_Time)
+ is
+ Trans : Transaction_Acc;
+ begin
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_F64, F64 => Val));
+ Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After);
+ end Ghdl_Signal_Start_Assign_F64;
+
+ procedure Ghdl_Signal_Next_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_F64;
+ After : Std_Time)
+ is
+ begin
+ Ghdl_Signal_Next_Assign
+ (Sign, Value_Union'(Mode => Mode_F64, F64 => Val), After);
+ end Ghdl_Signal_Next_Assign_F64;
+
+ procedure Ghdl_Signal_Internal_Checks
+ is
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Sig := Sig_Table.Table (I);
+
+ -- Check drivers.
+ case Sig.S.Mode_Sig is
+ when Mode_Signal_User =>
+ for J in 1 .. Sig.S.Nbr_Drivers loop
+ declare
+ Trans : Transaction_Acc;
+ begin
+ Trans := Sig.S.Drivers (J - 1).First_Trans;
+ while Trans.Next /= null loop
+ if Trans.Next.Time < Trans.Time then
+ Internal_Error ("ghdl_signal_internal_checks: "
+ & "bad transaction order");
+ end if;
+ Trans := Trans.Next;
+ end loop;
+ if Trans /= Sig.S.Drivers (J - 1).Last_Trans then
+ Internal_Error ("ghdl_signal_internal_checks: "
+ & "last transaction mismatch");
+ end if;
+ end;
+ end loop;
+ when others =>
+ null;
+ end case;
+ end loop;
+ end Ghdl_Signal_Internal_Checks;
+
+ procedure Ghdl_Signal_Effective_Value (Targ : Ghdl_Signal_Ptr;
+ Src : Ghdl_Signal_Ptr)
+ is
+ begin
+ if Targ.S.Effective /= null then
+ Error ("internal error: already effective value");
+ end if;
+ Targ.S.Effective := Src;
+ end Ghdl_Signal_Effective_Value;
+
+ Bit_Signal_Rti : aliased Ghdl_Rtin_Object :=
+ (Common => (Kind => Ghdl_Rtik_Signal,
+ Depth => 0,
+ Mode => Ghdl_Rti_Signal_Mode_None,
+ Max_Depth => 0),
+ Name => null,
+ Loc => Null_Rti_Loc,
+ Obj_Type => null);
+
+ Boolean_Signal_Rti : aliased Ghdl_Rtin_Object :=
+ (Common => (Kind => Ghdl_Rtik_Signal,
+ Depth => 0,
+ Mode => Ghdl_Rti_Signal_Mode_None,
+ Max_Depth => 0),
+ Name => null,
+ Loc => Null_Rti_Loc,
+ Obj_Type => null);
+
+ function Ghdl_Create_Signal_Attribute
+ (Mode : Mode_Signal_Type; Time : Std_Time)
+ return Ghdl_Signal_Ptr
+ is
+ Res : Ghdl_Signal_Ptr;
+-- Sig_Type : Ghdl_Desc_Ptr;
+ begin
+ case Mode is
+ when Mode_Transaction =>
+ Sig_Rti := To_Ghdl_Rtin_Object_Acc
+ (To_Ghdl_Rti_Access (Bit_Signal_Rti'Address));
+ when Mode_Quiet
+ | Mode_Stable =>
+ Sig_Rti := To_Ghdl_Rtin_Object_Acc
+ (To_Ghdl_Rti_Access (Boolean_Signal_Rti'Address));
+ when others =>
+ Internal_Error ("ghdl_create_signal_attribute");
+ end case;
+ -- Note: bit and boolean are both mode_b1.
+ Res := Create_Signal
+ (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => True),
+ Mode, null, Null_Address);
+ Sig_Rti := null;
+ Last_Implicit_Signal := Res;
+
+ if Mode /= Mode_Transaction then
+ Res.S.Time := Time;
+ Res.S.Attr_Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Res.Value);
+ end if;
+
+ if Time > 0 then
+ Res.Flink := Future_List;
+ Future_List := Res;
+ end if;
+
+ return Res;
+ end Ghdl_Create_Signal_Attribute;
+
+ function Ghdl_Create_Stable_Signal (Val : Std_Time) return Ghdl_Signal_Ptr
+ is
+ begin
+ return Ghdl_Create_Signal_Attribute (Mode_Stable, Val);
+ end Ghdl_Create_Stable_Signal;
+
+ function Ghdl_Create_Quiet_Signal (Val : Std_Time) return Ghdl_Signal_Ptr
+ is
+ begin
+ return Ghdl_Create_Signal_Attribute (Mode_Quiet, Val);
+ end Ghdl_Create_Quiet_Signal;
+
+ function Ghdl_Create_Transaction_Signal return Ghdl_Signal_Ptr
+ is
+ begin
+ return Ghdl_Create_Signal_Attribute (Mode_Transaction, 0);
+ end Ghdl_Create_Transaction_Signal;
+
+ procedure Ghdl_Signal_Attribute_Register_Prefix (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ Add_Port (Last_Implicit_Signal, Sig);
+ end Ghdl_Signal_Attribute_Register_Prefix;
+
+ --Guard_String : constant String := "guard";
+ --Guard_Name : constant Ghdl_Str_Len_Address_Type :=
+ -- (Len => 5, Str => Guard_String'Address);
+ --function To_Ghdl_Str_Len_Ptr is new Ada.Unchecked_Conversion
+ -- (Source => System.Address, Target => Ghdl_Str_Len_Ptr);
+
+ Guard_Rti : aliased constant Ghdl_Rtin_Object :=
+ (Common => (Kind => Ghdl_Rtik_Signal,
+ Depth => 0,
+ Mode => Ghdl_Rti_Signal_Mode_None,
+ Max_Depth => 0),
+ Name => null,
+ Loc => Null_Rti_Loc,
+ Obj_Type => Std_Standard_Boolean_RTI_Ptr);
+
+ function Ghdl_Signal_Create_Guard (This : System.Address;
+ Proc : Guard_Func_Acc)
+ return Ghdl_Signal_Ptr
+ is
+ Res : Ghdl_Signal_Ptr;
+ begin
+ Sig_Rti := To_Ghdl_Rtin_Object_Acc
+ (To_Ghdl_Rti_Access (Guard_Rti'Address));
+ Res := Create_Signal
+ (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => Proc.all (This)),
+ Mode_Guard, null, Null_Address);
+ Sig_Rti := null;
+ Res.S.Guard_Func := Proc;
+ Res.S.Guard_Instance := This;
+ Last_Implicit_Signal := Res;
+ return Res;
+ end Ghdl_Signal_Create_Guard;
+
+ procedure Ghdl_Signal_Guard_Dependence (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ Add_Port (Last_Implicit_Signal, Sig);
+ Sig.Has_Active := True;
+ end Ghdl_Signal_Guard_Dependence;
+
+ function Ghdl_Create_Delayed_Signal (Sig : Ghdl_Signal_Ptr; Val : Std_Time)
+ return Ghdl_Signal_Ptr
+ is
+ Res : Ghdl_Signal_Ptr;
+ begin
+ Res := Create_Signal (Sig.Mode, Sig.Value,
+ Mode_Delayed, null, Null_Address);
+ Res.S.Time := Val;
+ if Val > 0 then
+ Res.Flink := Future_List;
+ Future_List := Res;
+ end if;
+ Res.S.Attr_Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => 0,
+ Next => null,
+ Val => Res.Value);
+ Append_Port (Res, Sig);
+ return Res;
+ end Ghdl_Create_Delayed_Signal;
+
+ function Signal_Ptr_To_Index (Ptr : Ghdl_Signal_Ptr) return Sig_Table_Index
+ is
+ begin
+ -- Note: we may start from ptr.instance_name.sig_index, but
+ -- instance_name is *not* set for conversion signals.
+ for I in reverse Sig_Table.First .. Sig_Table.Last loop
+ if Sig_Table.Table (I) = Ptr then
+ return I;
+ end if;
+ end loop;
+ return -1;
+ end Signal_Ptr_To_Index;
+
+ function Ghdl_Signal_Get_Nbr_Ports (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_Index_Type is
+ begin
+ return Sig.Nbr_Ports;
+ end Ghdl_Signal_Get_Nbr_Ports;
+
+ function Ghdl_Signal_Get_Nbr_Drivers (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_Index_Type is
+ begin
+ return Sig.S.Nbr_Drivers;
+ end Ghdl_Signal_Get_Nbr_Drivers;
+
+ function Ghdl_Signal_Read_Port
+ (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type)
+ return Ghdl_Value_Ptr
+ is
+ begin
+ if Index >= Sig.Nbr_Ports then
+ Internal_Error ("ghdl_signal_read_port: bad index");
+ end if;
+ return To_Ghdl_Value_Ptr (Sig.Ports (Index).Driving_Value'Address);
+ end Ghdl_Signal_Read_Port;
+
+ function Ghdl_Signal_Read_Driver
+ (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type)
+ return Ghdl_Value_Ptr
+ is
+ Trans : Transaction_Acc;
+ begin
+ if Index >= Sig.S.Nbr_Drivers then
+ Internal_Error ("ghdl_signal_read_driver: bad index");
+ end if;
+ Trans := Sig.S.Drivers (Index).First_Trans;
+ case Trans.Kind is
+ when Trans_Value =>
+ return To_Ghdl_Value_Ptr (Trans.Val'Address);
+ when Trans_Direct =>
+ Internal_Error ("ghdl_signal_read_driver: trans_direct");
+ when Trans_Null =>
+ return null;
+ when Trans_Error =>
+ Error_Trans_Error (Trans);
+ end case;
+ end Ghdl_Signal_Read_Driver;
+
+ procedure Ghdl_Signal_Conversion (Func : System.Address;
+ Instance : System.Address;
+ Src : Ghdl_Signal_Ptr;
+ Src_Len : Ghdl_Index_Type;
+ Dst : Ghdl_Signal_Ptr;
+ Dst_Len : Ghdl_Index_Type;
+ Mode : Mode_Signal_Type)
+ is
+ Data : Sig_Conversion_Acc;
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ Data := new Sig_Conversion_Type'(Func => Func,
+ Instance => Instance,
+ Src => (-1, -1),
+ Dest => (-1, -1));
+ Data.Src.First := Signal_Ptr_To_Index (Src);
+ Data.Src.Last := Data.Src.First + Sig_Table_Index (Src_Len) - 1;
+
+ Data.Dest.First := Signal_Ptr_To_Index (Dst);
+ Data.Dest.Last := Data.Dest.First + Sig_Table_Index (Dst_Len) - 1;
+
+ -- Convert DEST to new mode.
+ for I in Data.Dest.First .. Data.Dest.Last loop
+ Sig := Sig_Table.Table (I);
+ case Mode is
+ when Mode_Conv_In =>
+ Sig.S := (Mode_Sig => Mode_Conv_In,
+ Conv => Data);
+ when Mode_Conv_Out =>
+ Sig.S := (Mode_Sig => Mode_Conv_Out,
+ Conv => Data);
+ when others =>
+ Internal_Error ("ghdl_signal_conversion");
+ end case;
+ end loop;
+ end Ghdl_Signal_Conversion;
+
+ procedure Ghdl_Signal_In_Conversion (Func : System.Address;
+ Instance : System.Address;
+ Src : Ghdl_Signal_Ptr;
+ Src_Len : Ghdl_Index_Type;
+ Dst : Ghdl_Signal_Ptr;
+ Dst_Len : Ghdl_Index_Type)
+ is
+ begin
+ Ghdl_Signal_Conversion
+ (Func, Instance, Src, Src_Len, Dst, Dst_Len, Mode_Conv_In);
+ end Ghdl_Signal_In_Conversion;
+
+ procedure Ghdl_Signal_Out_Conversion (Func : System.Address;
+ Instance : System.Address;
+ Src : Ghdl_Signal_Ptr;
+ Src_Len : Ghdl_Index_Type;
+ Dst : Ghdl_Signal_Ptr;
+ Dst_Len : Ghdl_Index_Type)
+ is
+ begin
+ Ghdl_Signal_Conversion
+ (Func, Instance, Src, Src_Len, Dst, Dst_Len, Mode_Conv_Out);
+ end Ghdl_Signal_Out_Conversion;
+
+ function Ghdl_Signal_Driving (Sig : Ghdl_Signal_Ptr) return Ghdl_B1
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null then
+ -- FIXME: disp signal and process.
+ Error ("'driving error: no driver in process for signal");
+ end if;
+ if Drv.First_Trans.Kind /= Trans_Null then
+ return True;
+ else
+ return False;
+ end if;
+ end Ghdl_Signal_Driving;
+
+ function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr) return Ghdl_B1
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.B1;
+ end if;
+ end Ghdl_Signal_Driving_Value_B1;
+
+ function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_E8
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.E8;
+ end if;
+ end Ghdl_Signal_Driving_Value_E8;
+
+ function Ghdl_Signal_Driving_Value_E32 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_E32
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.E32;
+ end if;
+ end Ghdl_Signal_Driving_Value_E32;
+
+ function Ghdl_Signal_Driving_Value_I32 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_I32
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.I32;
+ end if;
+ end Ghdl_Signal_Driving_Value_I32;
+
+ function Ghdl_Signal_Driving_Value_I64 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_I64
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.I64;
+ end if;
+ end Ghdl_Signal_Driving_Value_I64;
+
+ function Ghdl_Signal_Driving_Value_F64 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_F64
+ is
+ Drv : Driver_Acc;
+ begin
+ Drv := Get_Driver (Sig);
+ if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then
+ Error ("'driving_value: no active driver in process for signal");
+ else
+ return Drv.First_Trans.Val.F64;
+ end if;
+ end Ghdl_Signal_Driving_Value_F64;
+
+ Ghdl_Implicit_Signal_Active_Chain : Ghdl_Signal_Ptr;
+
+ procedure Flush_Active_List
+ is
+ Sig : Ghdl_Signal_Ptr;
+ Next_Sig : Ghdl_Signal_Ptr;
+ begin
+ -- Free active_chain.
+ Sig := Ghdl_Signal_Active_Chain;
+ loop
+ Next_Sig := Sig.Link;
+ exit when Next_Sig = null;
+ Sig.Link := null;
+ Sig := Next_Sig;
+ end loop;
+ Ghdl_Signal_Active_Chain := Sig;
+ end Flush_Active_List;
+
+ function Find_Next_Time return Std_Time
+ is
+ Res : Std_Time;
+ Sig : Ghdl_Signal_Ptr;
+
+ procedure Check_Transaction (Trans : Transaction_Acc)
+ is
+ begin
+ if Trans = null or else Trans.Kind = Trans_Direct then
+ -- Activity of direct drivers is done through link.
+ return;
+ end if;
+
+ if Trans.Time = Res and Sig.Link = null then
+ Sig.Link := Ghdl_Signal_Active_Chain;
+ Ghdl_Signal_Active_Chain := Sig;
+ elsif Trans.Time < Res then
+ Flush_Active_List;
+
+ -- Put sig on the list.
+ Sig.Link := Ghdl_Signal_Active_Chain;
+ Ghdl_Signal_Active_Chain := Sig;
+
+ Res := Trans.Time;
+ end if;
+ if Res = Current_Time then
+ -- Must have been in the active list.
+ Internal_Error ("find_next_time(2)");
+ end if;
+ end Check_Transaction;
+ begin
+ -- If there is signals in the active list, then next cycle is a delta
+ -- cycle, so next time is current_time.
+ if Ghdl_Signal_Active_Chain.Link /= null then
+ return Current_Time;
+ end if;
+ if Ghdl_Implicit_Signal_Active_Chain.Link /= null then
+ return Current_Time;
+ end if;
+ Res := Std_Time'Last;
+
+ Sig := Future_List;
+ while Sig.Flink /= null loop
+ case Sig.S.Mode_Sig is
+ when Mode_Signal_User =>
+ for J in 1 .. Sig.S.Nbr_Drivers loop
+ Check_Transaction (Sig.S.Drivers (J - 1).First_Trans.Next);
+ end loop;
+ when Mode_Delayed
+ | Mode_Stable
+ | Mode_Quiet =>
+ Check_Transaction (Sig.S.Attr_Trans.Next);
+ when others =>
+ Internal_Error ("find_next_time(3)");
+ end case;
+ Sig := Sig.Flink;
+ end loop;
+ return Res;
+ end Find_Next_Time;
+
+-- function Get_Nbr_Non_Null_Source (Sig : Ghdl_Signal_Ptr)
+-- return Natural
+-- is
+-- Length : Natural;
+-- begin
+-- Length := Sig.Nbr_Ports;
+-- for I in 0 .. Sig.Nbr_Drivers - 1 loop
+-- case Sig.Drivers (I).First_Trans.Kind is
+-- when Trans_Value =>
+-- Length := Length + 1;
+-- when Trans_Null =>
+-- null;
+-- when Trans_Error =>
+-- Error ("range check error");
+-- end case;
+-- end loop;
+-- return Length;
+-- end Get_Nbr_Non_Null_Source;
+
+ function To_Resolver_Acc is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Resolver_Acc);
+
+ procedure Compute_Resolved_Signal (Resolv : Resolved_Signal_Acc)
+ is
+ Sig : constant Ghdl_Signal_Ptr :=
+ Sig_Table.Table (Resolv.Sig_Range.First);
+ Length : Ghdl_Index_Type;
+ type Bool_Array_Type is array (1 .. Sig.S.Nbr_Drivers) of Boolean;
+ Vec : Bool_Array_Type;
+ begin
+ -- Compute number of non-null drivers.
+ Length := 0;
+ for I in 1 .. Sig.S.Nbr_Drivers loop
+ case Sig.S.Drivers (I - 1).First_Trans.Kind is
+ when Trans_Value =>
+ Length := Length + 1;
+ Vec (I) := True;
+ when Trans_Null =>
+ Vec (I) := False;
+ when Trans_Error =>
+ Error ("range check error");
+ when Trans_Direct =>
+ Internal_Error ("compute_resolved_signal: trans_direct");
+ end case;
+ end loop;
+
+ -- Check driving condition on all signals.
+ for J in Resolv.Sig_Range.First + 1.. Resolv.Sig_Range.Last loop
+ for I in 1 .. Sig.S.Nbr_Drivers loop
+ if (Sig_Table.Table (J).S.Drivers (I - 1).First_Trans.Kind
+ /= Trans_Null)
+ xor Vec (I)
+ then
+ Error ("null-transaction required");
+ end if;
+ end loop;
+ end loop;
+
+ -- if no driving sources and register, exit.
+ if Length = 0
+ and then Sig.Nbr_Ports = 0
+ and then Sig.Sig_Kind = Kind_Signal_Register
+ then
+ return;
+ end if;
+
+ -- Call the procedure.
+ Resolv.Resolv_Proc.all (Resolv.Resolv_Inst,
+ Resolv.Resolv_Ptr,
+ Vec'Address,
+ Length,
+ Sig.S.Nbr_Drivers,
+ Sig.Nbr_Ports);
+ end Compute_Resolved_Signal;
+
+ procedure Call_Conversion_Function (Conv : Sig_Conversion_Acc)
+ is
+ F : Conversion_Func_Acc;
+ begin
+ F := To_Conversion_Func_Acc (Conv.Func);
+ F.all (Conv.Instance);
+ end Call_Conversion_Function;
+
+ procedure Resume_Process_If_Event
+ (Sig : Ghdl_Signal_Ptr; Proc : Process_Acc)
+ is
+ El : Action_List_Acc;
+ begin
+ El := new Action_List'(Dynamic => False,
+ Proc => Proc,
+ Next => Sig.Event_List);
+ Sig.Event_List := El;
+ end Resume_Process_If_Event;
+
+ -- Order of signals:
+ -- To be computed: driving value or/and effective value
+ -- To be considered: ports, signals, implicit signals, resolution,
+ -- conversion
+ --
+
+ procedure Add_Propagation (P : Propagation_Type) is
+ begin
+ Propagation.Increment_Last;
+ Propagation.Table (Propagation.Last) := P;
+ end Add_Propagation;
+
+ procedure Add_Forward_Propagation (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ for I in 1 .. Sig.Nbr_Ports loop
+ Add_Propagation
+ ((Kind => Imp_Forward_Build,
+ Forward => new Forward_Build_Type'(Src => Sig.Ports (I - 1),
+ Targ => Sig)));
+ end loop;
+ end Add_Forward_Propagation;
+
+ -- Put SIG in PROPAGATION table until ORDER level.
+ procedure Order_Signal (Sig : Ghdl_Signal_Ptr; Order : Propag_Order_Flag);
+
+ -- Return TRUE is the effective value of SIG is the driving value of SIG.
+ function Is_Eff_Drv (Sig : Ghdl_Signal_Ptr) return Boolean
+ is
+ begin
+ case Sig.S.Mode_Sig is
+ when Mode_Signal
+ | Mode_Buffer =>
+ return True;
+ when Mode_Linkage
+ | Mode_Out =>
+ -- No effective value.
+ return False;
+ when Mode_Inout
+ | Mode_In =>
+ if Sig.S.Effective = null then
+ if Sig.S.Nbr_Drivers > 0 or Sig.Nbr_Ports > 0 then
+ -- Only for inout.
+ return True;
+ else
+ return False;
+ end if;
+ else
+ return False;
+ end if;
+ when Mode_Conv_In
+ | Mode_Conv_Out =>
+ return False;
+ when Mode_Stable
+ | Mode_Guard
+ | Mode_Quiet
+ | Mode_Transaction
+ | Mode_Delayed =>
+ return True;
+ when Mode_End =>
+ return False;
+ end case;
+ end Is_Eff_Drv;
+
+ procedure Order_Signal_List (Sig : Ghdl_Signal_Ptr;
+ Order : Propag_Order_Flag)
+ is
+ begin
+ for I in 1 .. Sig.Nbr_Ports loop
+ Order_Signal (Sig.Ports (I - 1), Order);
+ end loop;
+ end Order_Signal_List;
+
+ -- Put SIG in PROPAGATION table until ORDER level.
+ procedure Order_Signal (Sig : Ghdl_Signal_Ptr; Order : Propag_Order_Flag)
+ is
+ begin
+ if Sig = null then
+ return;
+ end if;
+
+ -- Catch infinite loops, which must never happen.
+ -- Also exit if the signal is already fully ordered.
+ case Sig.Flags.Propag is
+ when Propag_None =>
+ null;
+ when Propag_Being_Driving =>
+ Internal_Error ("order_signal: being driving");
+ when Propag_Being_Effective =>
+ Internal_Error ("order_signal: being effective");
+ when Propag_Driving =>
+ null;
+ when Propag_Done =>
+ -- If sig was already handled, nothing to do!
+ return;
+ end case;
+
+ -- First, the driving value.
+ if Sig.Flags.Propag = Propag_None then
+ case Sig.S.Mode_Sig is
+ when Mode_Signal_User =>
+ if Sig.S.Nbr_Drivers = 0 and Sig.Nbr_Ports = 0 then
+ -- No source.
+ Sig.Flags.Propag := Propag_Driving;
+ elsif Sig.S.Resolv = null then
+ -- Not resolved (so at most one source).
+ if Sig.S.Nbr_Drivers = 1 then
+ -- Not resolved, 1 source : a driver.
+ if Is_Eff_Drv (Sig) then
+ Add_Propagation ((Kind => Eff_One_Driver, Sig => Sig));
+ Sig.Flags.Propag := Propag_Done;
+ else
+ Add_Propagation ((Kind => Drv_One_Driver, Sig => Sig));
+ Sig.Flags.Propag := Propag_Driving;
+ end if;
+ else
+ Sig.Flags.Propag := Propag_Being_Driving;
+ -- not resolved, 1 source : Source is a port.
+ Order_Signal (Sig.Ports (0), Propag_Driving);
+ if Is_Eff_Drv (Sig) then
+ Add_Propagation ((Kind => Eff_One_Port, Sig => Sig));
+ Sig.Flags.Propag := Propag_Done;
+ else
+ Add_Propagation ((Kind => Drv_One_Port, Sig => Sig));
+ Sig.Flags.Propag := Propag_Driving;
+ end if;
+ end if;
+ else
+ -- Resolved signal.
+ declare
+ Resolv : Resolved_Signal_Acc;
+ S : Ghdl_Signal_Ptr;
+ begin
+ -- Compute driving value of brothers.
+ Resolv := Sig.S.Resolv;
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last
+ loop
+ S := Sig_Table.Table (I);
+ if S.Flags.Propag /= Propag_None then
+ Internal_Error ("order_signal(1)");
+ end if;
+ S.Flags.Propag := Propag_Being_Driving;
+ end loop;
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last
+ loop
+ S := Sig_Table.Table (I);
+ -- Compute driving value of the sources.
+ for J in 1 .. S.Nbr_Ports loop
+ Order_Signal (S.Ports (J - 1), Propag_Driving);
+ end loop;
+ end loop;
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last
+ loop
+ S := Sig_Table.Table (I);
+ S.Flags.Propag := Propag_Driving;
+ end loop;
+
+ if Is_Eff_Drv (Sig) then
+ if Resolv.Sig_Range.First = Resolv.Sig_Range.Last then
+ Add_Propagation ((Kind => Eff_One_Resolved,
+ Sig => Sig));
+ else
+ Add_Propagation ((Kind => Eff_Multiple,
+ Resolv => Resolv));
+ end if;
+ else
+ if Resolv.Sig_Range.First = Resolv.Sig_Range.Last then
+ Add_Propagation ((Kind => Drv_One_Resolved,
+ Sig => Sig));
+ else
+ Add_Propagation ((Kind => Drv_Multiple,
+ Resolv => Resolv));
+ end if;
+ end if;
+ end;
+ end if;
+ when Mode_Signal_Implicit =>
+ Sig.Flags.Propag := Propag_Being_Driving;
+ Order_Signal_List (Sig, Propag_Done);
+ Sig.Flags.Propag := Propag_Done;
+ if Sig.S.Mode_Sig in Mode_Signal_Forward then
+ Add_Forward_Propagation (Sig);
+ end if;
+ case Mode_Signal_Implicit (Sig.S.Mode_Sig) is
+ when Mode_Guard =>
+ Add_Propagation ((Kind => Imp_Guard, Sig => Sig));
+ when Mode_Stable =>
+ Add_Propagation ((Kind => Imp_Stable, Sig => Sig));
+ when Mode_Quiet =>
+ Add_Propagation ((Kind => Imp_Quiet, Sig => Sig));
+ when Mode_Transaction =>
+ Add_Propagation ((Kind => Imp_Transaction, Sig => Sig));
+ when Mode_Delayed =>
+ Add_Propagation ((Kind => Imp_Delayed, Sig => Sig));
+ end case;
+ return;
+ when Mode_Conv_In =>
+ -- In conversion signals have no driving value
+ null;
+ when Mode_Conv_Out =>
+ declare
+ Conv : Sig_Conversion_Acc;
+ begin
+ Conv := Sig.S.Conv;
+ for I in Conv.Dest.First .. Conv.Dest.Last loop
+ Sig_Table.Table (I).Flags.Propag := Propag_Being_Driving;
+ end loop;
+ for I in Conv.Src.First .. Conv.Src.Last loop
+ Order_Signal (Sig_Table.Table (I), Propag_Driving);
+ end loop;
+ Add_Propagation ((Kind => Out_Conversion, Conv => Conv));
+ for I in Conv.Dest.First .. Conv.Dest.Last loop
+ Sig_Table.Table (I).Flags.Propag := Propag_Done;
+ end loop;
+ end;
+ when Mode_End =>
+ Internal_Error ("order_signal: mode_end");
+ end case;
+ end if;
+
+ -- Effective value.
+ if Order = Propag_Driving then
+ -- Will be done later.
+ return;
+ end if;
+
+ case Sig.S.Mode_Sig is
+ when Mode_Signal
+ | Mode_Buffer =>
+ -- Effective value is driving value.
+ Sig.Flags.Propag := Propag_Done;
+ when Mode_Linkage
+ | Mode_Out =>
+ -- No effective value.
+ Sig.Flags.Propag := Propag_Done;
+ when Mode_Inout
+ | Mode_In =>
+ if Sig.S.Effective = null then
+ -- Effective value is driving value or initial value.
+ null;
+ else
+ Sig.Flags.Propag := Propag_Being_Effective;
+ Order_Signal (Sig.S.Effective, Propag_Done);
+ Add_Propagation ((Kind => Eff_Actual, Sig => Sig));
+ Sig.Flags.Propag := Propag_Done;
+ end if;
+ when Mode_Stable
+ | Mode_Guard
+ | Mode_Quiet
+ | Mode_Transaction
+ | Mode_Delayed =>
+ -- Sig.Propag is already set to PROPAG_DONE.
+ null;
+ when Mode_Conv_In =>
+ declare
+ Conv : Sig_Conversion_Acc;
+ begin
+ Conv := Sig.S.Conv;
+ for I in Conv.Dest.First .. Conv.Dest.Last loop
+ Sig_Table.Table (I).Flags.Propag := Propag_Being_Effective;
+ end loop;
+ for I in Conv.Src.First .. Conv.Src.Last loop
+ Order_Signal (Sig_Table.Table (I), Propag_Done);
+ end loop;
+ Add_Propagation ((Kind => In_Conversion, Conv => Conv));
+ for I in Conv.Dest.First .. Conv.Dest.Last loop
+ Sig_Table.Table (I).Flags.Propag := Propag_Done;
+ end loop;
+ end;
+ when Mode_Conv_Out =>
+ -- No effective value.
+ null;
+ when Mode_End =>
+ Internal_Error ("order_signal: mode_end");
+ end case;
+ end Order_Signal;
+
+ procedure Set_Net (Sig : Ghdl_Signal_Ptr;
+ Net : Signal_Net_Type;
+ Link : Ghdl_Signal_Ptr)
+ is
+ use Astdio;
+ use Stdio;
+ begin
+ if Sig = null then
+ return;
+ end if;
+
+ if Boolean'(False) then
+ Put ("set_net ");
+ Put_I32 (stdout, Ghdl_I32 (Net));
+ Put (" on ");
+ Put (stdout, Sig.all'Address);
+ Put (" ");
+ Disp_Signals.Disp_Mode_Signal (Sig.S.Mode_Sig);
+ New_Line;
+ end if;
+
+ if Sig.Net /= No_Signal_Net then
+ if Sig.Net /= Net then
+ -- Renumber.
+ if Boolean'(False) then
+ Put ("set_net renumber ");
+ Put_I32 (stdout, Ghdl_I32 (Net));
+ Put (" on ");
+ Put (stdout, Sig.all'Address);
+ New_Line;
+ end if;
+
+ declare
+ S : Ghdl_Signal_Ptr;
+ Old : constant Signal_Net_Type := Sig.Net;
+ begin
+ -- Merge the old net into NET.
+ S := Sig;
+ loop
+ S.Net := Net;
+ S := S.Link;
+ exit when S = Sig;
+ end loop;
+
+ -- Add to the ring.
+ S := Sig.Link;
+ Sig.Link := Link.Link;
+ Link.Link := S;
+
+ -- Check.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ if Sig_Table.Table (I).Net = Old then
+-- Disp_Signals.Disp_Signals_Table;
+-- Disp_Signals.Disp_Signals_Map;
+
+ Internal_Error ("set_net: link corrupted");
+ end if;
+ end loop;
+ end;
+ end if;
+ return;
+ end if;
+
+ Sig.Net := Net;
+
+ -- Add SIG in the LINK ring.
+ -- Note: this works even if LINK is not a ring (ie, LINK.link = null).
+ if Link.Link = null and then Sig /= Link then
+ Internal_Error ("set_net: bad link");
+ end if;
+ Sig.Link := Link.Link;
+ Link.Link := Sig;
+
+ -- Dependences.
+ case Sig.S.Mode_Sig is
+ when Mode_Signal_User =>
+ for I in 1 .. Sig.Nbr_Ports loop
+ Set_Net (Sig.Ports (I - 1), Net, Link);
+ end loop;
+ Set_Net (Sig.S.Effective, Net, Link);
+ if Sig.S.Resolv /= null then
+ for I in Sig.S.Resolv.Sig_Range.First
+ .. Sig.S.Resolv.Sig_Range.Last
+ loop
+ Set_Net (Sig_Table.Table (I), Net, Link);
+ end loop;
+ end if;
+ when Mode_Signal_Forward =>
+ null;
+ when Mode_Transaction
+ | Mode_Guard =>
+ for I in 1 .. Sig.Nbr_Ports loop
+ Set_Net (Sig.Ports (I - 1), Net, Link);
+ end loop;
+ when Mode_Conv_In
+ | Mode_Conv_Out =>
+ declare
+ S : Ghdl_Signal_Ptr;
+ Conv : Sig_Conversion_Acc;
+ begin
+ Conv := Sig.S.Conv;
+ S := Sig_Table.Table (Conv.Src.First);
+ if Sig = S or else S.Net /= Net then
+ for J in Conv.Src.First .. Conv.Src.Last loop
+ Set_Net (Sig_Table.Table (J), Net, Link);
+ end loop;
+ for J in Conv.Dest.First .. Conv.Dest.Last loop
+ Set_Net (Sig_Table.Table (J), Net, Link);
+ end loop;
+ end if;
+ end;
+ when Mode_End =>
+ Internal_Error ("set_net");
+ end case;
+ end Set_Net;
+
+ function Get_Propagation_Net (P : Signal_Net_Type) return Signal_Net_Type
+ is
+ begin
+ case Propagation.Table (P).Kind is
+ when Drv_Multiple
+ | Eff_Multiple =>
+ return Sig_Table.Table
+ (Propagation.Table (P).Resolv.Sig_Range.First).Net;
+ when In_Conversion
+ | Out_Conversion =>
+ return Sig_Table.Table
+ (Propagation.Table (P).Conv.Src.First).Net;
+ when Imp_Forward_Build =>
+ return Propagation.Table (P).Forward.Src.Net;
+ when others =>
+ return Propagation.Table (P).Sig.Net;
+ end case;
+ end Get_Propagation_Net;
+
+ Last_Signal_Net : Signal_Net_Type;
+
+ -- Create a net for SIG, or if one of its dependences has already a net,
+ -- merge SIG in this net.
+ procedure Merge_Net (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ if Sig.S.Resolv = null
+ and then Sig.Nbr_Ports = 0
+ and then Sig.S.Effective = null
+ then
+ Internal_Error ("merge_net(1)");
+ end if;
+
+ if Sig.S.Effective /= null
+ and then Sig.S.Effective.Net /= No_Signal_Net
+ then
+ -- Avoid to create a net, just merge.
+ Set_Net (Sig, Sig.S.Effective.Net, Sig.S.Effective);
+ return;
+ end if;
+ end if;
+
+ if Sig.Nbr_Ports >= 1
+ and then Sig.Ports (0).Net /= No_Signal_Net
+ then
+ -- Avoid to create a net, just merge.
+ Set_Net (Sig, Sig.Ports (0).Net, Sig.Ports (0));
+ else
+ Last_Signal_Net := Last_Signal_Net + 1;
+ Set_Net (Sig, Last_Signal_Net, Sig);
+ end if;
+ end Merge_Net;
+
+ -- Create nets.
+ -- For all signals, set the net field.
+ procedure Create_Nets
+ is
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ Last_Signal_Net := No_Signal_Net;
+
+ for I in reverse Propagation.First .. Propagation.Last loop
+ case Propagation.Table (I).Kind is
+ when Drv_Error
+ | Prop_End =>
+ null;
+ when Drv_One_Driver
+ | Eff_One_Driver =>
+ null;
+ when Eff_One_Resolved =>
+ Sig := Propagation.Table (I).Sig;
+ -- Do not create a net if the signal has no dependences.
+ if Sig.Net = No_Signal_Net
+ and then (Sig.S.Effective /= null or Sig.Nbr_Ports /= 0)
+ then
+ Merge_Net (Sig);
+ end if;
+ when Drv_One_Port
+ | Eff_One_Port
+ | Imp_Guard
+ | Imp_Transaction
+ | Eff_Actual
+ | Drv_One_Resolved =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Net = No_Signal_Net then
+ Merge_Net (Sig);
+ end if;
+ when Imp_Forward =>
+ -- Should not yet appear.
+ Internal_Error ("create_nets - forward");
+ when Imp_Forward_Build =>
+ Sig := Propagation.Table (I).Forward.Src;
+ if Sig.Net = No_Signal_Net then
+ -- Create a new net with only sig.
+ Last_Signal_Net := Last_Signal_Net + 1;
+ Set_Net (Sig, Last_Signal_Net, Sig);
+ end if;
+ when Imp_Quiet
+ | Imp_Stable
+ | Imp_Delayed =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Net = No_Signal_Net then
+ -- Create a new net with only sig.
+ Last_Signal_Net := Last_Signal_Net + 1;
+ Sig.Net := Last_Signal_Net;
+ Sig.Link := Sig;
+ end if;
+ when Drv_Multiple
+ | Eff_Multiple =>
+ declare
+ Resolv : Resolved_Signal_Acc;
+ Link : Ghdl_Signal_Ptr;
+ begin
+ Last_Signal_Net := Last_Signal_Net + 1;
+ Resolv := Propagation.Table (I).Resolv;
+ Link := Sig_Table.Table (Resolv.Sig_Range.First);
+ for J in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop
+ Set_Net (Sig_Table.Table (J), Last_Signal_Net, Link);
+ end loop;
+ end;
+ when In_Conversion
+ | Out_Conversion =>
+ declare
+ Conv : Sig_Conversion_Acc;
+ Link : Ghdl_Signal_Ptr;
+ begin
+ Conv := Propagation.Table (I).Conv;
+ Link := Sig_Table.Table (Conv.Src.First);
+ if Link.Net = No_Signal_Net then
+ Last_Signal_Net := Last_Signal_Net + 1;
+ Set_Net (Link, Last_Signal_Net, Link);
+ end if;
+ end;
+ end case;
+ end loop;
+
+ -- Reorder propagation table.
+ declare
+ type Off_Array is array (Signal_Net_Type range <>) of Signal_Net_Type;
+ Offs : Off_Array (0 .. Last_Signal_Net) := (others => 0);
+
+ Last_Off : Signal_Net_Type;
+ Num : Signal_Net_Type;
+
+-- procedure Disp_Offs
+-- is
+-- use Grt.Astdio;
+-- use Grt.Stdio;
+-- begin
+-- for I in Offs'Range loop
+-- if Offs (I) /= 0 then
+-- Put_I32 (stdout, Ghdl_I32 (I));
+-- Put (": ");
+-- Put_I32 (stdout, Ghdl_I32 (Offs (I)));
+-- New_Line;
+-- end if;
+-- end loop;
+-- end Disp_Offs;
+
+ type Propag_Array is array (Signal_Net_Type range <>)
+ of Propagation_Type;
+
+ procedure Deallocate is new Ada.Unchecked_Deallocation
+ (Object => Forward_Build_Type, Name => Forward_Build_Acc);
+
+ Net : Signal_Net_Type;
+ begin
+ -- 1) Count number of propagation cell per net.
+ for I in Propagation.First .. Propagation.Last loop
+ Net := Get_Propagation_Net (I);
+ Offs (Net) := Offs (Net) + 1;
+ end loop;
+
+ -- 2) Convert numbers to offsets.
+ Last_Off := 1;
+ for I in 1 .. Last_Signal_Net loop
+ Num := Offs (I);
+ if Num /= 0 then
+ -- Reserve one slot for a prepended 'prop_end'.
+ Offs (I) := Last_Off + 1;
+ Last_Off := Last_Off + 1 + Num;
+ end if;
+ end loop;
+ Offs (0) := Last_Off + 1;
+
+ declare
+ Propag : Propag_Array (1 .. Last_Off); -- := (others => 0);
+ begin
+ for I in Propagation.First .. Propagation.Last loop
+ Net := Get_Propagation_Net (I);
+ if Net /= No_Signal_Net then
+ Propag (Offs (Net)) := Propagation.Table (I);
+ Offs (Net) := Offs (Net) + 1;
+ end if;
+ end loop;
+ Propagation.Set_Last (Last_Off);
+ Propagation.Release;
+ for I in Propagation.First .. Propagation.Last loop
+ if Propag (I).Kind = Imp_Forward_Build then
+ Propagation.Table (I) := (Kind => Imp_Forward,
+ Sig => Propag (I).Forward.Targ);
+ Deallocate (Propag (I).Forward);
+ else
+ Propagation.Table (I) := Propag (I);
+ end if;
+ end loop;
+ end;
+ for I in 1 .. Last_Signal_Net loop
+ -- Ignore holes.
+ if Offs (I) /= 0 then
+ Propagation.Table (Offs (I)) :=
+ (Kind => Prop_End, Updated => True);
+ end if;
+ end loop;
+ Propagation.Table (1) := (Kind => Prop_End, Updated => True);
+
+ -- 4) Convert back from offset to start position (on the prop_end
+ -- cell).
+ Offs (0) := 1;
+ Last_Off := 1;
+ for I in 1 .. Last_Signal_Net loop
+ if Offs (I) /= 0 then
+ Num := Offs (I);
+ Offs (I) := Last_Off;
+ Last_Off := Num;
+ end if;
+ end loop;
+
+ -- 5) Re-map the nets to cell indexes.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Sig := Sig_Table.Table (I);
+ if Sig.Net = No_Signal_Net then
+ if Sig.S.Resolv /= null then
+ Sig.Net := Net_One_Resolved;
+ elsif Sig.S.Nbr_Drivers = 1 then
+ if Sig.S.Drivers (0).Last_Trans.Kind = Trans_Direct then
+ Sig.Net := Net_One_Direct;
+ else
+ Sig.Net := Net_One_Driver;
+ end if;
+ end if;
+ else
+ Sig.Net := Offs (Sig.Net);
+ end if;
+ Sig.Link := null;
+ end loop;
+ end;
+ end Create_Nets;
+
+ function Get_Nbr_Future return Ghdl_I32
+ is
+ Res : Ghdl_I32;
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ Res := 0;
+ Sig := Future_List;
+ while Sig.Flink /= null loop
+ Res := Res + 1;
+ Sig := Sig.Flink;
+ end loop;
+ return Res;
+ end Get_Nbr_Future;
+
+ -- Check every scalar subelement of a resolved signal has a driver
+ -- in the same process.
+ procedure Check_Resolved_Driver (Resolv : Resolved_Signal_Acc)
+ is
+ First_Sig : Ghdl_Signal_Ptr;
+ Nbr : Ghdl_Index_Type;
+ begin
+ First_Sig := Sig_Table.Table (Resolv.Sig_Range.First);
+ Nbr := First_Sig.S.Nbr_Drivers;
+ for I in Resolv.Sig_Range.First + 1 .. Resolv.Sig_Range.Last loop
+ if Sig_Table.Table (I).S.Nbr_Drivers /= Nbr then
+ -- FIXME: provide more information (signal name, process name).
+ Error ("missing drivers for subelement of a resolved signal");
+ end if;
+ end loop;
+ end Check_Resolved_Driver;
+
+ Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address;
+ pragma Import (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr,
+ "ieee__std_logic_1164__resolved_RESOLV_ptr");
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Name => Resolved_Signal_Acc, Object => Resolved_Signal_Type);
+
+ procedure Order_All_Signals
+ is
+ Sig : Ghdl_Signal_Ptr;
+ Resolv : Resolved_Signal_Acc;
+ begin
+ -- Do checks and optimization.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Sig := Sig_Table.Table (I);
+
+ -- LRM 5.3
+ -- If, by the above rules, no disconnection specification applies to
+ -- the drivers of a guarded, scalar signal S whose type mark is T
+ -- (including a scalar subelement of a composite signal), then the
+ -- following default disconnection specification is implicitly
+ -- assumed:
+ -- disconnect S : T after 0 ns;
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ Resolv := Sig.S.Resolv;
+ if Resolv /= null and then Resolv.Disconnect_Time = Bad_Time then
+ Resolv.Disconnect_Time := 0;
+ end if;
+
+ if Resolv /= null
+ and then Resolv.Sig_Range.First = I
+ and then Resolv.Sig_Range.Last > I
+ then
+ -- Check every scalar subelement of a resolved signal
+ -- has a driver in the same process.
+ Check_Resolved_Driver (Resolv);
+ end if;
+
+ if Resolv /= null
+ and then Resolv.Sig_Range.First = I
+ and then Resolv.Sig_Range.Last = I
+ and then
+ (Resolv.Resolv_Proc
+ = To_Resolver_Acc (Ieee_Std_Logic_1164_Resolved_Resolv_Ptr))
+ and then Sig.S.Nbr_Drivers + Sig.Nbr_Ports <= 1
+ then
+ -- Optimization: remove resolver if there is at most one
+ -- source.
+ Free (Sig.S.Resolv);
+ end if;
+ end if;
+ end loop;
+
+ -- Really order them.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Order_Signal (Sig_Table.Table (I), Propag_Driving);
+ end loop;
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Order_Signal (Sig_Table.Table (I), Propag_Done);
+ end loop;
+
+ Create_Nets;
+ end Order_All_Signals;
+
+ -- Add SIG in active_chain.
+ procedure Add_Active_Chain (Sig : Ghdl_Signal_Ptr);
+ pragma Inline (Add_Active_Chain);
+
+ procedure Add_Active_Chain (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ if Sig.Link = null then
+ Sig.Link := Ghdl_Signal_Active_Chain;
+ Ghdl_Signal_Active_Chain := Sig;
+ end if;
+ end Add_Active_Chain;
+
+ Clear_List : Ghdl_Signal_Ptr := null;
+
+ -- Mark SIG as active and put it on Clear_List (if not already).
+ procedure Mark_Active (Sig : Ghdl_Signal_Ptr);
+ pragma Inline (Mark_Active);
+
+ procedure Mark_Active (Sig : Ghdl_Signal_Ptr)
+ is
+ begin
+ if not Sig.Active then
+ Sig.Active := True;
+ Sig.Last_Active := Current_Time;
+ Sig.Alink := Clear_List;
+ Clear_List := Sig;
+ end if;
+ end Mark_Active;
+
+ procedure Set_Guard_Activity (Sig : Ghdl_Signal_Ptr) is
+ begin
+ for I in 1 .. Sig.Nbr_Ports loop
+ if Sig.Ports (I - 1).Active then
+ Mark_Active (Sig);
+ return;
+ end if;
+ end loop;
+ end Set_Guard_Activity;
+
+ procedure Set_Stable_Quiet_Activity
+ (Mode : Propagation_Kind_Type; Sig : Ghdl_Signal_Ptr) is
+ begin
+ case Mode is
+ when Imp_Stable =>
+ for I in 0 .. Sig.Nbr_Ports - 1 loop
+ if Sig.Ports (I).Event then
+ Mark_Active (Sig);
+ return;
+ end if;
+ end loop;
+ when Imp_Quiet
+ | Imp_Transaction =>
+ for I in 0 .. Sig.Nbr_Ports - 1 loop
+ if Sig.Ports (I).Active then
+ Mark_Active (Sig);
+ return;
+ end if;
+ end loop;
+ when others =>
+ Internal_Error ("set_stable_quiet_activity");
+ end case;
+ end Set_Stable_Quiet_Activity;
+
+ function Get_Resolved_Activity (Sig : Ghdl_Signal_Ptr) return Boolean
+ is
+ Trans : Transaction_Acc;
+ Res : Boolean := False;
+ begin
+ for J in 1 .. Sig.S.Nbr_Drivers loop
+ Trans := Sig.S.Drivers (J - 1).First_Trans.Next;
+ if Trans /= null then
+ if Trans.Kind = Trans_Direct then
+ Direct_Assign (Sig.S.Drivers (J - 1).First_Trans.Val,
+ Trans.Val_Ptr, Sig.Mode);
+ -- In fact we knew the signal was active!
+ Res := True;
+ elsif Trans.Time = Current_Time then
+ Free (Sig.S.Drivers (J - 1).First_Trans);
+ Sig.S.Drivers (J - 1).First_Trans := Trans;
+ Res := True;
+ end if;
+ end if;
+ end loop;
+ if Res then
+ return True;
+ end if;
+ for J in 1 .. Sig.Nbr_Ports loop
+ if Sig.Ports (J - 1).Active then
+ return True;
+ end if;
+ end loop;
+ return False;
+ end Get_Resolved_Activity;
+
+ procedure Set_Conversion_Activity (Conv : Sig_Conversion_Acc)
+ is
+ Active : Boolean := False;
+ begin
+ for I in Conv.Src.First .. Conv.Src.Last loop
+ Active := Active or Sig_Table.Table (I).Active;
+ end loop;
+ if Active then
+ Call_Conversion_Function (Conv);
+ end if;
+ for I in Conv.Dest.First .. Conv.Dest.Last loop
+ Sig_Table.Table (I).Active := Active;
+ end loop;
+ end Set_Conversion_Activity;
+
+ procedure Delayed_Implicit_Process (Sig : Ghdl_Signal_Ptr)
+ is
+ Pfx : Ghdl_Signal_Ptr;
+ Trans : Transaction_Acc;
+ Last : Transaction_Acc;
+ Prev : Transaction_Acc;
+ begin
+ Pfx := Sig.Ports (0);
+ if Pfx.Event then
+ -- LRM 14.1
+ -- P: process (S)
+ -- begin
+ -- R <= transport S after T;
+ -- end process;
+ Trans := new Transaction'(Kind => Trans_Value,
+ Line => 0,
+ Time => Current_Time + Sig.S.Time,
+ Next => null,
+ Val => Pfx.Value);
+ -- Find the last transaction.
+ Last := Sig.S.Attr_Trans;
+ Prev := Last;
+ while Last.Next /= null loop
+ Prev := Last;
+ Last := Last.Next;
+ end loop;
+ -- Maybe, remove it.
+ if Last.Time > Trans.Time then
+ Internal_Error ("delayed time");
+ elsif Last.Time = Trans.Time then
+ if Prev /= Last then
+ Free (Last);
+ else
+ -- No transaction.
+ if Last.Time /= 0 then
+ -- This can happen only at time = 0.
+ Internal_Error ("delayed");
+ end if;
+ end if;
+ else
+ Prev := Last;
+ end if;
+ -- Append the transaction.
+ Prev.Next := Trans;
+ if Sig.S.Time = 0 then
+ Add_Active_Chain (Sig);
+ end if;
+ end if;
+ end Delayed_Implicit_Process;
+
+ -- Set the effective value of signal SIG to VAL.
+ -- If the value is different from the previous one, resume processes.
+ procedure Set_Effective_Value (Sig : Ghdl_Signal_Ptr; Val : Value_Union)
+ is
+ El : Action_List_Acc;
+ begin
+ if not Value_Equal (Sig.Value, Val, Sig.Mode) then
+ Sig.Last_Value := Sig.Value;
+ Sig.Value := Val;
+ Sig.Event := True;
+ Sig.Last_Event := Current_Time;
+ Sig.Flags.Cyc_Event := True;
+
+ El := Sig.Event_List;
+ while El /= null loop
+ Resume_Process (El.Proc);
+ El := El.Next;
+ end loop;
+ end if;
+ end Set_Effective_Value;
+
+ procedure Run_Propagation (Start : Signal_Net_Type)
+ is
+ I : Signal_Net_Type;
+ Sig : Ghdl_Signal_Ptr;
+ Trans : Transaction_Acc;
+ First_Trans : Transaction_Acc;
+ begin
+ I := Start;
+ loop
+ -- First: the driving value.
+ case Propagation.Table (I).Kind is
+ when Drv_One_Driver
+ | Eff_One_Driver =>
+ Sig := Propagation.Table (I).Sig;
+ First_Trans := Sig.S.Drivers (0).First_Trans;
+ Trans := First_Trans.Next;
+ if Trans /= null then
+ if Trans.Kind = Trans_Direct then
+ -- Note: already or will be marked as active in
+ -- update_signals.
+ Mark_Active (Sig);
+ Direct_Assign (First_Trans.Val,
+ Trans.Val_Ptr, Sig.Mode);
+ Sig.Driving_Value := First_Trans.Val;
+ elsif Trans.Time = Current_Time then
+ Mark_Active (Sig);
+ Free (First_Trans);
+ Sig.S.Drivers (0).First_Trans := Trans;
+ case Trans.Kind is
+ when Trans_Value =>
+ Sig.Driving_Value := Trans.Val;
+ when Trans_Direct =>
+ Internal_Error ("run_propagation: trans_direct");
+ when Trans_Null =>
+ Error ("null transaction");
+ when Trans_Error =>
+ Error_Trans_Error (Trans);
+ end case;
+ end if;
+ end if;
+ when Drv_One_Resolved
+ | Eff_One_Resolved =>
+ Sig := Propagation.Table (I).Sig;
+ if Get_Resolved_Activity (Sig) then
+ Mark_Active (Sig);
+ Compute_Resolved_Signal (Propagation.Table (I).Sig.S.Resolv);
+ end if;
+ when Drv_One_Port
+ | Eff_One_Port =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Ports (0).Active then
+ Mark_Active (Sig);
+ Sig.Driving_Value := Sig.Ports (0).Driving_Value;
+ end if;
+ when Eff_Actual =>
+ Sig := Propagation.Table (I).Sig;
+ -- Note: the signal may have drivers (inout ports).
+ if Sig.S.Effective.Active and not Sig.Active then
+ Mark_Active (Sig);
+ end if;
+ when Drv_Multiple
+ | Eff_Multiple =>
+ declare
+ Active : Boolean := False;
+ Resolv : Resolved_Signal_Acc;
+ begin
+ Resolv := Propagation.Table (I).Resolv;
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop
+ Sig := Sig_Table.Table (I);
+ Active := Active or Get_Resolved_Activity (Sig);
+ end loop;
+ if Active then
+ -- Mark the first signal as active (since only this one
+ -- will be checked to set effective value).
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last
+ loop
+ Mark_Active (Sig_Table.Table (I));
+ end loop;
+ Compute_Resolved_Signal (Resolv);
+ end if;
+ end;
+ when Imp_Guard
+ | Imp_Stable
+ | Imp_Quiet
+ | Imp_Transaction
+ | Imp_Forward_Build =>
+ null;
+ when Imp_Forward =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Link = null then
+ Sig.Link := Ghdl_Implicit_Signal_Active_Chain;
+ Ghdl_Implicit_Signal_Active_Chain := Sig;
+ end if;
+ when Imp_Delayed =>
+ Sig := Propagation.Table (I).Sig;
+ Trans := Sig.S.Attr_Trans.Next;
+ if Trans /= null and then Trans.Time = Current_Time then
+ Mark_Active (Sig);
+ Free (Sig.S.Attr_Trans);
+ Sig.S.Attr_Trans := Trans;
+ Sig.Driving_Value := Trans.Val;
+ end if;
+ when In_Conversion =>
+ null;
+ when Out_Conversion =>
+ Set_Conversion_Activity (Propagation.Table (I).Conv);
+ when Prop_End =>
+ return;
+ when Drv_Error =>
+ Internal_Error ("update signals");
+ end case;
+
+ -- Second: the effective value.
+ case Propagation.Table (I).Kind is
+ when Drv_One_Driver
+ | Drv_One_Port
+ | Drv_One_Resolved
+ | Drv_Multiple =>
+ null;
+ when Eff_One_Driver
+ | Eff_One_Port
+ | Eff_One_Resolved =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Active then
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ end if;
+ when Eff_Multiple =>
+ declare
+ Resolv : Resolved_Signal_Acc;
+ begin
+ Resolv := Propagation.Table (I).Resolv;
+ if Sig_Table.Table (Resolv.Sig_Range.First).Active then
+ -- If one signal is active, all are active.
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last
+ loop
+ Sig := Sig_Table.Table (I);
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ end loop;
+ end if;
+ end;
+ when Eff_Actual =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Active then
+ Set_Effective_Value (Sig, Sig.S.Effective.Value);
+ end if;
+ when Imp_Forward
+ | Imp_Forward_Build =>
+ null;
+ when Imp_Guard =>
+ -- Guard signal is active iff one of its dependence is active.
+ Sig := Propagation.Table (I).Sig;
+ Set_Guard_Activity (Sig);
+ if Sig.Active then
+ Sig.Driving_Value.B1 :=
+ Sig.S.Guard_Func.all (Sig.S.Guard_Instance);
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ end if;
+ when Imp_Stable
+ | Imp_Quiet =>
+ Sig := Propagation.Table (I).Sig;
+ Set_Stable_Quiet_Activity (Propagation.Table (I).Kind, Sig);
+ if Sig.Active then
+ Sig.Driving_Value :=
+ Value_Union'(Mode => Mode_B1, B1 => False);
+ -- Set driver.
+ Trans := new Transaction'
+ (Kind => Trans_Value,
+ Line => 0,
+ Time => Current_Time + Sig.S.Time,
+ Next => null,
+ Val => Value_Union'(Mode => Mode_B1, B1 => True));
+ if Sig.S.Attr_Trans.Next /= null then
+ Free (Sig.S.Attr_Trans.Next);
+ end if;
+ Sig.S.Attr_Trans.Next := Trans;
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ if Sig.S.Time = 0 then
+ Add_Active_Chain (Sig);
+ end if;
+ else
+ Trans := Sig.S.Attr_Trans.Next;
+ if Trans /= null and then Trans.Time = Current_Time then
+ Mark_Active (Sig);
+ Free (Sig.S.Attr_Trans);
+ Sig.S.Attr_Trans := Trans;
+ Sig.Driving_Value := Trans.Val;
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ end if;
+ end if;
+ when Imp_Transaction =>
+ -- LRM 12.6.3 Updating Implicit Signals
+ -- Finally, for any implicit signal S'Transaction, the current
+ -- value of the signal is modified if and only if S is active.
+ -- If signal S is active, then S'Transaction is updated by
+ -- assigning the value of the expression (not S'Transaction)
+ -- to the variable representing the current value of
+ -- S'Transaction.
+ Sig := Propagation.Table (I).Sig;
+ for I in 0 .. Sig.Nbr_Ports - 1 loop
+ if Sig.Ports (I).Active then
+ Mark_Active (Sig);
+ Set_Effective_Value
+ (Sig, Value_Union'(Mode => Mode_B1,
+ B1 => not Sig.Value.B1));
+ exit;
+ end if;
+ end loop;
+ when Imp_Delayed =>
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Active then
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+ end if;
+ Delayed_Implicit_Process (Sig);
+ when In_Conversion =>
+ Set_Conversion_Activity (Propagation.Table (I).Conv);
+ when Out_Conversion =>
+ null;
+ when Prop_End =>
+ null;
+ when Drv_Error =>
+ Internal_Error ("run_propagation(2)");
+ end case;
+ I := I + 1;
+ end loop;
+ end Run_Propagation;
+
+ procedure Reset_Active_Flag
+ is
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ -- 1) Reset active flag.
+ Sig := Clear_List;
+ Clear_List := null;
+ while Sig /= null loop
+ if Options.Flag_Stats then
+ if Sig.Active then
+ Nbr_Active := Nbr_Active + 1;
+ end if;
+ if Sig.Event then
+ Nbr_Events := Nbr_Events + 1;
+ end if;
+ end if;
+ Sig.Active := False;
+ Sig.Event := False;
+
+ Sig := Sig.Alink;
+ end loop;
+
+-- for I in Sig_Table.First .. Sig_Table.Last loop
+-- Sig := Sig_Table.Table (I);
+-- if Sig.Active or Sig.Event then
+-- Internal_Error ("reset_active_flag");
+-- end if;
+-- end loop;
+ end Reset_Active_Flag;
+
+ procedure Update_Signals
+ is
+ Sig : Ghdl_Signal_Ptr;
+ Next_Sig : Ghdl_Signal_Ptr;
+ Trans : Transaction_Acc;
+ begin
+ -- LRM93 12.6.2
+ -- 1) Reset active flag.
+ Reset_Active_Flag;
+
+ -- For each active signals
+ Sig := Ghdl_Signal_Active_Chain;
+ Ghdl_Signal_Active_Chain := Signal_End;
+ while Sig.S.Mode_Sig /= Mode_End loop
+ Next_Sig := Sig.Link;
+ Sig.Link := null;
+
+ case Sig.Net is
+ when Net_One_Driver =>
+ -- This signal is active.
+ Mark_Active (Sig);
+
+ Trans := Sig.S.Drivers (0).First_Trans.Next;
+ Free (Sig.S.Drivers (0).First_Trans);
+ Sig.S.Drivers (0).First_Trans := Trans;
+ case Trans.Kind is
+ when Trans_Value =>
+ Sig.Driving_Value := Trans.Val;
+ when Trans_Direct =>
+ Internal_Error ("update_signals: trans_direct");
+ when Trans_Null =>
+ Error ("null transaction");
+ when Trans_Error =>
+ Error_Trans_Error (Trans);
+ end case;
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+
+ when Net_One_Direct =>
+ Mark_Active (Sig);
+ Sig.Is_Direct_Active := False;
+
+ Trans := Sig.S.Drivers (0).Last_Trans;
+ Direct_Assign (Sig.Driving_Value, Trans.Val_Ptr, Sig.Mode);
+ Sig.S.Drivers (0).First_Trans.Val := Sig.Driving_Value;
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+
+ when Net_One_Resolved =>
+ -- This signal is active.
+ Mark_Active (Sig);
+ Sig.Is_Direct_Active := False;
+
+ for J in 1 .. Sig.S.Nbr_Drivers loop
+ Trans := Sig.S.Drivers (J - 1).First_Trans.Next;
+ if Trans /= null then
+ if Trans.Kind = Trans_Direct then
+ Direct_Assign (Sig.S.Drivers (J - 1).First_Trans.Val,
+ Trans.Val_Ptr, Sig.Mode);
+ elsif Trans.Time = Current_Time then
+ Free (Sig.S.Drivers (J - 1).First_Trans);
+ Sig.S.Drivers (J - 1).First_Trans := Trans;
+ end if;
+ end if;
+ end loop;
+ Compute_Resolved_Signal (Sig.S.Resolv);
+ Set_Effective_Value (Sig, Sig.Driving_Value);
+
+ when No_Signal_Net =>
+ Internal_Error ("update_signals: no_signal_net");
+
+ when others =>
+ Sig.Is_Direct_Active := False;
+ if not Propagation.Table (Sig.Net).Updated then
+ Propagation.Table (Sig.Net).Updated := True;
+ Run_Propagation (Sig.Net + 1);
+
+ -- Put it on the list, so that updated flag will be cleared.
+ Add_Active_Chain (Sig);
+ end if;
+ end case;
+
+ Sig := Next_Sig;
+ end loop;
+
+ -- Implicit signals (forwarded).
+ loop
+ Sig := Ghdl_Implicit_Signal_Active_Chain;
+ exit when Sig.Link = null;
+ Ghdl_Implicit_Signal_Active_Chain := Sig.Link;
+ Sig.Link := null;
+
+ if not Propagation.Table (Sig.Net).Updated then
+ Propagation.Table (Sig.Net).Updated := True;
+ Run_Propagation (Sig.Net + 1);
+
+ -- Put it on the list, so that updated flag will be cleared.
+ Add_Active_Chain (Sig);
+ end if;
+ end loop;
+
+ -- Un-mark updated.
+ Sig := Ghdl_Signal_Active_Chain;
+ Ghdl_Signal_Active_Chain := Signal_End;
+ while Sig.Link /= null loop
+ Propagation.Table (Sig.Net).Updated := False;
+ Next_Sig := Sig.Link;
+ Sig.Link := null;
+
+ -- Maybe put SIG in the active list, if it will be active during
+ -- the next cycle.
+ -- This can happen only for 'quiet, 'stable or 'delayed.
+ case Sig.S.Mode_Sig is
+ when Mode_Stable
+ | Mode_Quiet
+ | Mode_Delayed =>
+ declare
+ Trans : Transaction_Acc;
+ begin
+ Trans := Sig.S.Attr_Trans.Next;
+ if Trans /= null and then Trans.Time = Current_Time then
+ Sig.Link := Ghdl_Implicit_Signal_Active_Chain;
+ Ghdl_Implicit_Signal_Active_Chain := Sig;
+ end if;
+ end;
+ when others =>
+ null;
+ end case;
+
+ Sig := Next_Sig;
+ end loop;
+ end Update_Signals;
+
+ procedure Run_Propagation_Init (Start : Signal_Net_Type)
+ is
+ I : Signal_Net_Type;
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ I := Start;
+ loop
+ -- First: the driving value.
+ case Propagation.Table (I).Kind is
+ when Drv_One_Driver
+ | Eff_One_Driver =>
+ -- Nothing to do: drivers were already created.
+ null;
+ when Drv_One_Resolved
+ | Eff_One_Resolved =>
+ -- Execute the resolution function.
+ Sig := Propagation.Table (I).Sig;
+ if Sig.Nbr_Ports > 0 then
+ Compute_Resolved_Signal (Sig.S.Resolv);
+ end if;
+ when Drv_One_Port
+ | Eff_One_Port =>
+ -- Copy value.
+ Sig := Propagation.Table (I).Sig;
+ Sig.Driving_Value := Sig.Ports (0).Driving_Value;
+ when Eff_Actual =>
+ null;
+ when Drv_Multiple
+ | Eff_Multiple =>
+ Compute_Resolved_Signal (Propagation.Table (I).Resolv);
+ when Imp_Guard
+ | Imp_Stable
+ | Imp_Quiet
+ | Imp_Transaction
+ | Imp_Forward
+ | Imp_Forward_Build =>
+ null;
+ when Imp_Delayed =>
+ -- LRM 14.1
+ -- Assuming that the initial value of R is the same as the
+ -- initial value of S, [...]
+ Sig := Propagation.Table (I).Sig;
+ Sig.Driving_Value := Sig.Ports (0).Driving_Value;
+ when In_Conversion =>
+ null;
+ when Out_Conversion =>
+ Call_Conversion_Function (Propagation.Table (I).Conv);
+ when Prop_End =>
+ return;
+ when Drv_Error =>
+ Internal_Error ("init_signals");
+ end case;
+
+ -- Second: the effective value.
+ case Propagation.Table (I).Kind is
+ when Drv_One_Driver
+ | Drv_One_Port
+ | Drv_One_Resolved
+ | Drv_Multiple =>
+ null;
+ when Eff_One_Driver
+ | Eff_One_Port
+ | Eff_One_Resolved
+ | Imp_Delayed =>
+ Sig := Propagation.Table (I).Sig;
+ Sig.Value := Sig.Driving_Value;
+ when Eff_Multiple =>
+ declare
+ Resolv : Resolved_Signal_Acc;
+ begin
+ Resolv := Propagation.Table (I).Resolv;
+ for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop
+ Sig := Sig_Table.Table (I);
+ Sig.Value := Sig.Driving_Value;
+ end loop;
+ end;
+ when Eff_Actual =>
+ Sig := Propagation.Table (I).Sig;
+ Sig.Value := Sig.S.Effective.Value;
+ when Imp_Guard =>
+ -- Guard signal is active iff one of its dependence is active.
+ Sig := Propagation.Table (I).Sig;
+ Sig.Driving_Value.B1 :=
+ Sig.S.Guard_Func.all (Sig.S.Guard_Instance);
+ Sig.Value := Sig.Driving_Value;
+ when Imp_Stable
+ | Imp_Quiet
+ | Imp_Transaction
+ | Imp_Forward
+ | Imp_Forward_Build =>
+ -- Already initialized during creation.
+ null;
+ when In_Conversion =>
+ Call_Conversion_Function (Propagation.Table (I).Conv);
+ when Out_Conversion =>
+ null;
+ when Prop_End =>
+ null;
+ when Drv_Error =>
+ Internal_Error ("init_signals(2)");
+ end case;
+
+ I := I + 1;
+ end loop;
+ end Run_Propagation_Init;
+
+ procedure Init_Signals
+ is
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ Sig := Sig_Table.Table (I);
+
+ case Sig.Net is
+ when Net_One_Driver
+ | Net_One_Direct =>
+ -- Nothing to do: drivers were already created.
+ null;
+
+ when Net_One_Resolved =>
+ Sig.Has_Active := True;
+ if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 0 then
+ Compute_Resolved_Signal (Sig.S.Resolv);
+ Sig.Value := Sig.Driving_Value;
+ end if;
+
+ when No_Signal_Net =>
+ null;
+
+ when others =>
+ if Propagation.Table (Sig.Net).Updated then
+ Propagation.Table (Sig.Net).Updated := False;
+ Run_Propagation_Init (Sig.Net + 1);
+ end if;
+ end case;
+ end loop;
+
+ end Init_Signals;
+
+ procedure Init is
+ begin
+ Signal_End := new Ghdl_Signal'(Value => (Mode => Mode_B1,
+ B1 => False),
+ Driving_Value => (Mode => Mode_B1,
+ B1 => False),
+ Last_Value => (Mode => Mode_B1,
+ B1 => False),
+ Last_Event => 0,
+ Last_Active => 0,
+ Event => False,
+ Active => False,
+ Has_Active => False,
+ Is_Direct_Active => False,
+ Sig_Kind => Kind_Signal_No,
+ Mode => Mode_B1,
+
+ Flags => (Propag => Propag_None,
+ Is_Dumped => False,
+ Cyc_Event => False,
+ Seen => False),
+
+ Net => No_Signal_Net,
+ Link => null,
+ Alink => null,
+ Flink => null,
+
+ Event_List => null,
+ Rti => null,
+
+ Nbr_Ports => 0,
+ Ports => null,
+
+ S => (Mode_Sig => Mode_End));
+
+ Ghdl_Signal_Active_Chain := Signal_End;
+ Ghdl_Implicit_Signal_Active_Chain := Signal_End;
+ Future_List := Signal_End;
+
+ Boolean_Signal_Rti.Obj_Type := Std_Standard_Boolean_RTI_Ptr;
+ Bit_Signal_Rti.Obj_Type := Std_Standard_Bit_RTI_Ptr;
+ end Init;
+
+end Grt.Signals;
diff --git a/src/translate/grt/grt-signals.ads b/src/translate/grt/grt-signals.ads
new file mode 100644
index 000000000..d792f1634
--- /dev/null
+++ b/src/translate/grt/grt-signals.ads
@@ -0,0 +1,919 @@
+-- GHDL Run Time (GRT) - signals management.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+with Ada.Unchecked_Conversion;
+with Grt.Table;
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+limited with Grt.Processes;
+pragma Elaborate_All (Grt.Table);
+
+package Grt.Signals is
+ pragma Suppress (All_Checks);
+
+ -- Kind of transaction.
+ type Transaction_Kind is
+ (
+ -- Normal transaction, with a value.
+ Trans_Value,
+ -- Normal transaction, with a pointer to a value (direct assignment).
+ Trans_Direct,
+ -- Null transaction.
+ Trans_Null,
+ -- Like a normal transaction, but without a value due to check error.
+ Trans_Error
+ );
+
+ type Transaction;
+ type Transaction_Acc is access Transaction;
+ type Transaction (Kind : Transaction_Kind) is record
+ -- Line for error. Put here to compact the record.
+ Line : Ghdl_I32;
+
+ Next : Transaction_Acc;
+ Time : Std_Time;
+ case Kind is
+ when Trans_Value =>
+ Val : Value_Union;
+ when Trans_Direct =>
+ Val_Ptr : Ghdl_Value_Ptr;
+ when Trans_Null =>
+ null;
+ when Trans_Error =>
+ -- Filename for error.
+ File : Ghdl_C_String;
+ end case;
+ end record;
+
+ type Process_Acc is access Grt.Processes.Process_Type;
+
+ -- A driver is bound to a process (PROC) and contains a list of
+ -- transactions.
+ type Driver_Type is record
+ First_Trans : Transaction_Acc;
+ Last_Trans : Transaction_Acc;
+ Proc : Process_Acc;
+ end record;
+
+ type Driver_Acc is access all Driver_Type;
+ type Driver_Fat_Array is array (Ghdl_Index_Type) of aliased Driver_Type;
+ type Driver_Arr_Ptr is access Driver_Fat_Array;
+
+ -- Function access type used to evaluate the guard expression.
+ type Guard_Func_Acc is access function (This : System.Address)
+ return Ghdl_B1;
+ pragma Convention (C, Guard_Func_Acc);
+
+ -- Simply linked list of processes to be resumed in case of events.
+
+ type Ghdl_Signal;
+ type Ghdl_Signal_Ptr is access Ghdl_Signal;
+
+ function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Ghdl_Signal_Ptr);
+
+ type Signal_Fat_Array is array (Ghdl_Index_Type) of Ghdl_Signal_Ptr;
+ type Signal_Arr_Ptr is access Signal_Fat_Array;
+
+ function To_Signal_Arr_Ptr is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Signal_Arr_Ptr);
+
+ -- List of processes to wake-up in case of event on the signal.
+ type Action_List;
+ type Action_List_Acc is access Action_List;
+
+ type Action_List (Dynamic : Boolean) is record
+ -- Next action for the current signal.
+ Next : Action_List_Acc;
+
+ -- Process to wake-up.
+ Proc : Process_Acc;
+
+ case Dynamic is
+ when True =>
+ -- For a non-sensitized process.
+ -- Previous action (to speed-up remove from the chain).
+ Prev : Action_List_Acc;
+
+ Sig : Ghdl_Signal_Ptr;
+
+ -- Chain of signals for the process.
+ Chain : Action_List_Acc;
+ when False =>
+ null;
+ end case;
+ end record;
+
+ -- Resolution function.
+ -- There is a wrapper around resolution functions to simplify the call
+ -- from GRT.
+ -- INSTANCE is the opaque parameter given when the resolver is
+ -- registers (RESOLV_INST).
+ -- VAL is the signal (which may be composite).
+ -- BOOL_VEC is an array of NBR_DRV booleans (bytes) and indicates
+ -- non-null drivers. There are VEC_LEN non-null drivers. So the number
+ -- of values is VEC_LEN + NBR_PORTS. This number of values is the length
+ -- of the array for the resolution function.
+ type Resolver_Acc is access procedure
+ (Instance : System.Address;
+ Val : System.Address;
+ Bool_Vec : System.Address;
+ Vec_Len : Ghdl_Index_Type;
+ Nbr_Drv : Ghdl_Index_Type;
+ Nbr_Ports : Ghdl_Index_Type);
+
+ -- On some platforms, GNAT use a descriptor (instead of a trampoline) for
+ -- nested subprograms. This descriptor contains the address of the
+ -- subprogram and the address of the chain. An unaligned pointer to this
+ -- descriptor (address + 1) is then used for 'Access, and every indirect
+ -- call check for unaligned address.
+ --
+ -- Disable this feature (as a resolver is never a nested subprogram), so
+ -- code generated by ghdl is compatible with ghdl runtimes built with
+ -- gnat.
+ pragma Convention (C, Resolver_Acc);
+
+ -- How to compute resolved signal.
+ type Resolved_Signal_Type is record
+ Resolv_Proc : Resolver_Acc;
+ Resolv_Inst : System.Address;
+ Resolv_Ptr : System.Address;
+ Sig_Range : Sig_Table_Range;
+ Disconnect_Time : Std_Time;
+ end record;
+
+ type Resolved_Signal_Acc is access Resolved_Signal_Type;
+
+ type Conversion_Func_Acc is access procedure (Instance : System.Address);
+ pragma Convention (C, Conversion_Func_Acc);
+
+ function To_Conversion_Func_Acc is new Ada.Unchecked_Conversion
+ (Source => System.Address, Target => Conversion_Func_Acc);
+
+ -- Signal conversion data.
+ type Sig_Conversion_Type is record
+ -- Function which performs the conversion.
+ Func : System.Address;
+ Instance : System.Address;
+
+ Src : Sig_Table_Range;
+ Dest : Sig_Table_Range;
+ end record;
+ type Sig_Conversion_Acc is access Sig_Conversion_Type;
+
+ type Forward_Build_Type is record
+ Src : Ghdl_Signal_Ptr;
+ Targ : Ghdl_Signal_Ptr;
+ end record;
+ type Forward_Build_Acc is access Forward_Build_Type;
+
+ -- Used to order the signals for the propagation of signals values.
+ type Propag_Order_Flag is
+ (
+ -- The signal was not yet ordered.
+ Propag_None,
+ -- The signal is being ordered for driving value.
+ -- This stage is used to catch loop (which can not occur).
+ Propag_Being_Driving,
+ -- The signal has been ordered for driving value.
+ Propag_Driving,
+ -- The signal is being ordered for effective value.
+ Propag_Being_Effective,
+ -- The signal has completly been ordered.
+ Propag_Done);
+
+ -- Each signal belongs to a signal_net.
+ -- Signals on the same net must be updated in order.
+ -- Signals on different nets have no direct relation-ship, and thus may
+ -- be updated without order.
+ -- Net NO_SIGNAL_NET is special: it groups all lonely signals.
+ type Signal_Net_Type is new Integer;
+ No_Signal_Net : constant Signal_Net_Type := 0;
+ Net_One_Driver : constant Signal_Net_Type := -1;
+ Net_One_Direct : constant Signal_Net_Type := -2;
+ Net_One_Resolved : constant Signal_Net_Type := -3;
+
+ -- Flush the list of active signals.
+ procedure Flush_Active_List;
+
+ type Ghdl_Signal_Data (Mode_Sig : Mode_Signal_Type := Mode_Signal)
+ is record
+ case Mode_Sig is
+ when Mode_Signal_User =>
+ Nbr_Drivers : Ghdl_Index_Type;
+ Drivers : Driver_Arr_Ptr;
+
+ -- Signal which defines the effective value of this signal,
+ -- if any.
+ Effective : Ghdl_Signal_Ptr;
+
+ -- Null if not resolved.
+ Resolv : Resolved_Signal_Acc;
+
+ when Mode_Conv_In
+ | Mode_Conv_Out =>
+ -- Conversion paramaters for conv_in, conv_out.
+ Conv : Sig_Conversion_Acc;
+
+ when Mode_Stable
+ | Mode_Quiet
+ | Mode_Delayed =>
+ -- Time parameter for 'stable, 'quiet or 'delayed
+ Time : Std_Time;
+ Attr_Trans : Transaction_Acc;
+
+ when Mode_Guard =>
+ -- Guard function and instance used to compute the
+ -- guard expression.
+ Guard_Func : Guard_Func_Acc;
+ Guard_Instance : System.Address;
+
+ when Mode_Transaction
+ | Mode_End =>
+ null;
+ end case;
+ end record;
+ pragma Suppress (Discriminant_Check, On => Ghdl_Signal_Data);
+
+ type Ghdl_Signal_Flags is record
+ -- Status of the ordering.
+ Propag : Propag_Order_Flag;
+
+ -- If set, the signal is dumped in a GHW file.
+ Is_Dumped : Boolean;
+
+ -- Set when an event occured.
+ -- Only reset by GHW file dumper.
+ Cyc_Event : Boolean;
+
+ -- Set if the signal has already been visited. When outside of the
+ -- algorithm that use it, it must be cleared.
+ Seen : Boolean;
+ end record;
+ pragma Pack (Ghdl_Signal_Flags);
+
+ type Ghdl_Signal is record
+ -- Fields known by the compilers.
+ Value : Value_Union;
+ Driving_Value : Value_Union;
+ Last_Value : Value_Union;
+ Last_Event : Std_Time;
+ Last_Active : Std_Time;
+
+ Event : Boolean;
+ Active : Boolean;
+ -- If set, the activity of the signal is required by the user.
+ Has_Active : Boolean;
+
+ -- Internal fields.
+ -- NOTE: keep above fields (components) in sync with translation.
+
+ -- If set, the signal has an active direct driver.
+ Is_Direct_Active : Boolean;
+
+ -- Kind of the signal (none, bus or register).
+ Sig_Kind : Kind_Signal_Type;
+
+ -- Values mode of this signal.
+ Mode : Mode_Type;
+
+ -- Misc flags.
+ Flags : Ghdl_Signal_Flags;
+
+ -- Net of the signal.
+ Net : Signal_Net_Type;
+
+ -- Chain of signals that will be active in the next delta-cycle.
+ -- (Also used to build nets).
+ Link : Ghdl_Signal_Ptr;
+
+ -- Chain of signals whose active flag was set. Used to clear the active
+ -- flag at the end of the delta cycle.
+ Alink : Ghdl_Signal_Ptr;
+
+ -- Chain of signals that have a projected waveform in the real future.
+ Flink : Ghdl_Signal_Ptr;
+
+ -- List of processes to resume when there is an event on
+ -- this signal.
+ Event_List : Action_List_Acc;
+
+ -- Path of the signal (with its name) in the design hierarchy.
+ -- Used to get the type of the signal.
+ Rti : Ghdl_Rtin_Object_Acc;
+
+ -- For user signals: the sources of a signals are drivers
+ -- and connected ports.
+ -- For implicit signals: PORTS is used as dependence list.
+ Nbr_Ports : Ghdl_Index_Type;
+ Ports : Signal_Arr_Ptr;
+
+ -- Mode of the signal (in, out ...)
+ --Mode_Signal : Mode_Signal_Type;
+ S : Ghdl_Signal_Data;
+ end record;
+
+ -- Each simple signal declared can be accessed by SIG_TABLE.
+ package Sig_Table is new Grt.Table
+ (Table_Component_Type => Ghdl_Signal_Ptr,
+ Table_Index_Type => Sig_Table_Index,
+ Table_Low_Bound => 0,
+ Table_Initial => 128);
+
+ -- Return the next time at which a driver becomes active.
+ function Find_Next_Time return Std_Time;
+
+ -- Elementary propagation computation.
+ -- See LRM 12.6.2 and 12.6.3
+ type Propagation_Kind_Type is
+ (
+ -- How to compute driving value:
+ -- Default value.
+ Drv_Error,
+
+ -- One source, a driver and not resolved:
+ -- the driving value is the driver.
+ Drv_One_Driver,
+
+ -- Same as previous, and the effective value is the driving value.
+ Eff_One_Driver,
+
+ -- One source, a port and not resolved:
+ -- the driving value is the driving value of the port.
+ -- Dependence.
+ Drv_One_Port,
+
+ -- Same as previous, and the effective value is the driving value.
+ Eff_One_Port,
+
+ -- Several sources or resolved:
+ -- signal is not composite.
+ Drv_One_Resolved,
+ Eff_One_Resolved,
+
+ -- Use the resolution function, signal is composite.
+ Drv_Multiple,
+
+ -- Same as previous, but the effective value is the previous value.
+ Eff_Multiple,
+
+ -- The effective value is the actual associated.
+ Eff_Actual,
+
+ -- Sig must be updated but does not belong to the same net.
+ Imp_Forward,
+ Imp_Forward_Build,
+
+ -- Implicit guard signal.
+ -- Its value must be evaluated after the effective value of its
+ -- dependences.
+ Imp_Guard,
+
+ -- Implicit stable.
+ -- Its value must be evaluated after the effective value of its
+ -- dependences.
+ Imp_Stable,
+
+ -- Implicit quiet.
+ -- Its value must be evaluated after the driving value of its
+ -- dependences.
+ Imp_Quiet,
+
+ -- Implicit transaction.
+ -- Its value must be evaluated after the driving value of its
+ -- dependences.
+ Imp_Transaction,
+
+ -- Implicit delayed
+ -- Its value must be evaluated after the driving value of its
+ -- dependences.
+ Imp_Delayed,
+
+ -- in_conversion.
+ -- Pseudo-signal which is set by conversion function.
+ In_Conversion,
+ Out_Conversion,
+
+ -- End of propagation.
+ Prop_End
+ );
+
+ type Propagation_Type (Kind : Propagation_Kind_Type := Drv_Error) is record
+ case Kind is
+ when Drv_Error =>
+ null;
+ when Drv_One_Driver
+ | Eff_One_Driver
+ | Drv_One_Port
+ | Eff_One_Port
+ | Imp_Forward
+ | Imp_Guard
+ | Imp_Quiet
+ | Imp_Transaction
+ | Imp_Stable
+ | Imp_Delayed
+ | Eff_Actual
+ | Eff_One_Resolved
+ | Drv_One_Resolved =>
+ Sig : Ghdl_Signal_Ptr;
+ when Drv_Multiple
+ | Eff_Multiple =>
+ Resolv : Resolved_Signal_Acc;
+ when In_Conversion
+ | Out_Conversion =>
+ Conv : Sig_Conversion_Acc;
+ when Imp_Forward_Build =>
+ Forward : Forward_Build_Acc;
+ when Prop_End =>
+ Updated : Boolean;
+ end case;
+ end record;
+
+ package Propagation is new Grt.Table
+ (Table_Component_Type => Propagation_Type,
+ Table_Index_Type => Signal_Net_Type,
+ Table_Low_Bound => 1,
+ Table_Initial => 128);
+
+ -- Get the signal index of PTR.
+ function Signal_Ptr_To_Index (Ptr : Ghdl_Signal_Ptr) return Sig_Table_Index;
+
+ -- Compute propagation order of signals.
+ procedure Order_All_Signals;
+
+ -- Initialize the package (mainly the lists).
+ procedure Init;
+
+ -- Initialize all signals.
+ procedure Init_Signals;
+
+ -- Update signals.
+ procedure Update_Signals;
+
+ -- Set the effective value of signal SIG to VAL.
+ -- If the value is different from the previous one, resume processes.
+ procedure Set_Effective_Value (Sig : Ghdl_Signal_Ptr; Val : Value_Union);
+
+ -- Add PROC in the list of processes to be resumed in case of event on
+ -- SIG.
+ procedure Resume_Process_If_Event
+ (Sig : Ghdl_Signal_Ptr; Proc : Process_Acc);
+
+ -- Creating a signal:
+ -- 1a) call Ghdl_Signal_Name_Rti (CTXT and ADDR are unused) to register
+ -- the RTI for the whole signal (in particular the mode and the
+ -- has_active flag)
+ -- or
+ -- 1b) call Ghdl_Signal_Set_Mode to register the mode and the has_active
+ -- flag. In that case, the signal has no name.
+ --
+ -- 2) call Ghdl_Create_Signal_XXX for each non-composite element
+
+ procedure Ghdl_Signal_Name_Rti (Sig : Ghdl_Rti_Access;
+ Ctxt : Ghdl_Rti_Access;
+ Addr : System.Address);
+
+ procedure Ghdl_Signal_Set_Mode (Mode : Mode_Signal_Type;
+ Kind : Kind_Signal_Type;
+ Has_Active : Boolean);
+
+ -- FIXME: document.
+ -- Merge RTI with SIG: adjust the has_active flag of SIG according to RTI.
+ procedure Ghdl_Signal_Merge_Rti (Sig : Ghdl_Signal_Ptr;
+ Rti : Ghdl_Rti_Access);
+
+ -- Assigning a waveform to a signal:
+ --
+ -- For simple waveform (sig <= val), the short form can be used:
+ -- Ghdl_Signal_Simple_Assign_XX (Sig, Val);
+ -- For all other forms
+ -- SIG <= reject R inertial V1 after T1, V2 after T2, ...:
+ -- Ghdl_Signal_Start_Assign_XX (SIG, R, V1, T1);
+ -- Ghdl_Signal_Next_Assign_XX (SIG, V2, T2);
+ -- ...
+ -- If the delay mechanism is transport, they R = 0,
+ -- if there is no rejection time, the mechanism is internal and R = T1.
+
+ -- Performs some internal checks on signals (transaction order).
+ -- Internal_error is called in case of error.
+ procedure Ghdl_Signal_Internal_Checks;
+
+ procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32);
+ procedure Ghdl_Signal_Start_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ After : Std_Time;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32);
+ procedure Ghdl_Signal_Next_Assign_Error (Sign : Ghdl_Signal_Ptr;
+ After : Std_Time;
+ File : Ghdl_C_String;
+ Line : Ghdl_I32);
+
+ procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr);
+
+ procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr;
+ Time : Std_Time);
+
+ procedure Ghdl_Signal_Disconnect (Sign : Ghdl_Signal_Ptr);
+
+ procedure Ghdl_Signal_Start_Assign_Null (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ After : Std_Time);
+
+ function Ghdl_Signal_Driving (Sig : Ghdl_Signal_Ptr) return Ghdl_B1;
+
+ function Ghdl_Create_Signal_B1 (Init_Val : Ghdl_B1;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_B1 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_B1);
+ procedure Ghdl_Signal_Associate_B1 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_B1);
+ procedure Ghdl_Signal_Simple_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_B1);
+ procedure Ghdl_Signal_Start_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_B1;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_B1 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_B1;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_B1;
+
+ function Ghdl_Create_Signal_E8 (Init_Val : Ghdl_E8;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_E8 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E8);
+ procedure Ghdl_Signal_Associate_E8 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E8);
+ procedure Ghdl_Signal_Simple_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E8);
+ procedure Ghdl_Signal_Start_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_E8;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_E8 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E8;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_E8;
+
+ function Ghdl_Create_Signal_E32 (Init_Val : Ghdl_E32;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_E32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E32);
+ procedure Ghdl_Signal_Associate_E32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E32);
+ procedure Ghdl_Signal_Simple_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E32);
+ procedure Ghdl_Signal_Start_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_E32;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_E32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_E32;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_E32 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_E32;
+
+ function Ghdl_Create_Signal_I32 (Init_Val : Ghdl_I32;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_I32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I32);
+ procedure Ghdl_Signal_Associate_I32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I32);
+ procedure Ghdl_Signal_Simple_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I32);
+ procedure Ghdl_Signal_Start_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_I32;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_I32 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I32;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_I32 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_I32;
+
+ function Ghdl_Create_Signal_I64 (Init_Val : Ghdl_I64;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_I64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I64);
+ procedure Ghdl_Signal_Associate_I64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I64);
+ procedure Ghdl_Signal_Simple_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I64);
+ procedure Ghdl_Signal_Start_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_I64;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_I64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_I64;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_I64 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_I64;
+
+ function Ghdl_Create_Signal_F64 (Init_Val : Ghdl_F64;
+ Resolv_Func : Resolver_Acc;
+ Resolv_Inst : System.Address)
+ return Ghdl_Signal_Ptr;
+ procedure Ghdl_Signal_Init_F64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_F64);
+ procedure Ghdl_Signal_Associate_F64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_F64);
+ procedure Ghdl_Signal_Simple_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_F64);
+ procedure Ghdl_Signal_Start_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Rej : Std_Time;
+ Val : Ghdl_F64;
+ After : Std_Time);
+ procedure Ghdl_Signal_Next_Assign_F64 (Sign : Ghdl_Signal_Ptr;
+ Val : Ghdl_F64;
+ After : Std_Time);
+ function Ghdl_Signal_Driving_Value_F64 (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_F64;
+
+ -- Add a driver to SIGN for the current process.
+ procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr);
+
+ -- Add a direct driver for the current process. This is an optimization
+ -- that could be used when a driver has no projected waveforms.
+ --
+ -- Assignment using direct driver:
+ -- * the driver value is set
+ -- * put the signal on the ghdl_signal_active_chain, if the signal will
+ -- be active and if not already on the chain.
+ procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr;
+ Drv : Ghdl_Value_Ptr);
+
+ -- Used for connexions:
+ -- SRC is a source for TARG.
+ procedure Ghdl_Signal_Add_Source (Targ : Ghdl_Signal_Ptr;
+ Src : Ghdl_Signal_Ptr);
+
+ -- The effective value of TARG is the effective value of SRC.
+ procedure Ghdl_Signal_Effective_Value (Targ : Ghdl_Signal_Ptr;
+ Src : Ghdl_Signal_Ptr);
+
+ -- Conversions. In order to do conversion from A to B, an intermediate
+ -- signal T must be created. The flow is A -> T -> B.
+ -- The link from A -> T is a conversion, added by one of the two
+ -- following procedures. The type of A and T is different.
+ -- The link from T -> B is a normal connection: either an effective
+ -- one (for in conversion) or a source (for out conversion).
+
+ -- Add an in conversion (from SRC to DEST using function FUNC).
+ -- The effective value can be read and writen directly.
+ procedure Ghdl_Signal_In_Conversion (Func : System.Address;
+ Instance : System.Address;
+ Src : Ghdl_Signal_Ptr;
+ Src_Len : Ghdl_Index_Type;
+ Dst : Ghdl_Signal_Ptr;
+ Dst_Len : Ghdl_Index_Type);
+
+ -- Add an out conversion.
+ -- The driving value can be read and writen directly.
+ procedure Ghdl_Signal_Out_Conversion (Func : System.Address;
+ Instance : System.Address;
+ Src : Ghdl_Signal_Ptr;
+ Src_Len : Ghdl_Index_Type;
+ Dst : Ghdl_Signal_Ptr;
+ Dst_Len : Ghdl_Index_Type);
+
+ -- Mark the next (and not yet created) NBR_SIG signals as resolved.
+ procedure Ghdl_Signal_Create_Resolution (Proc : Resolver_Acc;
+ Instance : System.Address;
+ Sig : System.Address;
+ Nbr_Sig : Ghdl_Index_Type);
+
+ -- Create a new 'stable (VAL) signal. The prefixes are set by
+ -- ghdl_signal_attribute_register_prefix.
+ function Ghdl_Create_Stable_Signal (Val : Std_Time) return Ghdl_Signal_Ptr;
+ -- Create a new 'quiet (VAL) signal. The prefixes are set by
+ -- ghdl_signal_attribute_register_prefix.
+ function Ghdl_Create_Quiet_Signal (Val : Std_Time) return Ghdl_Signal_Ptr;
+ -- Create a new 'transaction signal. The prefixes are set by
+ -- ghdl_signal_attribute_register_prefix.
+ function Ghdl_Create_Transaction_Signal return Ghdl_Signal_Ptr;
+
+ -- Create a new SIG'delayed (VAL) signal.
+ function Ghdl_Create_Delayed_Signal (Sig : Ghdl_Signal_Ptr; Val : Std_Time)
+ return Ghdl_Signal_Ptr;
+
+ -- Add SIG in the set of prefix for the last created signal.
+ procedure Ghdl_Signal_Attribute_Register_Prefix (Sig : Ghdl_Signal_Ptr);
+
+ -- Create a new implicitly defined GUARD signal.
+ function Ghdl_Signal_Create_Guard (This : System.Address;
+ Proc : Guard_Func_Acc)
+ return Ghdl_Signal_Ptr;
+
+ -- Add SIG to the list of referenced signals that appear in the guard
+ -- expression.
+ procedure Ghdl_Signal_Guard_Dependence (Sig : Ghdl_Signal_Ptr);
+
+ -- Return number of ports/drivers.
+ function Ghdl_Signal_Get_Nbr_Ports (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_Index_Type;
+ function Ghdl_Signal_Get_Nbr_Drivers (Sig : Ghdl_Signal_Ptr)
+ return Ghdl_Index_Type;
+
+ -- Read a source (port or driver) from a signal. This is used by
+ -- resolution functions.
+ function Ghdl_Signal_Read_Port
+ (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type)
+ return Ghdl_Value_Ptr;
+ function Ghdl_Signal_Read_Driver
+ (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type)
+ return Ghdl_Value_Ptr;
+
+ Ghdl_Signal_Active_Chain : aliased Ghdl_Signal_Ptr;
+
+ -- Statistics.
+ Nbr_Active : Ghdl_I32;
+ Nbr_Events: Ghdl_I32;
+ function Get_Nbr_Future return Ghdl_I32;
+private
+ pragma Export (C, Ghdl_Signal_Name_Rti,
+ "__ghdl_signal_name_rti");
+ pragma Export (C, Ghdl_Signal_Merge_Rti,
+ "__ghdl_signal_merge_rti");
+
+ pragma Export (C, Ghdl_Signal_Simple_Assign_Error,
+ "__ghdl_signal_simple_assign_error");
+ pragma Export (C, Ghdl_Signal_Start_Assign_Error,
+ "__ghdl_signal_start_assign_error");
+ pragma Export (C, Ghdl_Signal_Next_Assign_Error,
+ "__ghdl_signal_next_assign_error");
+
+ pragma Export (C, Ghdl_Signal_Start_Assign_Null,
+ "__ghdl_signal_start_assign_null");
+
+ pragma Export (C, Ghdl_Signal_Direct_Assign,
+ "__ghdl_signal_direct_assign");
+
+ pragma Export (C, Ghdl_Signal_Set_Disconnect,
+ "__ghdl_signal_set_disconnect");
+ pragma Export (C, Ghdl_Signal_Disconnect,
+ "__ghdl_signal_disconnect");
+
+ pragma Export (Ada, Ghdl_Signal_Driving,
+ "__ghdl_signal_driving");
+
+ pragma Export (Ada, Ghdl_Create_Signal_B1,
+ "__ghdl_create_signal_b1");
+ pragma Export (Ada, Ghdl_Signal_Init_B1,
+ "__ghdl_signal_init_b1");
+ pragma Export (Ada, Ghdl_Signal_Associate_B1,
+ "__ghdl_signal_associate_b1");
+ pragma Export (Ada, Ghdl_Signal_Simple_Assign_B1,
+ "__ghdl_signal_simple_assign_b1");
+ pragma Export (Ada, Ghdl_Signal_Start_Assign_B1,
+ "__ghdl_signal_start_assign_b1");
+ pragma Export (Ada, Ghdl_Signal_Next_Assign_B1,
+ "__ghdl_signal_next_assign_b1");
+ pragma Export (Ada, Ghdl_Signal_Driving_Value_B1,
+ "__ghdl_signal_driving_value_b1");
+
+ pragma Export (C, Ghdl_Create_Signal_E8,
+ "__ghdl_create_signal_e8");
+ pragma Export (C, Ghdl_Signal_Init_E8,
+ "__ghdl_signal_init_e8");
+ pragma Export (C, Ghdl_Signal_Associate_E8,
+ "__ghdl_signal_associate_e8");
+ pragma Export (C, Ghdl_Signal_Simple_Assign_E8,
+ "__ghdl_signal_simple_assign_e8");
+ pragma Export (C, Ghdl_Signal_Start_Assign_E8,
+ "__ghdl_signal_start_assign_e8");
+ pragma Export (C, Ghdl_Signal_Next_Assign_E8,
+ "__ghdl_signal_next_assign_e8");
+ pragma Export (C, Ghdl_Signal_Driving_Value_E8,
+ "__ghdl_signal_driving_value_e8");
+
+ pragma Export (C, Ghdl_Create_Signal_E32,
+ "__ghdl_create_signal_e32");
+ pragma Export (C, Ghdl_Signal_Init_E32,
+ "__ghdl_signal_init_e32");
+ pragma Export (C, Ghdl_Signal_Associate_E32,
+ "__ghdl_signal_associate_e32");
+ pragma Export (C, Ghdl_Signal_Simple_Assign_E32,
+ "__ghdl_signal_simple_assign_e32");
+ pragma Export (C, Ghdl_Signal_Start_Assign_E32,
+ "__ghdl_signal_start_assign_e32");
+ pragma Export (C, Ghdl_Signal_Next_Assign_E32,
+ "__ghdl_signal_next_assign_e32");
+ pragma Export (C, Ghdl_Signal_Driving_Value_E32,
+ "__ghdl_signal_driving_value_e32");
+
+ pragma Export (C, Ghdl_Create_Signal_I32,
+ "__ghdl_create_signal_i32");
+ pragma Export (C, Ghdl_Signal_Init_I32,
+ "__ghdl_signal_init_i32");
+ pragma Export (C, Ghdl_Signal_Associate_I32,
+ "__ghdl_signal_associate_i32");
+ pragma Export (C, Ghdl_Signal_Simple_Assign_I32,
+ "__ghdl_signal_simple_assign_i32");
+ pragma Export (C, Ghdl_Signal_Start_Assign_I32,
+ "__ghdl_signal_start_assign_i32");
+ pragma Export (C, Ghdl_Signal_Next_Assign_I32,
+ "__ghdl_signal_next_assign_i32");
+ pragma Export (C, Ghdl_Signal_Driving_Value_I32,
+ "__ghdl_signal_driving_value_i32");
+
+ pragma Export (C, Ghdl_Create_Signal_I64,
+ "__ghdl_create_signal_i64");
+ pragma Export (C, Ghdl_Signal_Init_I64,
+ "__ghdl_signal_init_i64");
+ pragma Export (C, Ghdl_Signal_Associate_I64,
+ "__ghdl_signal_associate_i64");
+ pragma Export (C, Ghdl_Signal_Simple_Assign_I64,
+ "__ghdl_signal_simple_assign_i64");
+ pragma Export (C, Ghdl_Signal_Start_Assign_I64,
+ "__ghdl_signal_start_assign_i64");
+ pragma Export (C, Ghdl_Signal_Next_Assign_I64,
+ "__ghdl_signal_next_assign_i64");
+ pragma Export (C, Ghdl_Signal_Driving_Value_I64,
+ "__ghdl_signal_driving_value_i64");
+
+ pragma Export (C, Ghdl_Create_Signal_F64,
+ "__ghdl_create_signal_f64");
+ pragma Export (C, Ghdl_Signal_Init_F64,
+ "__ghdl_signal_init_f64");
+ pragma Export (C, Ghdl_Signal_Associate_F64,
+ "__ghdl_signal_associate_f64");
+ pragma Export (C, Ghdl_Signal_Simple_Assign_F64,
+ "__ghdl_signal_simple_assign_f64");
+ pragma Export (C, Ghdl_Signal_Start_Assign_F64,
+ "__ghdl_signal_start_assign_f64");
+ pragma Export (C, Ghdl_Signal_Next_Assign_F64,
+ "__ghdl_signal_next_assign_f64");
+ pragma Export (C, Ghdl_Signal_Driving_Value_F64,
+ "__ghdl_signal_driving_value_f64");
+
+ pragma Export (C, Ghdl_Process_Add_Driver,
+ "__ghdl_process_add_driver");
+ pragma Export (C, Ghdl_Signal_Add_Direct_Driver,
+ "__ghdl_signal_add_direct_driver");
+
+ pragma Export (C, Ghdl_Signal_Add_Source,
+ "__ghdl_signal_add_source");
+ pragma Export (C, Ghdl_Signal_Effective_Value,
+ "__ghdl_signal_effective_value");
+ pragma Export (C, Ghdl_Signal_In_Conversion,
+ "__ghdl_signal_in_conversion");
+ pragma Export (C, Ghdl_Signal_Out_Conversion,
+ "__ghdl_signal_out_conversion");
+
+ pragma Export (C, Ghdl_Signal_Create_Resolution,
+ "__ghdl_signal_create_resolution");
+
+ pragma Export (C, Ghdl_Create_Stable_Signal,
+ "__ghdl_create_stable_signal");
+ pragma Export (C, Ghdl_Create_Quiet_Signal,
+ "__ghdl_create_quiet_signal");
+ pragma Export (C, Ghdl_Create_Transaction_Signal,
+ "__ghdl_create_transaction_signal");
+ pragma Export (C, Ghdl_Signal_Attribute_Register_Prefix,
+ "__ghdl_signal_attribute_register_prefix");
+ pragma Export (C, Ghdl_Create_Delayed_Signal,
+ "__ghdl_create_delayed_signal");
+
+ pragma Export (Ada, Ghdl_Signal_Create_Guard,
+ "__ghdl_signal_create_guard");
+ pragma Export (C, Ghdl_Signal_Guard_Dependence,
+ "__ghdl_signal_guard_dependence");
+
+ pragma Export (C, Ghdl_Signal_Get_Nbr_Ports,
+ "__ghdl_signal_get_nbr_ports");
+ pragma Export (C, Ghdl_Signal_Get_Nbr_Drivers,
+ "__ghdl_signal_get_nbr_drivers");
+ pragma Export (C, Ghdl_Signal_Read_Port,
+ "__ghdl_signal_read_port");
+ pragma Export (C, Ghdl_Signal_Read_Driver,
+ "__ghdl_signal_read_driver");
+
+ pragma Export (C, Ghdl_Signal_Active_Chain,
+ "__ghdl_signal_active_chain");
+
+end Grt.Signals;
diff --git a/src/translate/grt/grt-stack2.adb b/src/translate/grt/grt-stack2.adb
new file mode 100644
index 000000000..82341d072
--- /dev/null
+++ b/src/translate/grt/grt-stack2.adb
@@ -0,0 +1,205 @@
+-- GHDL Run Time (GRT) - secondary stack.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with Grt.Errors; use Grt.Errors;
+with Grt.Stdio;
+with Grt.Astdio;
+
+package body Grt.Stack2 is
+ -- This should be storage_elements.storage_element, but I don't want to
+ -- use system.storage_elements package (not pure). Unfortunatly, this is
+ -- currently a failure (storage_elements is automagically used).
+ type Memory is array (Mark_Id range <>) of Character;
+
+ type Chunk_Type (First, Last : Mark_Id);
+ type Chunk_Acc is access all Chunk_Type;
+ type Chunk_Type (First, Last : Mark_Id) is record
+ Next : Chunk_Acc;
+ Mem : Memory (First .. Last);
+ end record;
+
+ type Stack2_Type is record
+ First_Chunk : Chunk_Acc;
+ Last_Chunk : Chunk_Acc;
+ Top : Mark_Id;
+ end record;
+ type Stack2_Acc is access all Stack2_Type;
+
+ function To_Acc is new Ada.Unchecked_Conversion
+ (Source => Stack2_Ptr, Target => Stack2_Acc);
+ function To_Addr is new Ada.Unchecked_Conversion
+ (Source => Stack2_Acc, Target => Stack2_Ptr);
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Object => Chunk_Type, Name => Chunk_Acc);
+
+ function Mark (S : Stack2_Ptr) return Mark_Id
+ is
+ S2 : Stack2_Acc;
+ begin
+ S2 := To_Acc (S);
+ return S2.Top;
+ end Mark;
+
+ procedure Release (S : Stack2_Ptr; Mark : Mark_Id)
+ is
+ S2 : Stack2_Acc;
+ begin
+ S2 := To_Acc (S);
+ S2.Top := Mark;
+ end Release;
+
+ function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type)
+ return System.Address
+ is
+ pragma Suppress (All_Checks);
+
+ S2 : Stack2_Acc;
+ Chunk : Chunk_Acc;
+ N_Chunk : Chunk_Acc;
+
+ Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment);
+ Max_Size : constant Mark_Id :=
+ ((Mark_Id (Size) + Max_Align - 1) / Max_Align) * Max_Align;
+
+ Res : System.Address;
+ begin
+ S2 := To_Acc (S);
+
+ -- Find the chunk to which S2.TOP belong.
+ Chunk := S2.First_Chunk;
+ loop
+ exit when S2.Top >= Chunk.First and S2.Top <= Chunk.Last;
+ Chunk := Chunk.Next;
+ exit when Chunk = null;
+ end loop;
+
+ if Chunk /= null then
+ -- If there is enough place in it, allocate from the chunk.
+ if S2.Top + Max_Size <= Chunk.Last then
+ Res := Chunk.Mem (S2.Top)'Address;
+ S2.Top := S2.Top + Max_Size;
+ return Res;
+ end if;
+
+ -- If there is not enough place in it:
+ -- find a chunk which has enough room, deallocate skipped chunk.
+ loop
+ N_Chunk := Chunk.Next;
+ exit when N_Chunk = null;
+ if N_Chunk.Last - N_Chunk.First + 1 < Max_Size then
+ -- Not enough place in this chunk.
+ Chunk.Next := N_Chunk.Next;
+ Free (N_Chunk);
+ if Chunk.Next = null then
+ S2.Last_Chunk := Chunk;
+ exit;
+ end if;
+ else
+ Res := N_Chunk.Mem (N_Chunk.First)'Address;
+ S2.Top := N_Chunk.First + Max_Size;
+ return Res;
+ end if;
+ end loop;
+ end if;
+
+ -- If not such chunk, allocate a chunk
+ S2.Top := S2.Last_Chunk.Last + 1;
+ Chunk := new Chunk_Type (First => S2.Top,
+ Last => S2.Top + Max_Size - 1);
+ Chunk.Next := null;
+ S2.Last_Chunk.Next := Chunk;
+ S2.Last_Chunk := Chunk;
+ S2.Top := Chunk.Last + 1;
+ return Chunk.Mem (Chunk.First)'Address;
+ end Allocate;
+
+ function Create return Stack2_Ptr is
+ Res : Stack2_Acc;
+ Chunk : Chunk_Acc;
+ begin
+ Chunk := new Chunk_Type (First => 1, Last => 8 * 1024);
+ Chunk.Next := null;
+ Res := new Stack2_Type'(First_Chunk => Chunk,
+ Last_Chunk => Chunk,
+ Top => 1);
+ return To_Addr (Res);
+ end Create;
+
+ procedure Check_Empty (S : Stack2_Ptr)
+ is
+ S2 : Stack2_Acc;
+ begin
+ S2 := To_Acc (S);
+ if S2 /= null and then S2.Top /= S2.First_Chunk.First then
+ Internal_Error ("stack2.check_empty: stack is not empty");
+ end if;
+ end Check_Empty;
+
+ -- May be used to debug.
+ procedure Dump_Stack2 (S : Stack2_Ptr);
+ pragma Unreferenced (Dump_Stack2);
+
+ procedure Dump_Stack2 (S : Stack2_Ptr)
+ is
+ use Grt.Astdio;
+ use Grt.Stdio;
+ use System;
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Chunk_Acc, Target => Address);
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Mark_Id, Target => Address);
+ S2 : Stack2_Acc;
+ Chunk : Chunk_Acc;
+ begin
+ S2 := To_Acc (S);
+ Put ("Stack 2 at ");
+ Put (stdout, Address (S));
+ New_Line;
+ Put ("First Chunk at ");
+ Put (stdout, To_Address (S2.First_Chunk));
+ Put (", last chunk at ");
+ Put (stdout, To_Address (S2.Last_Chunk));
+ Put (", top at ");
+ Put (stdout, To_Address (S2.Top));
+ New_Line;
+ Chunk := S2.First_Chunk;
+ while Chunk /= null loop
+ Put ("Chunk ");
+ Put (stdout, To_Address (Chunk));
+ Put (": first: ");
+ Put (stdout, To_Address (Chunk.First));
+ Put (", last: ");
+ Put (stdout, To_Address (Chunk.Last));
+ Put (", len: ");
+ Put (stdout, To_Address (Chunk.Last - Chunk.First + 1));
+ Put (", next = ");
+ Put (stdout, To_Address (Chunk.Next));
+ New_Line;
+ Chunk := Chunk.Next;
+ end loop;
+ end Dump_Stack2;
+end Grt.Stack2;
diff --git a/src/translate/grt/grt-stack2.ads b/src/translate/grt/grt-stack2.ads
new file mode 100644
index 000000000..b3de6b76d
--- /dev/null
+++ b/src/translate/grt/grt-stack2.ads
@@ -0,0 +1,43 @@
+-- GHDL Run Time (GRT) - secondary stack.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+with Grt.Types; use Grt.Types;
+
+-- Secondary stack management.
+package Grt.Stack2 is
+ type Stack2_Ptr is new System.Address;
+ Null_Stack2_Ptr : constant Stack2_Ptr := Stack2_Ptr (System.Null_Address);
+
+ type Mark_Id is new Integer_Address;
+
+ function Mark (S : Stack2_Ptr) return Mark_Id;
+ procedure Release (S : Stack2_Ptr; Mark : Mark_Id);
+ function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type)
+ return System.Address;
+ function Create return Stack2_Ptr;
+
+ -- Check S is empty.
+ procedure Check_Empty (S : Stack2_Ptr);
+end Grt.Stack2;
diff --git a/src/translate/grt/grt-stacks.adb b/src/translate/grt/grt-stacks.adb
new file mode 100644
index 000000000..adb008d02
--- /dev/null
+++ b/src/translate/grt/grt-stacks.adb
@@ -0,0 +1,43 @@
+-- GHDL Run Time (GRT) - process stacks.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Stacks is
+ procedure Error_Grow_Failed is
+ begin
+ Error ("cannot grow the stack");
+ end Error_Grow_Failed;
+
+ procedure Error_Memory_Access is
+ begin
+ Error
+ ("invalid memory access (dangling accesses or stack size too small)");
+ end Error_Memory_Access;
+
+ procedure Error_Null_Access is
+ begin
+ Error ("NULL access dereferenced");
+ end Error_Null_Access;
+end Grt.Stacks;
diff --git a/src/translate/grt/grt-stacks.ads b/src/translate/grt/grt-stacks.ads
new file mode 100644
index 000000000..dd9434080
--- /dev/null
+++ b/src/translate/grt/grt-stacks.ads
@@ -0,0 +1,87 @@
+-- GHDL Run Time (GRT) - process stacks.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Ada.Unchecked_Conversion;
+
+package Grt.Stacks is
+ -- Instance is the parameter of the process procedure.
+ -- This is in fact a fully opaque type whose content is private to the
+ -- process.
+ type Instance is limited private;
+ type Instance_Acc is access all Instance;
+ pragma Convention (C, Instance_Acc);
+
+ -- A process is identified by a procedure having a single private
+ -- parameter (its instance).
+ type Proc_Acc is access procedure (Self : Instance_Acc);
+ pragma Convention (C, Proc_Acc);
+
+ function To_Address is new Ada.Unchecked_Conversion
+ (Instance_Acc, System.Address);
+
+ type Stack_Type is new Address;
+ Null_Stack : constant Stack_Type := Stack_Type (Null_Address);
+
+ -- Initialize the stacks package.
+ -- This may adjust stack sizes.
+ -- Must be called after grt.options.decode.
+ procedure Stack_Init;
+
+ -- Create a new stack, which on first execution will call FUNC with
+ -- an argument ARG.
+ function Stack_Create (Func : Proc_Acc; Arg : Instance_Acc)
+ return Stack_Type;
+
+ -- Resume stack TO and save the current context to the stack pointed by
+ -- CUR.
+ procedure Stack_Switch (To : Stack_Type; From : Stack_Type);
+
+ -- Delete stack STACK, which must not be currently executed.
+ procedure Stack_Delete (Stack : Stack_Type);
+
+ -- Error during stack handling:
+ -- Cannot grow the stack.
+ procedure Error_Grow_Failed;
+ pragma No_Return (Error_Grow_Failed);
+
+ -- Invalid memory access detected (other than dereferencing a NULL access).
+ procedure Error_Memory_Access;
+ pragma No_Return (Error_Memory_Access);
+
+ -- A NULL access is dereferenced.
+ procedure Error_Null_Access;
+ pragma No_Return (Error_Null_Access);
+private
+ type Instance is null record;
+
+ pragma Import (C, Stack_Init, "grt_stack_init");
+ pragma Import (C, Stack_Create, "grt_stack_create");
+ pragma Import (C, Stack_Switch, "grt_stack_switch");
+ pragma Import (C, Stack_Delete, "grt_stack_delete");
+
+ pragma Export (C, Error_Grow_Failed, "grt_stack_error_grow_failed");
+ pragma Export (C, Error_Memory_Access, "grt_stack_error_memory_access");
+ pragma Export (C, Error_Null_Access, "grt_stack_error_null_access");
+end Grt.Stacks;
diff --git a/src/translate/grt/grt-stats.adb b/src/translate/grt/grt-stats.adb
new file mode 100644
index 000000000..5bc046d00
--- /dev/null
+++ b/src/translate/grt/grt-stats.adb
@@ -0,0 +1,370 @@
+-- GHDL Run Time (GRT) - statistics.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Signals;
+with Grt.Processes;
+with Grt.Types; use Grt.Types;
+with Grt.Disp;
+
+package body Grt.Stats is
+ type Clock_T is new Integer;
+
+ type Time_Stats is record
+ Wall : Clock_T;
+ User : Clock_T;
+ Sys : Clock_T;
+ end record;
+
+ -- Number of CLOCK_T per second.
+ One_Second : Clock_T;
+
+
+ -- Get number of seconds per CLOCK_T.
+ function Get_Clk_Tck return Clock_T;
+ pragma Import (C, Get_Clk_Tck, "grt_get_clk_tck");
+
+ -- Get wall, user and system times.
+ -- This is a binding to times(2).
+ procedure Get_Times (Wall : Address; User : Address; Sys : Address);
+ pragma Import (C, Get_Times, "grt_get_times");
+
+ procedure Get_Stats (Stats : out Time_Stats)
+ is
+ begin
+ Get_Times (Stats.Wall'Address, Stats.User'Address, Stats.Sys'Address);
+ end Get_Stats;
+
+ function "-" (L : Time_Stats; R : Time_Stats) return Time_Stats
+ is
+ begin
+ return Time_Stats'(Wall => L.Wall - R.Wall,
+ User => L.User - R.User,
+ Sys => L.Sys - R.Sys);
+ end "-";
+
+ function "+" (L : Time_Stats; R : Time_Stats) return Time_Stats
+ is
+ begin
+ return Time_Stats'(Wall => L.Wall + R.Wall,
+ User => L.User + R.User,
+ Sys => L.Sys + R.Sys);
+ end "+";
+
+ procedure Put (Stream : FILEs; Val : Clock_T)
+ is
+ procedure Fprintf_Clock (Stream : FILEs; A, B : Clock_T);
+ pragma Import (C, Fprintf_Clock, "__ghdl_fprintf_clock");
+
+ Sec : Clock_T;
+ Ms : Clock_T;
+ begin
+ Sec := Val / One_Second;
+
+ -- Avoid overflow.
+ Ms := ((Val mod One_Second) * 1000) / One_Second;
+
+ Fprintf_Clock (Stream, Sec, Ms);
+ end Put;
+
+ procedure Put (Stream : FILEs; T : Time_Stats) is
+ begin
+ Put (Stream, "wall: ");
+ Put (Stream, T.Wall);
+ Put (Stream, " user: ");
+ Put (Stream, T.User);
+ Put (Stream, " sys: ");
+ Put (Stream, T.Sys);
+ end Put;
+
+ type Counter_Kind is (Counter_Elab, Counter_Order,
+ Counter_Process, Counter_Update,
+ Counter_Next, Counter_Resume);
+
+ type Counter_Array is array (Counter_Kind) of Time_Stats;
+ Counters : Counter_Array := (others => (0, 0, 0));
+
+ Init_Time : Time_Stats;
+ Last_Counter : Counter_Kind;
+ Last_Time : Time_Stats;
+
+-- -- Stats at origin.
+-- Start_Time : Time_Stats;
+-- End_Elab_Time : Time_Stats;
+-- End_Order_Time : Time_Stats;
+
+-- Start_Proc_Time : Time_Stats;
+-- Proc_Times : Time_Stats;
+
+-- Start_Update_Time : Time_Stats;
+-- Update_Times : Time_Stats;
+
+-- Start_Next_Time_Time : Time_Stats;
+-- Next_Time_Times : Time_Stats;
+
+-- Start_Resume_Time : Time_Stats;
+-- Resume_Times : Time_Stats;
+
+-- Running_Time : Time_Stats;
+-- Simu_Time : Time_Stats;
+
+ procedure Start_Elaboration is
+ begin
+ One_Second := Get_Clk_Tck;
+
+ Get_Stats (Init_Time);
+ Last_Time := Init_Time;
+ Last_Counter := Counter_Elab;
+ end Start_Elaboration;
+
+ procedure Change_Counter (Cnt : Counter_Kind)
+ is
+ New_Time : Time_Stats;
+ begin
+ Get_Stats (New_Time);
+ Counters (Last_Counter) := Counters (Last_Counter)
+ + (New_Time - Last_Time);
+ Last_Time := New_Time;
+ Last_Counter := Cnt;
+ end Change_Counter;
+
+ procedure Start_Order is
+ begin
+ Change_Counter (Counter_Order);
+ end Start_Order;
+
+ procedure Start_Processes is
+ begin
+ Change_Counter (Counter_Process);
+ end Start_Processes;
+
+ procedure Start_Update is
+ begin
+ Change_Counter (Counter_Update);
+ end Start_Update;
+
+ procedure Start_Next_Time is
+ begin
+ Change_Counter (Counter_Next);
+ end Start_Next_Time;
+
+ procedure Start_Resume is
+ begin
+ Change_Counter (Counter_Resume);
+ end Start_Resume;
+
+ procedure End_Simulation is
+ begin
+ Change_Counter (Last_Counter);
+ end End_Simulation;
+
+ procedure Disp_Signals_Stats
+ is
+ use Grt.Signals;
+ Nbr_No_Drivers : Ghdl_I32;
+ Nbr_Resolv : Ghdl_I32;
+ Nbr_Multi_Src : Ghdl_I32;
+ Nbr_Active : Ghdl_I32;
+ Nbr_Drivers : Ghdl_I32;
+ Nbr_Direct_Drivers : Ghdl_I32;
+
+ type Propagation_Kind_Array is array (Propagation_Kind_Type) of Ghdl_I32;
+ Propag_Count : Propagation_Kind_Array;
+
+ type Mode_Array is array (Mode_Type) of Ghdl_I32;
+ Mode_Counts : Mode_Array;
+
+ type Mode_Name_Type is array (Mode_Type) of String (1 .. 4);
+ Mode_Names : constant Mode_Name_Type := (Mode_B1 => "B1: ",
+ Mode_E8 => "E8: ",
+ Mode_E32 => "E32:",
+ Mode_I32 => "I32:",
+ Mode_I64 => "I64:",
+ Mode_F64 => "F64:");
+ begin
+ Put (stdout, "Number of simple signals: ");
+ Put_I32 (stdout, Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1));
+ New_Line;
+ Put (stdout, "Number of signals with projected wave: ");
+ Put_I32 (stdout, Get_Nbr_Future);
+ New_Line;
+
+ Nbr_No_Drivers := 0;
+ Nbr_Resolv := 0;
+ Nbr_Multi_Src := 0;
+ Nbr_Active := 0;
+ Nbr_Drivers := 0;
+ Nbr_Direct_Drivers := 0;
+ Mode_Counts := (others => 0);
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ declare
+ Sig : Ghdl_Signal_Ptr;
+ Trans : Transaction_Acc;
+ begin
+ Sig := Sig_Table.Table (I);
+ if Sig.S.Mode_Sig in Mode_Signal_User then
+ if Sig.S.Nbr_Drivers = 0 then
+ Nbr_No_Drivers := Nbr_No_Drivers + 1;
+ end if;
+ if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 1 then
+ Nbr_Multi_Src := Nbr_Multi_Src + 1;
+ end if;
+ if Sig.S.Resolv /= null then
+ Nbr_Resolv := Nbr_Resolv + 1;
+ end if;
+ Nbr_Drivers := Nbr_Drivers + Ghdl_I32 (Sig.S.Nbr_Drivers);
+ for J in 1 .. Sig.S.Nbr_Drivers loop
+ Trans := Sig.S.Drivers (J - 1).Last_Trans;
+ if Trans /= null and then Trans.Kind = Trans_Direct then
+ Nbr_Direct_Drivers := Nbr_Direct_Drivers + 1;
+ end if;
+ end loop;
+ end if;
+ Mode_Counts (Sig.Mode) := Mode_Counts (Sig.Mode) + 1;
+ if Sig.Has_Active then
+ Nbr_Active := Nbr_Active + 1;
+ end if;
+ end;
+ end loop;
+ Put (stdout, "Number of non-driven simple signals: ");
+ Put_I32 (stdout, Nbr_No_Drivers);
+ New_Line;
+ Put (stdout, "Number of resolved simple signals: ");
+ Put_I32 (stdout, Nbr_Resolv);
+ New_Line;
+ Put (stdout, "Number of multi-sourced signals: ");
+ Put_I32 (stdout, Nbr_Multi_Src);
+ New_Line;
+ Put (stdout, "Number of signals whose activity is managed: ");
+ Put_I32 (stdout, Nbr_Active);
+ New_Line;
+ Put (stdout, "Number of drivers: ");
+ Put_I32 (stdout, Nbr_Drivers);
+ New_Line;
+ Put (stdout, "Number of direct drivers: ");
+ Put_I32 (stdout, Nbr_Direct_Drivers);
+ New_Line;
+ Put (stdout, "Number of signals per mode:");
+ New_Line;
+ for I in Mode_Type loop
+ Put (stdout, " ");
+ Put (stdout, Mode_Names (I));
+ Put (stdout, " ");
+ Put_I32 (stdout, Mode_Counts (I));
+ New_Line;
+ end loop;
+ New_Line;
+
+ Propag_Count := (others => 0);
+ for I in Propagation.First .. Propagation.Last loop
+ Propag_Count (Propagation.Table (I).Kind) :=
+ Propag_Count (Propagation.Table (I).Kind) + 1;
+ end loop;
+
+ Put (stdout, "Propagation table length: ");
+ Put_I32 (stdout, Ghdl_I32 (Grt.Signals.Propagation.Last));
+ New_Line;
+ Put (stdout, "Propagation table count:");
+ New_Line;
+ for I in Propagation_Kind_Type loop
+ if Propag_Count (I) /= 0 then
+ Put (stdout, " ");
+ Grt.Disp.Disp_Propagation_Kind (I);
+ Put (stdout, ": ");
+ Put_I32 (stdout, Propag_Count (I));
+ New_Line;
+ end if;
+ end loop;
+ end Disp_Signals_Stats;
+
+ -- Disp all statistics.
+ procedure Disp_Stats
+ is
+ N : Natural;
+ begin
+ Put (stdout, "total: ");
+ Put (stdout, Last_Time - Init_Time);
+ New_Line (stdout);
+ Put (stdout, " elab: ");
+ Put (stdout, Counters (Counter_Elab));
+ New_Line (stdout);
+ Put (stdout, " internal elab: ");
+ Put (stdout, Counters (Counter_Order));
+ New_Line (stdout);
+ Put (stdout, " cycle (sum): ");
+ Put (stdout, Counters (Counter_Process) + Counters (Counter_Resume)
+ + Counters (Counter_Update) + Counters (Counter_Next));
+ New_Line (stdout);
+ Put (stdout, " processes: ");
+ Put (stdout, Counters (Counter_Process));
+ New_Line (stdout);
+ Put (stdout, " resume: ");
+ Put (stdout, Counters (Counter_Resume));
+ New_Line (stdout);
+ Put (stdout, " update: ");
+ Put (stdout, Counters (Counter_Update));
+ New_Line (stdout);
+ Put (stdout, " next compute: ");
+ Put (stdout, Counters (Counter_Next));
+ New_Line (stdout);
+
+ Disp_Signals_Stats;
+
+ Put (stdout, "Number of delta cycles: ");
+ Put_I32 (stdout, Ghdl_I32 (Processes.Nbr_Delta_Cycles));
+ New_Line;
+ Put (stdout, "Number of non-delta cycles: ");
+ Put_I32 (stdout, Ghdl_I32 (Processes.Nbr_Cycles));
+ New_Line;
+
+ Put (stdout, "Nbr of events: ");
+ Put_I32 (stdout, Signals.Nbr_Events);
+ New_Line;
+ Put (stdout, "Nbr of active: ");
+ Put_I32 (stdout, Signals.Nbr_Active);
+ New_Line;
+
+ Put (stdout, "Number of processes: ");
+ Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Processes));
+ New_Line;
+ Put (stdout, "Number of sensitized processes: ");
+ Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Sensitized_Processes));
+ New_Line;
+ Put (stdout, "Number of resumed processes: ");
+ Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Resumed_Processes));
+ New_Line;
+ Put (stdout, "Average number of resumed processes per cycle: ");
+ N := Processes.Nbr_Delta_Cycles + Processes.Nbr_Cycles;
+ if N = 0 then
+ Put (stdout, "-");
+ else
+ Put_I32 (stdout, Ghdl_I32 (Processes.Get_Nbr_Resumed_Processes / N));
+ end if;
+ New_Line;
+ end Disp_Stats;
+end Grt.Stats;
diff --git a/src/translate/grt/grt-stats.ads b/src/translate/grt/grt-stats.ads
new file mode 100644
index 000000000..6f60261af
--- /dev/null
+++ b/src/translate/grt/grt-stats.ads
@@ -0,0 +1,54 @@
+-- GHDL Run Time (GRT) - statistics.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package Grt.Stats is
+ -- Entry points to gather statistics.
+ procedure Start_Elaboration;
+ procedure Start_Order;
+
+ -- Time in user processes.
+ procedure Start_Processes;
+
+
+ -- Time in next time computation.
+ procedure Start_Next_Time;
+
+
+ -- Time in signals update.
+ procedure Start_Update;
+
+
+ -- Time in process resume
+ procedure Start_Resume;
+
+
+ procedure End_Simulation;
+
+ -- Disp all statistics.
+ procedure Disp_Stats;
+end Grt.Stats;
+
+
+
diff --git a/src/translate/grt/grt-std_logic_1164.adb b/src/translate/grt/grt-std_logic_1164.adb
new file mode 100644
index 000000000..5be308bd6
--- /dev/null
+++ b/src/translate/grt/grt-std_logic_1164.adb
@@ -0,0 +1,146 @@
+-- GHDL Run Time (GRT) std_logic_1664 subprograms.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+with Grt.Lib;
+
+package body Grt.Std_Logic_1164 is
+ Assert_DC_Msg : constant String :=
+ "STD_LOGIC_1164: '-' operand for matching ordering operator";
+
+ Assert_DC_Msg_Bound : constant Std_String_Bound :=
+ (Dim_1 => (Left => 1, Right => Assert_DC_Msg'Length, Dir => Dir_To,
+ Length => Assert_DC_Msg'Length));
+
+ Assert_DC_Msg_Str : aliased constant Std_String :=
+ (Base => To_Std_String_Basep (Assert_DC_Msg'Address),
+ Bounds => To_Std_String_Boundp (Assert_DC_Msg_Bound'Address));
+
+ Filename : constant String := "std_logic_1164.vhdl" & NUL;
+ Loc : aliased constant Ghdl_Location :=
+ (Filename => To_Ghdl_C_String (Filename'Address),
+ Line => 58,
+ Col => 3);
+
+ procedure Assert_Not_Match (V : Std_Ulogic)
+ is
+ use Grt.Lib;
+ begin
+ if V = '-' then
+ Ghdl_Ieee_Assert_Failed
+ (To_Std_String_Ptr (Assert_DC_Msg_Str'Address), Error_Severity,
+ To_Ghdl_Location_Ptr (Loc'Address));
+ end if;
+ end Assert_Not_Match;
+
+ function Ghdl_Std_Ulogic_Match_Eq (L, R : Ghdl_E8) return Ghdl_E8
+ is
+ Left : constant Std_Ulogic := Std_Ulogic'Val (L);
+ Right : constant Std_Ulogic := Std_Ulogic'Val (R);
+ begin
+ Assert_Not_Match (Left);
+ Assert_Not_Match (Right);
+ return Std_Ulogic'Pos (Match_Eq_Table (Left, Right));
+ end Ghdl_Std_Ulogic_Match_Eq;
+
+ function Ghdl_Std_Ulogic_Match_Ne (L, R : Ghdl_E8) return Ghdl_E8
+ is
+ Left : constant Std_Ulogic := Std_Ulogic'Val (L);
+ Right : constant Std_Ulogic := Std_Ulogic'Val (R);
+ begin
+ Assert_Not_Match (Left);
+ Assert_Not_Match (Right);
+ return Std_Ulogic'Pos (Not_Table (Match_Eq_Table (Left, Right)));
+ end Ghdl_Std_Ulogic_Match_Ne;
+
+ function Ghdl_Std_Ulogic_Match_Lt (L, R : Ghdl_E8) return Ghdl_E8
+ is
+ Left : constant Std_Ulogic := Std_Ulogic'Val (L);
+ Right : constant Std_Ulogic := Std_Ulogic'Val (R);
+ begin
+ Assert_Not_Match (Left);
+ Assert_Not_Match (Right);
+ return Std_Ulogic'Pos (Match_Lt_Table (Left, Right));
+ end Ghdl_Std_Ulogic_Match_Lt;
+
+ function Ghdl_Std_Ulogic_Match_Le (L, R : Ghdl_E8) return Ghdl_E8
+ is
+ Left : constant Std_Ulogic := Std_Ulogic'Val (L);
+ Right : constant Std_Ulogic := Std_Ulogic'Val (R);
+ begin
+ Assert_Not_Match (Left);
+ Assert_Not_Match (Right);
+ return Std_Ulogic'Pos (Or_Table (Match_Lt_Table (Left, Right),
+ Match_Eq_Table (Left, Right)));
+ end Ghdl_Std_Ulogic_Match_Le;
+
+ Assert_Arr_Msg : constant String :=
+ "parameters of '?=' array operator are not of the same length";
+
+ Assert_Arr_Msg_Bound : constant Std_String_Bound :=
+ (Dim_1 => (Left => 1, Right => Assert_Arr_Msg'Length, Dir => Dir_To,
+ Length => Assert_Arr_Msg'Length));
+
+ Assert_Arr_Msg_Str : aliased constant Std_String :=
+ (Base => To_Std_String_Basep (Assert_Arr_Msg'Address),
+ Bounds => To_Std_String_Boundp (Assert_Arr_Msg_Bound'Address));
+
+
+ function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr;
+ L_Len : Ghdl_Index_Type;
+ R : Ghdl_Ptr;
+ R_Len : Ghdl_Index_Type)
+ return Ghdl_I32
+ is
+ use Grt.Lib;
+ L_Arr : constant Ghdl_E8_Array_Base_Ptr :=
+ To_Ghdl_E8_Array_Base_Ptr (L);
+ R_Arr : constant Ghdl_E8_Array_Base_Ptr :=
+ To_Ghdl_E8_Array_Base_Ptr (R);
+ Res : Std_Ulogic := '1';
+ begin
+ if L_Len /= R_Len then
+ Ghdl_Ieee_Assert_Failed
+ (To_Std_String_Ptr (Assert_Arr_Msg_Str'Address), Error_Severity,
+ To_Ghdl_Location_Ptr (Loc'Address));
+ end if;
+ for I in 1 .. L_Len loop
+ Res := And_Table
+ (Res, Std_Ulogic'Val (Ghdl_Std_Ulogic_Match_Eq (L_Arr (I - 1),
+ R_Arr (I - 1))));
+ end loop;
+ return Std_Ulogic'Pos (Res);
+ end Ghdl_Std_Ulogic_Array_Match_Eq;
+
+ function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr;
+ L_Len : Ghdl_Index_Type;
+ R : Ghdl_Ptr;
+ R_Len : Ghdl_Index_Type)
+ return Ghdl_I32 is
+ begin
+ return Std_Ulogic'Pos
+ (Not_Table (Std_Ulogic'Val
+ (Ghdl_Std_Ulogic_Array_Match_Eq (L, L_Len, R, R_Len))));
+ end Ghdl_Std_Ulogic_Array_Match_Ne;
+end Grt.Std_Logic_1164;
diff --git a/src/translate/grt/grt-std_logic_1164.ads b/src/translate/grt/grt-std_logic_1164.ads
new file mode 100644
index 000000000..4d1569553
--- /dev/null
+++ b/src/translate/grt/grt-std_logic_1164.ads
@@ -0,0 +1,124 @@
+-- GHDL Run Time (GRT) std_logic_1664 subprograms.
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+with Grt.Types; use Grt.Types;
+
+package Grt.Std_Logic_1164 is
+ type Std_Ulogic is ('U', 'X', '0', '1', 'Z', 'W','L', 'H', '-');
+
+ type Stdlogic_Table_2d is array (Std_Ulogic, Std_Ulogic) of Std_Ulogic;
+ type Stdlogic_Table_1d is array (Std_Ulogic) of Std_Ulogic;
+
+ -- LRM08 9.2.3 Relational operators
+ Match_Eq_Table : constant Stdlogic_Table_2d :=
+ --UX01ZWLH-
+ ("UUUUUUUU1",
+ "UXXXXXXX1",
+ "UX10XX101",
+ "UX01XX011",
+ "UXXXXXXX1",
+ "UXXXXXXX1",
+ "UX10XX101",
+ "UX01XX011",
+ "111111111");
+
+ Match_Lt_Table : constant Stdlogic_Table_2d :=
+ --UX01ZWLH-
+ ("UUUUUUUUX",
+ "UXXXXXXXX",
+ "UX01XX01X",
+ "UX00XX00X",
+ "UXXXXXXXX",
+ "UXXXXXXXX",
+ "UX01XX01X",
+ "UX00XX00X",
+ "XXXXXXXXX");
+
+ And_Table : constant Stdlogic_Table_2d :=
+ --UX01ZWLH-
+ ("UU0UUU0UX", -- U
+ "UX0XXX0XX", -- X
+ "000000000", -- 0
+ "UX01XX01X", -- 1
+ "UX0XXX0XX", -- Z
+ "UX0XXX0XX", -- W
+ "000000000", -- L
+ "UX01XX01X", -- H
+ "UX0XXX0XX"); -- -
+
+ Or_Table : constant Stdlogic_Table_2d :=
+ --UX01ZWLH-
+ ("UUU1UUU1U", -- U
+ "UXX1XXX1X", -- X
+ "UX01XX01X", -- 0
+ "111111111", -- 1
+ "UXX1XXX1X", -- Z
+ "UXX1XXX1X", -- W
+ "UX01XX01X", -- L
+ "111111111", -- H
+ "UXX1XXX1X"); -- -
+
+ Xor_Table : constant Stdlogic_Table_2d :=
+ --UX01ZWLH-
+ ("UUUUUUUUU", -- U
+ "UXXXXXXXX", -- X
+ "UX01XX01X", -- 0
+ "UX10XX10X", -- 1
+ "UXXXXXXXX", -- Z
+ "UXXXXXXXX", -- W
+ "UX01XX01X", -- L
+ "UX10XX10X", -- H
+ "UXXXXXXXX"); -- -
+
+ Not_Table : constant Stdlogic_Table_1d := "UX10XX10X";
+
+ function Ghdl_Std_Ulogic_Match_Eq (L, R : Ghdl_E8) return Ghdl_E8;
+ function Ghdl_Std_Ulogic_Match_Ne (L, R : Ghdl_E8) return Ghdl_E8;
+ function Ghdl_Std_Ulogic_Match_Lt (L, R : Ghdl_E8) return Ghdl_E8;
+ function Ghdl_Std_Ulogic_Match_Le (L, R : Ghdl_E8) return Ghdl_E8;
+ -- For Gt and Ge, use Lt and Le with swapped parameters.
+
+ function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr;
+ L_Len : Ghdl_Index_Type;
+ R : Ghdl_Ptr;
+ R_Len : Ghdl_Index_Type)
+ return Ghdl_I32;
+ function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr;
+ L_Len : Ghdl_Index_Type;
+ R : Ghdl_Ptr;
+ R_Len : Ghdl_Index_Type)
+ return Ghdl_I32;
+
+private
+ pragma Export (C, Ghdl_Std_Ulogic_Match_Eq, "__ghdl_std_ulogic_match_eq");
+ pragma Export (C, Ghdl_Std_Ulogic_Match_Ne, "__ghdl_std_ulogic_match_ne");
+ pragma Export (C, Ghdl_Std_Ulogic_Match_Lt, "__ghdl_std_ulogic_match_lt");
+ pragma Export (C, Ghdl_Std_Ulogic_Match_Le, "__ghdl_std_ulogic_match_le");
+
+ pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Eq,
+ "__ghdl_std_ulogic_array_match_eq");
+ pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Ne,
+ "__ghdl_std_ulogic_array_match_ne");
+end Grt.Std_Logic_1164;
diff --git a/src/translate/grt/grt-stdio.ads b/src/translate/grt/grt-stdio.ads
new file mode 100644
index 000000000..229249ac9
--- /dev/null
+++ b/src/translate/grt/grt-stdio.ads
@@ -0,0 +1,107 @@
+-- GHDL Run Time (GRT) - stdio binding.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System;
+with Grt.C; use Grt.C;
+
+-- This package provides a thin binding to the stdio.h of the C library.
+-- It mimics GNAT package Interfaces.C_Streams.
+-- The purpose of this package is to remove dependencies on the GNAT run time.
+
+package Grt.Stdio is
+ pragma Preelaborate (Grt.Stdio);
+
+ -- Type FILE *.
+ type FILEs is new System.Address;
+
+ -- NULL for a stream.
+ NULL_Stream : constant FILEs;
+
+ -- Predefined streams.
+ function stdout return FILEs;
+ function stderr return FILEs;
+ function stdin return FILEs;
+
+ -- The following subprograms are translation of the C prototypes.
+
+ function fopen (path: chars; mode : chars) return FILEs;
+
+ function fwrite (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs)
+ return size_t;
+
+ function fread (buffer : voids;
+ size : size_t;
+ count : size_t;
+ stream : FILEs)
+ return size_t;
+
+ function fputc (c : int; stream : FILEs) return int;
+ procedure fputc (c : int; stream : FILEs);
+
+ function fputs (s : chars; stream : FILEs) return int;
+
+ function fgetc (stream : FILEs) return int;
+ function fgets (s : chars; size : int; stream : FILEs) return chars;
+ function ungetc (c : int; stream : FILEs) return int;
+
+ function fflush (stream : FILEs) return int;
+ procedure fflush (stream : FILEs);
+
+ function feof (stream : FILEs) return int;
+
+ function ftell (stream : FILEs) return long;
+
+ function fclose (stream : FILEs) return int;
+ procedure fclose (Stream : FILEs);
+private
+ -- This is a little bit dubious, but this package should be preelaborated,
+ -- and Null_Address is not static (since defined in the private part
+ -- of System).
+ -- I am pretty sure the C definition of NULL is 0.
+ NULL_Stream : constant FILEs := FILEs (System'To_Address (0));
+
+ pragma Import (C, fopen);
+
+ pragma Import (C, fwrite);
+ pragma Import (C, fread);
+
+ pragma Import (C, fputs);
+ pragma Import (C, fputc);
+
+ pragma Import (C, fgetc);
+ pragma Import (C, fgets);
+ pragma Import (C, ungetc);
+
+ pragma Import (C, fflush);
+ pragma Import (C, feof);
+ pragma Import (C, ftell);
+ pragma Import (C, fclose);
+
+ pragma Import (C, stdout, "__ghdl_get_stdout");
+ pragma Import (C, stderr, "__ghdl_get_stderr");
+ pragma Import (C, stdin, "__ghdl_get_stdin");
+end Grt.Stdio;
diff --git a/src/translate/grt/grt-table.adb b/src/translate/grt/grt-table.adb
new file mode 100644
index 000000000..36aa99982
--- /dev/null
+++ b/src/translate/grt/grt-table.adb
@@ -0,0 +1,120 @@
+-- GHDL Run Time (GRT) - Resizable array
+-- Copyright (C) 2008 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+with System; use System;
+with Grt.C; use Grt.C;
+
+package body Grt.Table is
+
+ -- Maximum index of table before resizing.
+ Max : Table_Index_Type := Table_Index_Type'Pred (Table_Low_Bound);
+
+ -- Current value of Last
+ Last_Val : Table_Index_Type;
+
+ function Malloc (Size : size_t) return Table_Ptr;
+ pragma Import (C, Malloc);
+
+ procedure Free (T : Table_Ptr);
+ pragma Import (C, Free);
+
+ -- Resize and reallocate the table according to LAST_VAL.
+ procedure Resize is
+ function Realloc (T : Table_Ptr; Size : size_t) return Table_Ptr;
+ pragma Import (C, Realloc);
+
+ New_Size : size_t;
+ begin
+ while Max < Last_Val loop
+ Max := Max + (Max - Table_Low_Bound + 1);
+ end loop;
+
+ New_Size := size_t ((Max - Table_Low_Bound + 1) *
+ (Table_Type'Component_Size / Storage_Unit));
+
+ Table := Realloc (Table, New_Size);
+
+ if Table = null then
+ raise Storage_Error;
+ end if;
+ end Resize;
+
+ procedure Append (New_Val : Table_Component_Type) is
+ begin
+ Increment_Last;
+ Table (Last_Val) := New_Val;
+ end Append;
+
+ procedure Decrement_Last is
+ begin
+ Last_Val := Table_Index_Type'Pred (Last_Val);
+ end Decrement_Last;
+
+ procedure Free is
+ begin
+ Free (Table);
+ Table := null;
+ end Free;
+
+ procedure Increment_Last is
+ begin
+ Last_Val := Table_Index_Type'Succ (Last_Val);
+
+ if Last_Val > Max then
+ Resize;
+ end if;
+ end Increment_Last;
+
+ function Last return Table_Index_Type is
+ begin
+ return Last_Val;
+ end Last;
+
+ procedure Release is
+ begin
+ Max := Last_Val;
+ Resize;
+ end Release;
+
+ procedure Set_Last (New_Val : Table_Index_Type) is
+ begin
+ if New_Val < Last_Val then
+ Last_Val := New_Val;
+ else
+ Last_Val := New_Val;
+
+ if Last_Val > Max then
+ Resize;
+ end if;
+ end if;
+ end Set_Last;
+
+begin
+ Last_Val := Table_Index_Type'Pred (Table_Low_Bound);
+ Max := Table_Low_Bound + Table_Index_Type (Table_Initial) - 1;
+
+ Table := Malloc (size_t (Table_Initial *
+ (Table_Type'Component_Size / Storage_Unit)));
+end Grt.Table;
diff --git a/src/translate/grt/grt-table.ads b/src/translate/grt/grt-table.ads
new file mode 100644
index 000000000..f814eff5c
--- /dev/null
+++ b/src/translate/grt/grt-table.ads
@@ -0,0 +1,75 @@
+-- GHDL Run Time (GRT) - Resizable array
+-- Copyright (C) 2008 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+generic
+ type Table_Component_Type is private;
+ type Table_Index_Type is range <>;
+
+ Table_Low_Bound : Table_Index_Type;
+ Table_Initial : Positive;
+
+package Grt.Table is
+ pragma Elaborate_Body;
+
+ type Table_Type is
+ array (Table_Index_Type range <>) of Table_Component_Type;
+ subtype Fat_Table_Type is
+ Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
+
+ -- Thin pointer.
+ type Table_Ptr is access all Fat_Table_Type;
+
+ -- The table itself.
+ Table : aliased Table_Ptr := null;
+
+ -- Get the high bound.
+ function Last return Table_Index_Type;
+ pragma Inline (Last);
+
+ -- Get the low bound.
+ First : constant Table_Index_Type := Table_Low_Bound;
+
+ -- Increase the length by 1.
+ procedure Increment_Last;
+ pragma Inline (Increment_Last);
+
+ -- Decrease the length by 1.
+ procedure Decrement_Last;
+ pragma Inline (Decrement_Last);
+
+ -- Set the last bound.
+ procedure Set_Last (New_Val : Table_Index_Type);
+
+ -- Release extra memory.
+ procedure Release;
+
+ -- Free all the memory used by the table.
+ -- The table won't be useable anymore.
+ procedure Free;
+
+ -- Append a new element.
+ procedure Append (New_Val : Table_Component_Type);
+ pragma Inline (Append);
+end Grt.Table;
diff --git a/src/translate/grt/grt-threads.ads b/src/translate/grt/grt-threads.ads
new file mode 100644
index 000000000..248f2c41b
--- /dev/null
+++ b/src/translate/grt/grt-threads.ads
@@ -0,0 +1,27 @@
+-- GHDL Run Time (GRT) - threading.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Unithread;
+
+package Grt.Threads renames Grt.Unithread;
diff --git a/src/translate/grt/grt-types.ads b/src/translate/grt/grt-types.ads
new file mode 100644
index 000000000..fed822554
--- /dev/null
+++ b/src/translate/grt/grt-types.ads
@@ -0,0 +1,327 @@
+-- GHDL Run Time (GRT) - common types.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with Interfaces; use Interfaces;
+
+package Grt.Types is
+ pragma Preelaborate (Grt.Types);
+
+ type Ghdl_B1 is new Boolean;
+ type Ghdl_E8 is new Unsigned_8;
+ type Ghdl_U32 is new Unsigned_32;
+ subtype Ghdl_E32 is Ghdl_U32;
+ type Ghdl_I32 is new Integer_32;
+ type Ghdl_I64 is new Integer_64;
+ type Ghdl_U64 is new Unsigned_64;
+ type Ghdl_F64 is new IEEE_Float_64;
+
+ type Ghdl_Ptr is new Address;
+ type Ghdl_Index_Type is mod 2 ** 32;
+ subtype Ghdl_Real is Ghdl_F64;
+
+ type Ghdl_Dir_Type is (Dir_To, Dir_Downto);
+ for Ghdl_Dir_Type use (Dir_To => 0, Dir_Downto => 1);
+ for Ghdl_Dir_Type'Size use 8;
+
+ -- Access to an unconstrained string.
+ type String_Access is access String;
+ procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation
+ (Name => String_Access, Object => String);
+
+ subtype Std_Integer is Ghdl_I32;
+
+ type Std_Time is new Ghdl_I64;
+ Bad_Time : constant Std_Time := Std_Time'First;
+
+ type Std_Integer_Trt is record
+ Left : Std_Integer;
+ Right : Std_Integer;
+ Dir : Ghdl_Dir_Type;
+ Length : Ghdl_Index_Type;
+ end record;
+
+ subtype Std_Character is Character;
+ type Std_String_Uncons is array (Ghdl_Index_Type range <>) of Std_Character;
+ subtype Std_String_Base is Std_String_Uncons (Ghdl_Index_Type);
+ type Std_String_Basep is access all Std_String_Base;
+ function To_Std_String_Basep is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Std_String_Basep);
+
+ type Std_String_Bound is record
+ Dim_1 : Std_Integer_Trt;
+ end record;
+ type Std_String_Boundp is access all Std_String_Bound;
+ function To_Std_String_Boundp is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Std_String_Boundp);
+
+ type Std_String is record
+ Base : Std_String_Basep;
+ Bounds : Std_String_Boundp;
+ end record;
+ type Std_String_Ptr is access all Std_String;
+ function To_Std_String_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Std_String_Ptr);
+
+ type Std_Bit is ('0', '1');
+ type Std_Bit_Vector_Uncons is array (Ghdl_Index_Type range <>) of Std_Bit;
+ subtype Std_Bit_Vector_Base is Std_Bit_Vector_Uncons (Ghdl_Index_Type);
+ type Std_Bit_Vector_Basep is access all Std_Bit_Vector_Base;
+
+ -- An unconstrained array.
+ -- It is in fact a fat pointer to the base and the bounds.
+ type Ghdl_Uc_Array is record
+ Base : Address;
+ Bounds : Address;
+ end record;
+ type Ghdl_Uc_Array_Acc is access Ghdl_Uc_Array;
+ function To_Ghdl_Uc_Array_Acc is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Uc_Array_Acc);
+
+ -- Verilog types.
+
+ type Ghdl_Logic32 is record
+ Val : Ghdl_U32;
+ Xz : Ghdl_U32;
+ end record;
+ type Ghdl_Logic32_Ptr is access Ghdl_Logic32;
+ type Ghdl_Logic32_Vec is array (Ghdl_U32) of Ghdl_Logic32;
+ type Ghdl_Logic32_Vptr is access Ghdl_Logic32_Vec;
+
+ function To_Ghdl_Logic32_Vptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Logic32_Vptr);
+
+ function To_Ghdl_Logic32_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Logic32_Ptr);
+
+ -- Mimics C strings (NUL ended).
+ -- Note: this is 1 based.
+ type Ghdl_C_String is access String (Positive);
+ NUL : constant Character := Character'Val (0);
+
+ Nl : constant Character := Character'Val (10); -- LF, nl or '\n'.
+
+ function strlen (Str : Ghdl_C_String) return Natural;
+ pragma Import (C, strlen);
+
+ function Strcmp (L , R : Ghdl_C_String) return Integer;
+ pragma Import (C, Strcmp);
+
+ function To_Ghdl_C_String is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_C_String);
+
+ -- Str_len.
+ type String_Ptr is access String (1 .. Natural'Last);
+ type Ghdl_Str_Len_Type is record
+ Len : Natural;
+ Str : String_Ptr;
+ end record;
+ -- Same as previous one, but using 'address.
+ type Ghdl_Str_Len_Address_Type is record
+ Len : Natural;
+ Str : Address;
+ end record;
+ type Ghdl_Str_Len_Ptr is access constant Ghdl_Str_Len_Type;
+ type Ghdl_Str_Len_Array is array (Natural) of Ghdl_Str_Len_Type;
+ type Ghdl_Str_Len_Array_Ptr is access all Ghdl_Str_Len_Array;
+
+ -- Location is used for errors/messages.
+ type Ghdl_Location is record
+ Filename : Ghdl_C_String;
+ Line : Integer;
+ Col : Integer;
+ end record;
+ type Ghdl_Location_Ptr is access Ghdl_Location;
+ function To_Ghdl_Location_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Location_Ptr);
+
+ -- Signal index.
+ type Sig_Table_Index is new Integer;
+
+ -- A range of signals.
+ type Sig_Table_Range is record
+ First, Last : Sig_Table_Index;
+ end record;
+
+ -- Simple values, used for signals.
+ type Mode_Type is
+ (Mode_B1, Mode_E8, Mode_E32, Mode_I32, Mode_I64, Mode_F64);
+
+ type Ghdl_B1_Array is array (Ghdl_Index_Type range <>) of Ghdl_B1;
+ subtype Ghdl_B1_Array_Base is Ghdl_B1_Array (Ghdl_Index_Type);
+ type Ghdl_B1_Array_Base_Ptr is access Ghdl_B1_Array_Base;
+ function To_Ghdl_B1_Array_Base_Ptr is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Ptr, Target => Ghdl_B1_Array_Base_Ptr);
+
+ type Ghdl_E8_Array is array (Ghdl_Index_Type range <>) of Ghdl_E8;
+ subtype Ghdl_E8_Array_Base is Ghdl_E8_Array (Ghdl_Index_Type);
+ type Ghdl_E8_Array_Base_Ptr is access Ghdl_E8_Array_Base;
+ function To_Ghdl_E8_Array_Base_Ptr is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Ptr, Target => Ghdl_E8_Array_Base_Ptr);
+
+ type Ghdl_E32_Array is array (Ghdl_Index_Type range <>) of Ghdl_E32;
+ subtype Ghdl_E32_Array_Base is Ghdl_E32_Array (Ghdl_Index_Type);
+ type Ghdl_E32_Array_Base_Ptr is access Ghdl_E32_Array_Base;
+ function To_Ghdl_E32_Array_Base_Ptr is new Ada.Unchecked_Conversion
+ (Source => Ghdl_Ptr, Target => Ghdl_E32_Array_Base_Ptr);
+
+ type Ghdl_I32_Array is array (Ghdl_Index_Type range <>) of Ghdl_I32;
+
+ type Value_Union (Mode : Mode_Type := Mode_B1) is record
+ case Mode is
+ when Mode_B1 =>
+ B1 : Ghdl_B1;
+ when Mode_E8 =>
+ E8 : Ghdl_E8;
+ when Mode_E32 =>
+ E32 : Ghdl_E32;
+ when Mode_I32 =>
+ I32 : Ghdl_I32;
+ when Mode_I64 =>
+ I64 : Ghdl_I64;
+ when Mode_F64 =>
+ F64 : Ghdl_F64;
+ end case;
+ end record;
+ pragma Unchecked_Union (Value_Union);
+
+ type Ghdl_Value_Ptr is access Value_Union;
+ function To_Ghdl_Value_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Value_Ptr);
+
+ -- Ranges.
+ type Ghdl_Range_B1 is record
+ Left : Ghdl_B1;
+ Right : Ghdl_B1;
+ Dir : Ghdl_Dir_Type;
+ Len : Ghdl_Index_Type;
+ end record;
+
+ type Ghdl_Range_E8 is record
+ Left : Ghdl_E8;
+ Right : Ghdl_E8;
+ Dir : Ghdl_Dir_Type;
+ Len : Ghdl_Index_Type;
+ end record;
+
+ type Ghdl_Range_E32 is record
+ Left : Ghdl_E32;
+ Right : Ghdl_E32;
+ Dir : Ghdl_Dir_Type;
+ Len : Ghdl_Index_Type;
+ end record;
+
+ type Ghdl_Range_I32 is record
+ Left : Ghdl_I32;
+ Right : Ghdl_I32;
+ Dir : Ghdl_Dir_Type;
+ Len : Ghdl_Index_Type;
+ end record;
+
+ type Ghdl_Range_I64 is record
+ Left : Ghdl_I64;
+ Right : Ghdl_I64;
+ Dir : Ghdl_Dir_Type;
+ Len : Ghdl_Index_Type;
+ end record;
+
+ type Ghdl_Range_F64 is record
+ Left : Ghdl_F64;
+ Right : Ghdl_F64;
+ Dir : Ghdl_Dir_Type;
+ end record;
+
+ type Ghdl_Range_Type (K : Mode_Type := Mode_B1) is record
+ case K is
+ when Mode_B1 =>
+ B1 : Ghdl_Range_B1;
+ when Mode_E8 =>
+ E8 : Ghdl_Range_E8;
+ when Mode_E32 =>
+ E32 : Ghdl_Range_E32;
+ when Mode_I32 =>
+ I32 : Ghdl_Range_I32;
+ when Mode_I64 =>
+ P64 : Ghdl_Range_I64;
+ when Mode_F64 =>
+ F64 : Ghdl_Range_F64;
+ end case;
+ end record;
+ pragma Unchecked_Union (Ghdl_Range_Type);
+
+ type Ghdl_Range_Ptr is access all Ghdl_Range_Type;
+
+ function To_Ghdl_Range_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Range_Ptr);
+
+ type Ghdl_Range_Array is array (Ghdl_Index_Type range <>) of Ghdl_Range_Ptr;
+
+ -- Mode of a signal.
+ type Mode_Signal_Type is
+ (Mode_Signal,
+ Mode_Linkage, Mode_Buffer, Mode_Out, Mode_Inout, Mode_In,
+ Mode_Stable, Mode_Quiet, Mode_Delayed, Mode_Transaction, Mode_Guard,
+ Mode_Conv_In, Mode_Conv_Out,
+ Mode_End);
+
+ subtype Mode_Signal_Port is
+ Mode_Signal_Type range Mode_Linkage .. Mode_In;
+
+ -- Not implicit signals.
+ subtype Mode_Signal_User is
+ Mode_Signal_Type range Mode_Signal .. Mode_In;
+
+ -- Implicit signals.
+ subtype Mode_Signal_Implicit is
+ Mode_Signal_Type range Mode_Stable .. Mode_Guard;
+
+ subtype Mode_Signal_Forward is
+ Mode_Signal_Type range Mode_Stable .. Mode_Delayed;
+
+ -- Kind of a signal.
+ type Kind_Signal_Type is
+ (Kind_Signal_No, Kind_Signal_Register, Kind_Signal_Bus);
+
+ -- Note: we could use system.storage_elements, but unfortunatly,
+ -- this doesn't work with pragma no_run_time (gnat 3.15p).
+ type Integer_Address is mod Memory_Size;
+
+ function To_Address is new Ada.Unchecked_Conversion
+ (Source => Integer_Address, Target => Address);
+
+ function To_Integer is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Integer_Address);
+
+ -- The NOW value.
+ Current_Time : Std_Time;
+ -- Copy of Current_Time before updating it.
+ -- To be used by hooks.
+ Cycle_Time : Std_Time;
+ -- The current delta cycle number.
+ Current_Delta : Integer;
+private
+ pragma Export (C, Current_Time, "__ghdl_now");
+end Grt.Types;
diff --git a/src/translate/grt/grt-unithread.adb b/src/translate/grt/grt-unithread.adb
new file mode 100644
index 000000000..6acb52169
--- /dev/null
+++ b/src/translate/grt/grt-unithread.adb
@@ -0,0 +1,106 @@
+-- GHDL Run Time (GRT) - mono-thread version.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package body Grt.Unithread is
+ procedure Init is
+ begin
+ null;
+ end Init;
+
+ procedure Finish is
+ begin
+ null;
+ end Finish;
+
+ procedure Run_Parallel (Subprg : Parallel_Subprg_Acc) is
+ begin
+ Subprg.all;
+ end Run_Parallel;
+
+ function Atomic_Insert (List : access Ghdl_Signal_Ptr; El : Ghdl_Signal_Ptr)
+ return Ghdl_Signal_Ptr
+ is
+ Prev : Ghdl_Signal_Ptr;
+ begin
+ Prev := List.all;
+ List.all := El;
+ return Prev;
+ end Atomic_Insert;
+
+ function Atomic_Inc (Val : access Natural) return Natural
+ is
+ Res : Natural;
+ begin
+ Res := Val.all;
+ Val.all := Val.all + 1;
+ return Res;
+ end Atomic_Inc;
+
+ Current_Process : Process_Acc;
+
+ -- Called by linux.c
+ function Grt_Get_Current_Process return Process_Acc;
+ pragma Export (C, Grt_Get_Current_Process);
+
+ function Grt_Get_Current_Process return Process_Acc is
+ begin
+ return Current_Process;
+ end Grt_Get_Current_Process;
+
+
+ procedure Set_Current_Process (Proc : Process_Acc) is
+ begin
+ Current_Process := Proc;
+ end Set_Current_Process;
+
+ function Get_Current_Process return Process_Acc is
+ begin
+ return Current_Process;
+ end Get_Current_Process;
+
+ Stack2 : Stack2_Ptr;
+
+ function Get_Stack2 return Stack2_Ptr is
+ begin
+ return Stack2;
+ end Get_Stack2;
+
+ procedure Set_Stack2 (St : Stack2_Ptr) is
+ begin
+ Stack2 := St;
+ end Set_Stack2;
+
+ Main_Stack : Stack_Type;
+
+ function Get_Main_Stack return Stack_Type is
+ begin
+ return Main_Stack;
+ end Get_Main_Stack;
+
+ procedure Set_Main_Stack (St : Stack_Type) is
+ begin
+ Main_Stack := St;
+ end Set_Main_Stack;
+end Grt.Unithread;
diff --git a/src/translate/grt/grt-unithread.ads b/src/translate/grt/grt-unithread.ads
new file mode 100644
index 000000000..b35b7be33
--- /dev/null
+++ b/src/translate/grt/grt-unithread.ads
@@ -0,0 +1,73 @@
+-- GHDL Run Time (GRT) - mono-thread version.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Signals; use Grt.Signals;
+with Grt.Stack2; use Grt.Stack2;
+with Grt.Stacks; use Grt.Stacks;
+
+package Grt.Unithread is
+ procedure Init;
+ procedure Finish;
+
+ type Parallel_Subprg_Acc is access procedure;
+ procedure Run_Parallel (Subprg : Parallel_Subprg_Acc);
+
+ -- Return the old value of LIST.all and store EL into LIST.all.
+ function Atomic_Insert (List : access Ghdl_Signal_Ptr; El : Ghdl_Signal_Ptr)
+ return Ghdl_Signal_Ptr;
+
+ -- Return the old value.
+ function Atomic_Inc (Val : access Natural) return Natural;
+
+ -- Set and get the current process being executed by the thread.
+ procedure Set_Current_Process (Proc : Process_Acc);
+ function Get_Current_Process return Process_Acc;
+
+ -- The secondary stack for the thread. In this implementation, there is
+ -- only one secondary stack, shared by all processes. This is allowed,
+ -- because a wait statement cannot appear within a function. So at a wait
+ -- statement, the secondary stack must be empty.
+ function Get_Stack2 return Stack2_Ptr;
+ procedure Set_Stack2 (St : Stack2_Ptr);
+
+ -- The main stack. This is initialized by STACK_INIT.
+ -- The return point.
+ function Get_Main_Stack return Stack_Type;
+ procedure Set_Main_Stack (St : Stack_Type);
+private
+ pragma Inline (Run_Parallel);
+ pragma Inline (Atomic_Insert);
+ pragma Inline (Atomic_Inc);
+ pragma Inline (Get_Stack2);
+ pragma Inline (Set_Stack2);
+
+ pragma Inline (Get_Main_Stack);
+ pragma Export (C, Set_Main_Stack, "grt_set_main_stack");
+
+ pragma Inline (Set_Current_Process);
+ pragma Inline (Get_Current_Process);
+
+end Grt.Unithread;
diff --git a/src/translate/grt/grt-values.adb b/src/translate/grt/grt-values.adb
new file mode 100644
index 000000000..3d703bc85
--- /dev/null
+++ b/src/translate/grt/grt-values.adb
@@ -0,0 +1,639 @@
+-- GHDL Run Time (GRT) - 'value subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Errors; use Grt.Errors;
+with Grt.Rtis_Utils;
+
+package body Grt.Values is
+
+ NBSP : constant Character := Character'Val (160);
+ HT : constant Character := Character'Val (9);
+
+ -- Return True IFF C is a whitespace character (as defined in LRM93 14.3)
+ function Is_Whitespace (C : in Character) return Boolean is
+ begin
+ return C = ' ' or C = NBSP or C = HT;
+ end Is_Whitespace;
+
+ -- Increase POS to skip leading whitespace characters, decrease LEN to
+ -- skip trailing whitespaces in string S.
+ procedure Remove_Whitespaces (S : Std_String_Basep;
+ Len : in out Ghdl_Index_Type;
+ Pos : in out Ghdl_Index_Type) is
+ begin
+ -- GHDL: allow several leading whitespace.
+ while Pos < Len loop
+ exit when not Is_Whitespace (S (Pos));
+ Pos := Pos + 1;
+ end loop;
+
+ -- GHDL: allow several leading whitespace.
+ while Len > Pos loop
+ exit when not Is_Whitespace (S (Len - 1));
+ Len := Len - 1;
+ end loop;
+ if Pos = Len then
+ Error_E ("'value: empty string");
+ end if;
+ end Remove_Whitespaces;
+
+ -- Convert C to lowercase.
+ function To_LC (C : in Character) return Character is
+ begin
+ if C >= 'A' and then C <= 'Z' then
+ return Character'Val
+ (Character'Pos (C) + Character'Pos ('a') - Character'Pos ('A'));
+ else
+ return C;
+ end if;
+ end To_LC;
+
+ -- Return TRUE iff user string S (POS .. LEN - 1) is equal to REF.
+ -- Comparaison is case insensitive, but REF must be lowercase (REF is
+ -- supposed to come from an RTI).
+ function String_Match (S : Std_String_Basep;
+ Pos : Ghdl_Index_Type;
+ Len : Ghdl_Index_Type;
+ Ref : Ghdl_C_String) return Boolean
+ is
+ P : Ghdl_Index_Type;
+ C : Character;
+ begin
+ P := 0;
+ loop
+ C := Ref (Natural (P + 1));
+ if Pos + P = Len then
+ -- End of string.
+ return C = ASCII.NUL;
+ end if;
+ if To_LC (S (Pos + P)) /= C or else C = ASCII.NUL then
+ return False;
+ end if;
+ P := P + 1;
+ end loop;
+ end String_Match;
+
+ -- Return the value of STR for enumerated type RTI.
+ function Ghdl_Value_Enum (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_Index_Type
+ is
+ Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc :=
+ To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ S : constant Std_String_Basep := Str.Base;
+ Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
+ Pos : Ghdl_Index_Type := 0;
+ begin
+ Remove_Whitespaces (S, Len, Pos);
+
+ for I in 0 .. Enum_Rti.Nbr - 1 loop
+ if String_Match (S, Pos, Len, Enum_Rti.Names (I)) then
+ return I;
+ end if;
+ end loop;
+ Error_C ("'value: '");
+ Error_C_Std (S (Pos .. Len));
+ Error_C ("' not in enumeration '");
+ Error_C (Enum_Rti.Name);
+ Error_E ("'");
+ end Ghdl_Value_Enum;
+
+ function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_B1
+ is
+ begin
+ return Ghdl_B1'Val (Ghdl_Value_Enum (Str, Rti));
+ end Ghdl_Value_B1;
+
+ function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_E8
+ is
+ begin
+ return Ghdl_E8'Val (Ghdl_Value_Enum (Str, Rti));
+ end Ghdl_Value_E8;
+
+ function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_E32
+ is
+ begin
+ return Ghdl_E32'Val (Ghdl_Value_Enum (Str, Rti));
+ end Ghdl_Value_E32;
+
+ -- Convert S (INIT_POS .. LEN) to a signed integer.
+ function Ghdl_Value_I64 (S : Std_String_Basep;
+ Len : Ghdl_Index_Type;
+ Init_Pos : Ghdl_Index_Type)
+ return Ghdl_I64
+ is
+ Pos : Ghdl_Index_Type := Init_Pos;
+ C : Character;
+ Sep : Character;
+ Val, D, Base : Ghdl_I64;
+ Exp : Integer;
+ begin
+ C := S (Pos);
+
+ -- Be user friendly.
+ -- FIXME: reference.
+ if C = '-' or C = '+' then
+ Error_E ("'value: leading sign +/- not allowed");
+ end if;
+
+ Val := 0;
+ loop
+ if C in '0' .. '9' then
+ Val := Val * 10 + Character'Pos (C) - Character'Pos ('0');
+ Pos := Pos + 1;
+ exit when Pos >= Len;
+ C := S (Pos);
+ else
+ Error_E ("'value: decimal digit expected");
+ end if;
+ case C is
+ when '_' =>
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: trailing underscore");
+ end if;
+ C := S (Pos);
+ when '#'
+ | ':'
+ | 'E'
+ | 'e' =>
+ exit;
+ when ' '
+ | NBSP
+ | HT =>
+ Pos := Pos + 1;
+ exit;
+ when others =>
+ null;
+ end case;
+ end loop;
+
+ if Pos >= Len then
+ return Val;
+ end if;
+
+ if C = '#' or C = ':' then
+ Base := Val;
+ Val := 0;
+ Sep := C;
+ Pos := Pos + 1;
+ if Base < 2 or Base > 16 then
+ Error_E ("'value: bad base");
+ end if;
+ if Pos >= Len then
+ Error_E ("'value: missing based integer");
+ end if;
+ C := S (Pos);
+ loop
+ case C is
+ when '0' .. '9' =>
+ D := Character'Pos (C) - Character'Pos ('0');
+ when 'a' .. 'f' =>
+ D := Character'Pos (C) - Character'Pos ('a') + 10;
+ when 'A' .. 'F' =>
+ D := Character'Pos (C) - Character'Pos ('A') + 10;
+ when others =>
+ Error_E ("'value: digit expected");
+ end case;
+ if D >= Base then
+ Error_E ("'value: digit >= base");
+ end if;
+ Val := Val * Base + D;
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: missing end sign number");
+ end if;
+ C := S (Pos);
+ if C = '#' or C = ':' then
+ if C /= Sep then
+ Error_E ("'value: sign number mismatch");
+ end if;
+ Pos := Pos + 1;
+ exit;
+ elsif C = '_' then
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: no character after underscore");
+ end if;
+ C := S (Pos);
+ end if;
+ end loop;
+ else
+ Base := 10;
+ end if;
+
+ -- Handle exponent.
+ if C = 'e' or C = 'E' then
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: no character after exponent");
+ end if;
+ C := S (Pos);
+ if C = '+' then
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: no character after sign");
+ end if;
+ C := S (Pos);
+ elsif C = '-' then
+ Error_E ("'value: negativ exponent not allowed");
+ end if;
+ Exp := 0;
+ loop
+ if C in '0' .. '9' then
+ Exp := Exp * 10 + Character'Pos (C) - Character'Pos ('0');
+ Pos := Pos + 1;
+ exit when Pos >= Len;
+ C := S (Pos);
+ else
+ Error_E ("'value: decimal digit expected");
+ end if;
+ case C is
+ when '_' =>
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: trailing underscore");
+ end if;
+ C := S (Pos);
+ when ' '
+ | NBSP
+ | HT =>
+ Pos := Pos + 1;
+ exit;
+ when others =>
+ null;
+ end case;
+ end loop;
+ while Exp > 0 loop
+ if Exp mod 2 = 1 then
+ Val := Val * Base;
+ end if;
+ Exp := Exp / 2;
+ Base := Base * Base;
+ end loop;
+ end if;
+
+ if Pos /= Len then
+ Error_E ("'value: trailing characters after blank");
+ end if;
+
+ return Val;
+ end Ghdl_Value_I64;
+
+ function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64
+ is
+ S : constant Std_String_Basep := Str.Base;
+ Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
+ Pos : Ghdl_Index_Type := 0;
+ begin
+ -- LRM 14.1
+ -- Leading [and trailing] whitespace is allowed and ignored.
+ --
+ -- GHDL: allow several leading whitespace.
+ Remove_Whitespaces (S, Len, Pos);
+
+ return Ghdl_Value_I64 (S, Len, Pos);
+ end Ghdl_Value_I64;
+
+ function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32
+ is
+ begin
+ return Ghdl_I32 (Ghdl_Value_I64 (Str));
+ end Ghdl_Value_I32;
+
+ -- From patch attached to https://gna.org/bugs/index.php?18352
+ -- thanks to Christophe Curis https://gna.org/users/lobotomy
+ function Ghdl_Value_F64 (S : Std_String_Basep;
+ Len : Ghdl_Index_Type;
+ Init_Pos : Ghdl_Index_Type)
+ return Ghdl_F64
+ is
+ Pos : Ghdl_Index_Type := Init_Pos;
+ C : Character;
+ Is_Negative, Is_Neg_Exp : Boolean := False;
+ Base : Ghdl_F64;
+ Intg : Ghdl_I32;
+ Val, Df : Ghdl_F64;
+ Sep : Character;
+ FrcExp : Ghdl_F64;
+ begin
+ C := S (Pos);
+ if C = '-' then
+ Is_Negative := True;
+ Pos := Pos + 1;
+ elsif C = '+' then
+ Pos := Pos + 1;
+ end if;
+
+ if Pos >= Len then
+ Error_E ("'value: decimal digit expected");
+ end if;
+
+ -- Read Integer-or-Base part (may be optional)
+ Intg := 0;
+ while Pos < Len loop
+ C := S (Pos);
+ if C in '0' .. '9' then
+ Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0');
+ elsif C /= '_' then
+ exit;
+ end if;
+ Pos := Pos + 1;
+ end loop;
+
+ if Pos = Len then
+ return Ghdl_F64 (Intg);
+ end if;
+
+ -- Special case: base was specified
+ if C = '#' or C = ':' then
+ if Intg < 2 or Intg > 16 then
+ Error_E ("'value: bad base");
+ end if;
+ Base := Ghdl_F64 (Intg);
+ Val := 0.0;
+ Sep := C;
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: missing based decimal");
+ end if;
+
+ -- Get the Integer part of the Value
+ while Pos < Len loop
+ C := S (Pos);
+ case C is
+ when '0' .. '9' =>
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0') );
+ when 'A' .. 'F' =>
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10);
+ when 'a' .. 'f' =>
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10);
+ when others =>
+ exit;
+ end case;
+ if C /= '_' then
+ if Df >= Base then
+ Error_E ("'value: digit greater than base");
+ end if;
+ Val := Val * Base + Df;
+ end if;
+ Pos := Pos + 1;
+ end loop;
+ if Pos >= Len then
+ Error_E ("'value: missing end sign number");
+ end if;
+ else
+ Base := 10.0;
+ Sep := ' ';
+ Val := Ghdl_F64 (Intg);
+ end if;
+
+ -- Handle the Fractional part
+ if C = '.' then
+ Pos := Pos + 1;
+ FrcExp := 1.0;
+ while Pos < Len loop
+ C := S (Pos);
+ case C is
+ when '0' .. '9' =>
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0'));
+ when 'A' .. 'F' =>
+ exit when Sep = ' ';
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10);
+ when 'a' .. 'f' =>
+ exit when Sep = ' ';
+ Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10);
+ when others =>
+ exit;
+ end case;
+ if C /= '_' then
+ FrcExp := FrcExp / Base;
+ if Df > Base then
+ Error_E ("'value: digit greater than base");
+ end if;
+ Val := Val + Df * FrcExp;
+ end if;
+ Pos := Pos + 1;
+ end loop;
+ end if;
+
+ -- If base was specified, we must find here the end marker
+ if Sep /= ' ' then
+ if Pos >= Len then
+ Error_E ("'value: missing end sign number");
+ end if;
+ if C /= Sep then
+ Error_E ("'value: sign number mismatch");
+ end if;
+ Pos := Pos + 1;
+ end if;
+
+ -- Handle exponent
+ if Pos < Len then
+ C := S (Pos);
+ if C = 'e' or C = 'E' then
+ Pos := Pos + 1;
+ if Pos >= Len then
+ Error_E ("'value: no character after exponent");
+ end if;
+ C := S (Pos);
+ if C = '-' then
+ Is_Neg_Exp := True;
+ Pos := Pos + 1;
+ elsif C = '+' then
+ Pos := Pos + 1;
+ end if;
+ Intg := 0;
+ while Pos < Len loop
+ C := S (Pos);
+ if C in '0' .. '9' then
+ Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0');
+ else
+ exit;
+ end if;
+ Pos := Pos + 1;
+ end loop;
+ -- This Exponentiation method is sub-optimal,
+ -- but it does not depend on any library
+ FrcExp := 1.0;
+ if Is_Neg_Exp then
+ while Intg > 0 loop
+ FrcExp := FrcExp / 10.0;
+ Intg := Intg - 1;
+ end loop;
+ else
+ while Intg > 0 loop
+ FrcExp := FrcExp * 10.0;
+ Intg := Intg - 1;
+ end loop;
+ end if;
+ Val := Val * FrcExp;
+ end if;
+ end if;
+
+ if Pos /= Len then
+ Error_E ("'value: trailing characters after blank");
+ end if;
+
+ if Is_Negative then
+ Val := -Val;
+ end if;
+
+ return Val;
+ end Ghdl_Value_F64;
+
+ -- From patch attached to https://gna.org/bugs/index.php?18352
+ -- thanks to Christophe Curis https://gna.org/users/lobotomy
+ function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64
+ is
+ S : constant Std_String_Basep := Str.Base;
+ Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
+ Pos : Ghdl_Index_Type := 0;
+ begin
+ -- LRM 14.1
+ -- Leading and trailing whitespace is allowed and ignored.
+ --
+ -- GHDL: allow several leading whitespace.
+ Remove_Whitespaces (S, Len, Pos);
+
+ return Ghdl_Value_F64 (S, Len, Pos);
+ end Ghdl_Value_F64;
+
+ procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr;
+ Is_Real : out Boolean;
+ Lit_Pos : out Ghdl_Index_Type;
+ Lit_End : out Ghdl_Index_Type;
+ Unit_Pos : out Ghdl_Index_Type)
+ is
+ S : constant Std_String_Basep := Str.Base;
+ Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
+ begin
+ -- LRM 14.1
+ -- Leading and trailing whitespace is allowed and ignored.
+ Lit_Pos := 0;
+ Remove_Whitespaces (S, Len, Lit_Pos);
+
+ -- Split between abstract literal (optionnal) and unit name.
+ Lit_End := Lit_Pos;
+ Is_Real := False;
+ while Lit_End < Len loop
+ exit when Is_Whitespace (S (Lit_End));
+ if S (Lit_End) = '.' then
+ Is_Real := True;
+ end if;
+ Lit_End := Lit_End + 1;
+ end loop;
+ if Lit_End = Len then
+ -- No literal
+ Unit_Pos := Lit_Pos;
+ Lit_End := 0;
+ else
+ Unit_Pos := Lit_End + 1;
+ while Unit_Pos < Len loop
+ exit when not Is_Whitespace (S (Unit_Pos));
+ Unit_Pos := Unit_Pos + 1;
+ end loop;
+ end if;
+ end Ghdl_Value_Physical_Split;
+
+ function Ghdl_Value_Physical_Type (Str : Std_String_Ptr;
+ Rti : Ghdl_Rti_Access)
+ return Ghdl_I64
+ is
+ S : constant Std_String_Basep := Str.Base;
+ Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length;
+ Unit_Pos : Ghdl_Index_Type;
+ Lit_Pos : Ghdl_Index_Type;
+ Lit_End : Ghdl_Index_Type;
+
+ Found_Real : Boolean;
+
+ Phys_Rti : constant Ghdl_Rtin_Type_Physical_Acc :=
+ To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Unit_Name : Ghdl_C_String;
+ Multiple : Ghdl_Rti_Access;
+ Mult : Ghdl_I64;
+ begin
+ -- Remove trailing whitespaces. FIXME: also called in physical_split.
+ Lit_Pos := 0;
+ Remove_Whitespaces (S, Len, Lit_Pos);
+
+ -- Extract literal and unit
+ Ghdl_Value_Physical_Split (Str, Found_Real, Lit_Pos, Lit_End, Unit_Pos);
+
+ -- Find unit value
+ Multiple := null;
+ for i in 0 .. Phys_Rti.Nbr - 1 loop
+ Unit_Name :=
+ Rtis_Utils.Get_Physical_Unit_Name (Phys_Rti.Units (i));
+ if String_Match (S, Unit_Pos, Len, Unit_Name) then
+ Multiple := Phys_Rti.Units (i);
+ exit;
+ end if;
+ end loop;
+ if Multiple = null then
+ Error_C ("'value: unit '");
+ Error_C_Std (S (Unit_Pos .. Len - 1));
+ Error_C ("' not in physical type '");
+ Error_C (Phys_Rti.Name);
+ Error_E ("'");
+ end if;
+
+ Mult := Grt.Rtis_Utils.Get_Physical_Unit_Value (Multiple, Rti);
+
+ if Lit_End = 0 then
+ return Mult;
+ else
+ if Found_Real then
+ return Ghdl_I64
+ (Ghdl_Value_F64 (S, Lit_End, Lit_Pos) * Ghdl_F64 (Mult));
+ else
+ return Ghdl_Value_I64 (S, Lit_End, Lit_Pos) * Mult;
+ end if;
+ end if;
+ end Ghdl_Value_Physical_Type;
+
+ function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_I64
+ is
+ begin
+ if Rti.Kind /= Ghdl_Rtik_Type_P64 then
+ Error_E ("Physical_Type_64'value: incorrect RTI");
+ end if;
+ return Ghdl_Value_Physical_Type (Str, Rti);
+ end Ghdl_Value_P64;
+
+ function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_I32
+ is
+ begin
+ if Rti.Kind /= Ghdl_Rtik_Type_P32 then
+ Error_E ("Physical_Type_32'value: incorrect RTI");
+ end if;
+ return Ghdl_I32 (Ghdl_Value_Physical_Type (Str, Rti));
+ end Ghdl_Value_P32;
+
+end Grt.Values;
diff --git a/src/translate/grt/grt-values.ads b/src/translate/grt/grt-values.ads
new file mode 100644
index 000000000..8df8c3f63
--- /dev/null
+++ b/src/translate/grt/grt-values.ads
@@ -0,0 +1,69 @@
+-- GHDL Run Time (GRT) - 'value subprograms.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Rtis; use Grt.Rtis;
+
+package Grt.Values is
+ -- Return True IFF C is a whitespace character (as defined in LRM93 14.3)
+ function Is_Whitespace (C : in Character) return Boolean;
+
+ -- Convert C to lowercase.
+ function To_LC (C : in Character) return Character;
+
+ -- Extract position of numeric literal and unit in string STR.
+ -- Set IS_REAL if the unit is a real number (presence of '.').
+ -- Set UNIT_POS to the position of the first character of the unit name.
+ -- Set LIT_POS to the position of the first character of the numeric
+ -- literal (after whitespaces are skipped).
+ -- Set LIT_END to the position of the next character of the numeric lit.
+ procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr;
+ Is_Real : out Boolean;
+ Lit_Pos : out Ghdl_Index_Type;
+ Lit_End : out Ghdl_Index_Type;
+ Unit_Pos : out Ghdl_Index_Type);
+
+ function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_B1;
+ function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_E8;
+ function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_E32;
+ function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32;
+ function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64;
+ function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64;
+ function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_I64;
+ function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access)
+ return Ghdl_I32;
+private
+ pragma Export (Ada, Ghdl_Value_B1, "__ghdl_value_b1");
+ pragma Export (C, Ghdl_Value_E8, "__ghdl_value_e8");
+ pragma Export (C, Ghdl_Value_E32, "__ghdl_value_e32");
+ pragma Export (C, Ghdl_Value_I32, "__ghdl_value_i32");
+ pragma Export (C, Ghdl_Value_I64, "__ghdl_value_i64");
+ pragma Export (C, Ghdl_Value_F64, "__ghdl_value_f64");
+ pragma Export (C, Ghdl_Value_P64, "__ghdl_value_p64");
+ pragma Export (C, Ghdl_Value_P32, "__ghdl_value_p32");
+end Grt.Values;
diff --git a/src/translate/grt/grt-vcd.adb b/src/translate/grt/grt-vcd.adb
new file mode 100644
index 000000000..d4a9ea066
--- /dev/null
+++ b/src/translate/grt/grt-vcd.adb
@@ -0,0 +1,845 @@
+-- GHDL Run Time (GRT) - VCD generator.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Interfaces;
+with Grt.Stdio; use Grt.Stdio;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Errors; use Grt.Errors;
+with Grt.Signals; use Grt.Signals;
+with Grt.Table;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.C; use Grt.C;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Rtis_Types; use Grt.Rtis_Types;
+with Grt.Vstrings;
+pragma Elaborate_All (Grt.Table);
+
+package body Grt.Vcd is
+ -- If TRUE, put $date in vcd file.
+ -- Can be set to FALSE to make vcd comparaison easier.
+ Flag_Vcd_Date : Boolean := True;
+
+ Stream : FILEs;
+
+ procedure My_Vcd_Put (Str : String)
+ is
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (Str'Address, Str'Length, 1, Stream);
+ end My_Vcd_Put;
+
+ procedure My_Vcd_Putc (C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := fputc (Character'Pos (C), Stream);
+ end My_Vcd_Putc;
+
+ procedure My_Vcd_Close is
+ begin
+ fclose (Stream);
+ Stream := NULL_Stream;
+ end My_Vcd_Close;
+
+ -- VCD filename.
+ -- Stream corresponding to the VCD filename.
+ --Vcd_Stream : FILEs;
+
+ -- Index type of the table of vcd variables to dump.
+ type Vcd_Index_Type is new Integer;
+
+ -- Return TRUE if OPT is an option for VCD.
+ function Vcd_Option (Opt : String) return Boolean
+ is
+ F : constant Natural := Opt'First;
+ Mode : constant String := "wt" & NUL;
+ Vcd_Filename : String_Access;
+ begin
+ if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vcd" then
+ return False;
+ end if;
+ if Opt'Length = 12 and then Opt (F + 5 .. F + 11) = "-nodate" then
+ Flag_Vcd_Date := False;
+ return True;
+ end if;
+ if Opt'Length > 6 and then Opt (F + 5) = '=' then
+ if Vcd_Close /= null then
+ Error ("--vcd: file already set");
+ return True;
+ end if;
+
+ -- Add an extra NUL character.
+ Vcd_Filename := new String (1 .. Opt'Length - 6 + 1);
+ Vcd_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last);
+ Vcd_Filename (Vcd_Filename'Last) := NUL;
+
+ if Vcd_Filename.all = "-" & NUL then
+ Stream := stdout;
+ else
+ Stream := fopen (Vcd_Filename.all'Address, Mode'Address);
+ if Stream = NULL_Stream then
+ Error_C ("cannot open ");
+ Error_E (Vcd_Filename (Vcd_Filename'First
+ .. Vcd_Filename'Last - 1));
+ return True;
+ end if;
+ end if;
+ Vcd_Putc := My_Vcd_Putc'Access;
+ Vcd_Put := My_Vcd_Put'Access;
+ Vcd_Close := My_Vcd_Close'Access;
+ return True;
+ else
+ return False;
+ end if;
+ end Vcd_Option;
+
+ procedure Vcd_Help is
+ begin
+ Put_Line (" --vcd=FILENAME dump signal values into a VCD file");
+ Put_Line (" --vcd-nodate do not write date in VCD file");
+ end Vcd_Help;
+
+ procedure Vcd_Newline is
+ begin
+ Vcd_Putc (Nl);
+ end Vcd_Newline;
+
+ procedure Vcd_Putline (Str : String) is
+ begin
+ Vcd_Put (Str);
+ Vcd_Newline;
+ end Vcd_Putline;
+
+-- procedure Vcd_Put (Str : Ghdl_Str_Len_Type)
+-- is
+-- begin
+-- Put_Str_Len (Vcd_Stream, Str);
+-- end Vcd_Put;
+
+ procedure Vcd_Put_I32 (V : Ghdl_I32)
+ is
+ Str : String (1 .. 11);
+ First : Natural;
+ begin
+ Vstrings.To_String (Str, First, V);
+ Vcd_Put (Str (First .. Str'Last));
+ end Vcd_Put_I32;
+
+ procedure Vcd_Put_Idcode (N : Vcd_Index_Type)
+ is
+ Str : String (1 .. 8);
+ V, R : Vcd_Index_Type;
+ L : Natural;
+ begin
+ L := 0;
+ V := N;
+ loop
+ R := V mod 93;
+ V := V / 93;
+ L := L + 1;
+ Str (L) := Character'Val (33 + R);
+ exit when V = 0;
+ end loop;
+ Vcd_Put (Str (1 .. L));
+ end Vcd_Put_Idcode;
+
+ procedure Vcd_Put_Name (Obj : VhpiHandleT)
+ is
+ Name : String (1 .. 128);
+ Name_Len : Integer;
+ begin
+ Vhpi_Get_Str (VhpiNameP, Obj, Name, Name_Len);
+ if Name_Len <= Name'Last then
+ Vcd_Put (Name (1 .. Name_Len));
+ else
+ -- Truncate.
+ Vcd_Put (Name);
+ end if;
+ end Vcd_Put_Name;
+
+ procedure Vcd_Put_End is
+ begin
+ Vcd_Putline ("$end");
+ end Vcd_Put_End;
+
+ -- Called before elaboration.
+ procedure Vcd_Init
+ is
+ begin
+ if Vcd_Close = null then
+ return;
+ end if;
+ if Flag_Vcd_Date then
+ Vcd_Putline ("$date");
+ Vcd_Put (" ");
+ declare
+ type time_t is new Interfaces.Integer_64;
+ Cur_Time : time_t;
+
+ function time (Addr : Address) return time_t;
+ pragma Import (C, time);
+
+ function ctime (Timep: Address) return Ghdl_C_String;
+ pragma Import (C, ctime);
+
+ Ct : Ghdl_C_String;
+ begin
+ Cur_Time := time (Null_Address);
+ Ct := ctime (Cur_Time'Address);
+ for I in Positive loop
+ exit when Ct (I) = NUL;
+ Vcd_Putc (Ct (I));
+ end loop;
+ -- Note: ctime already append a LF.
+ end;
+ Vcd_Put_End;
+ end if;
+ Vcd_Putline ("$version");
+ Vcd_Putline (" GHDL v0");
+ Vcd_Put_End;
+ Vcd_Putline ("$timescale");
+ Vcd_Putline (" 1 fs");
+ Vcd_Put_End;
+ end Vcd_Init;
+
+ package Vcd_Table is new Grt.Table
+ (Table_Component_Type => Verilog_Wire_Info,
+ Table_Index_Type => Vcd_Index_Type,
+ Table_Low_Bound => 0,
+ Table_Initial => 32);
+
+ procedure Avhpi_Error (Err : AvhpiErrorT)
+ is
+ pragma Unreferenced (Err);
+ begin
+ Put_Line ("Vcd.Avhpi_Error!");
+ null;
+ end Avhpi_Error;
+
+ function Rti_To_Vcd_Kind (Rti : Ghdl_Rti_Access) return Vcd_Var_Kind
+ is
+ Rti1 : Ghdl_Rti_Access;
+ begin
+ if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then
+ Rti1 := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype;
+ else
+ Rti1 := Rti;
+ end if;
+
+ if Rti1 = Std_Standard_Boolean_RTI_Ptr then
+ return Vcd_Bool;
+ end if;
+ if Rti1 = Std_Standard_Bit_RTI_Ptr then
+ return Vcd_Bit;
+ end if;
+ if Rti1 = Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr then
+ return Vcd_Stdlogic;
+ end if;
+ if Rti1.Kind = Ghdl_Rtik_Type_I32 then
+ return Vcd_Integer32;
+ end if;
+ if Rti1.Kind = Ghdl_Rtik_Type_F64 then
+ return Vcd_Float64;
+ end if;
+ return Vcd_Bad;
+ end Rti_To_Vcd_Kind;
+
+ function Rti_To_Vcd_Kind (Rti : Ghdl_Rtin_Type_Array_Acc)
+ return Vcd_Var_Kind
+ is
+ It : Ghdl_Rti_Access;
+ begin
+ if Rti.Nbr_Dim /= 1 then
+ return Vcd_Bad;
+ end if;
+ It := Rti.Indexes (0);
+ if It.Kind /= Ghdl_Rtik_Subtype_Scalar then
+ return Vcd_Bad;
+ end if;
+ if To_Ghdl_Rtin_Subtype_Scalar_Acc (It).Basetype.Kind
+ /= Ghdl_Rtik_Type_I32
+ then
+ return Vcd_Bad;
+ end if;
+ case Rti_To_Vcd_Kind (Rti.Element) is
+ when Vcd_Bit =>
+ return Vcd_Bitvector;
+ when Vcd_Stdlogic =>
+ return Vcd_Stdlogic_Vector;
+ when others =>
+ return Vcd_Bad;
+ end case;
+ end Rti_To_Vcd_Kind;
+
+ procedure Get_Verilog_Wire (Sig : VhpiHandleT; Info : out Verilog_Wire_Info)
+ is
+ Sig_Type : VhpiHandleT;
+ Rti : Ghdl_Rti_Access;
+ Error : AvhpiErrorT;
+ Sig_Addr : Address;
+ begin
+ -- Extract type of the signal.
+ Vhpi_Handle (VhpiSubtype, Sig, Sig_Type, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ Rti := Avhpi_Get_Rti (Sig_Type);
+ Sig_Addr := Avhpi_Get_Address (Sig);
+ Info.Kind := Vcd_Bad;
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Subtype_Scalar =>
+ Info.Kind := Rti_To_Vcd_Kind (Rti);
+ Info.Addr := Sig_Addr;
+ Info.Irange := null;
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ St : Ghdl_Rtin_Subtype_Array_Acc;
+ begin
+ St := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Info.Kind := Rti_To_Vcd_Kind (St.Basetype);
+ Info.Addr := Sig_Addr;
+ Info.Irange := To_Ghdl_Range_Ptr
+ (Loc_To_Addr (St.Common.Depth, St.Bounds,
+ Avhpi_Get_Context (Sig)));
+ end;
+ when Ghdl_Rtik_Type_Array =>
+ declare
+ Uc : Ghdl_Uc_Array_Acc;
+ begin
+ Info.Kind := Rti_To_Vcd_Kind
+ (To_Ghdl_Rtin_Type_Array_Acc (Rti));
+ Uc := To_Ghdl_Uc_Array_Acc (Sig_Addr);
+ Info.Addr := Uc.Base;
+ Info.Irange := To_Ghdl_Range_Ptr (Uc.Bounds);
+ end;
+ when others =>
+ Info.Irange := null;
+ end case;
+
+ -- Do not allow null-array.
+ if Info.Irange /= null and then Info.Irange.I32.Len = 0 then
+ Info.Kind := Vcd_Bad;
+ Info.Irange := null;
+ return;
+ end if;
+
+ if Vhpi_Get_Kind (Sig) = VhpiPortDeclK then
+ case Vhpi_Get_Mode (Sig) is
+ when VhpiInMode
+ | VhpiInoutMode
+ | VhpiBufferMode
+ | VhpiLinkageMode =>
+ Info.Val := Vcd_Effective;
+ when VhpiOutMode =>
+ Info.Val := Vcd_Driving;
+ when VhpiErrorMode =>
+ Info.Kind := Vcd_Bad;
+ end case;
+ else
+ Info.Val := Vcd_Effective;
+ end if;
+ end Get_Verilog_Wire;
+
+ procedure Add_Signal (Sig : VhpiHandleT)
+ is
+ N : Vcd_Index_Type;
+ Vcd_El : Verilog_Wire_Info;
+ begin
+ Get_Verilog_Wire (Sig, Vcd_El);
+
+ if Vcd_El.Kind = Vcd_Bad then
+ Vcd_Put ("$comment ");
+ Vcd_Put_Name (Sig);
+ Vcd_Put (" is not handled");
+ --Vcd_Put (Ghdl_Type_Kind'Image (Desc.Kind));
+ Vcd_Putc (' ');
+ Vcd_Put_End;
+ return;
+ else
+ Vcd_Table.Increment_Last;
+ N := Vcd_Table.Last;
+
+ Vcd_Table.Table (N) := Vcd_El;
+ Vcd_Put ("$var ");
+ case Vcd_El.Kind is
+ when Vcd_Integer32 =>
+ Vcd_Put ("integer 32");
+ when Vcd_Float64 =>
+ Vcd_Put ("real 64");
+ when Vcd_Bool
+ | Vcd_Bit
+ | Vcd_Stdlogic =>
+ Vcd_Put ("reg 1");
+ when Vcd_Bitvector
+ | Vcd_Stdlogic_Vector =>
+ Vcd_Put ("reg ");
+ Vcd_Put_I32 (Ghdl_I32 (Vcd_El.Irange.I32.Len));
+ when Vcd_Bad =>
+ null;
+ end case;
+ Vcd_Putc (' ');
+ Vcd_Put_Idcode (N);
+ Vcd_Putc (' ');
+ Vcd_Put_Name (Sig);
+ if Vcd_El.Irange /= null then
+ Vcd_Putc ('[');
+ Vcd_Put_I32 (Vcd_El.Irange.I32.Left);
+ Vcd_Putc (':');
+ Vcd_Put_I32 (Vcd_El.Irange.I32.Right);
+ Vcd_Putc (']');
+ end if;
+ Vcd_Putc (' ');
+ Vcd_Put_End;
+ if Boolean'(False) then
+ Vcd_Put ("$comment ");
+ Vcd_Put_Name (Sig);
+ Vcd_Put (" is ");
+ case Vcd_El.Val is
+ when Vcd_Effective =>
+ Vcd_Put ("effective ");
+ when Vcd_Driving =>
+ Vcd_Put ("driving ");
+ end case;
+ Vcd_Put_End;
+ end if;
+ end if;
+ end Add_Signal;
+
+ procedure Vcd_Put_Hierarchy (Inst : VhpiHandleT)
+ is
+ Decl_It : VhpiHandleT;
+ Decl : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ -- Extract signals.
+ loop
+ Vhpi_Scan (Decl_It, Decl, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ Add_Signal (Decl);
+ when others =>
+ null;
+ end case;
+ end loop;
+
+ -- Extract sub-scopes.
+ Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ loop
+ Vhpi_Scan (Decl_It, Decl, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiIfGenerateK
+ | VhpiForGenerateK
+ | VhpiBlockStmtK
+ | VhpiCompInstStmtK =>
+ Vcd_Put ("$scope module ");
+ Vcd_Put_Name (Decl);
+ Vcd_Putc (' ');
+ Vcd_Put_End;
+ Vcd_Put_Hierarchy (Decl);
+ Vcd_Put ("$upscope ");
+ Vcd_Put_End;
+ when others =>
+ null;
+ end case;
+ end loop;
+
+ end Vcd_Put_Hierarchy;
+
+ procedure Vcd_Put_Bit (V : Ghdl_B1)
+ is
+ C : Character;
+ begin
+ if V then
+ C := '1';
+ else
+ C := '0';
+ end if;
+ Vcd_Putc (C);
+ end Vcd_Put_Bit;
+
+ procedure Vcd_Put_Stdlogic (V : Ghdl_E8)
+ is
+ type Map_Type is array (Ghdl_E8 range 0 .. 8) of Character;
+ -- "UX01ZWLH-"
+ -- Map_Vlg : constant Map_Type := "xx01zz01x";
+ Map_Std : constant Map_Type := "UX01ZWLH-";
+ begin
+ if V not in Map_Type'Range then
+ Vcd_Putc ('?');
+ else
+ Vcd_Putc (Map_Std (V));
+ end if;
+ end Vcd_Put_Stdlogic;
+
+ procedure Vcd_Put_Integer32 (V : Ghdl_U32)
+ is
+ Val : Ghdl_U32;
+ N : Natural;
+ begin
+ Val := V;
+ N := 32;
+ while N > 1 loop
+ exit when (Val and 16#8000_0000#) /= 0;
+ Val := Val * 2;
+ N := N - 1;
+ end loop;
+
+ while N > 0 loop
+ if (Val and 16#8000_0000#) /= 0 then
+ Vcd_Putc ('1');
+ else
+ Vcd_Putc ('0');
+ end if;
+ Val := Val * 2;
+ N := N - 1;
+ end loop;
+ end Vcd_Put_Integer32;
+
+ -- Using the floor attribute of Ghdl_F64 will result on a link error while
+ -- trying to simulate a design. So it was needed to create a floor function
+ function Digit_Floor (V : Ghdl_F64) return Ghdl_I32
+ is
+ Var : Ghdl_I32;
+ begin
+ -- V is always positive here and only of interest when it is a digit
+ if V > 10.0 then
+ return -1;
+ else
+ Var := Ghdl_I32(V-0.5); --Ghdl_I32 rounds to the nearest integer
+ -- The rounding made by Ghdl_I32 is asymetric :
+ -- 0.5 will be rounded to 1, but -0.5 to -1 instead of 0
+ if Var > 0 then
+ return Var;
+ else
+ return 0;
+ end if;
+ end if;
+ end Digit_Floor;
+
+ procedure Vcd_Put_Float64 (V : Ghdl_F64)
+ is
+ Val_tmp, Fact : Ghdl_F64;
+ Digit, Exp, Delta_Exp, N_Exp : Ghdl_I32;
+ --
+ begin
+ Exp := 0;
+ if V /= V then
+ Vcd_Put("NaN");
+ return;
+ end if;
+ if V < 0.0 then
+ Vcd_Putc ('-');
+ Val_tmp := -V;
+ elsif V = 0.0 then
+ Vcd_Put("0.0");
+ return;
+ else
+ Val_tmp := V;
+ end if;
+ if Val_tmp > Ghdl_F64'Last then
+ Vcd_Put("Inf");
+ return;
+ elsif Val_tmp < 1.0 then
+ Fact := 10.0;
+ Delta_Exp := -1;
+ else
+ Fact := 0.1;
+ Delta_Exp := 1;
+ end if;
+
+ -- Seek the first digit
+ loop
+ Digit := Digit_Floor(Val_tmp);
+ if Digit > 0 then
+ exit;
+ end if;
+ Exp := Exp + Delta_Exp;
+ Val_tmp := Val_tmp * Fact;
+ end loop;
+ Vcd_Putc(Character'Val(Digit + 48));
+ Vcd_Putc('.');
+ for i in 0..4 loop -- 5 digits displayed after the point
+ Val_tmp := abs(Val_tmp - Ghdl_F64(Digit))*10.0;
+ Digit := Digit_Floor(Val_tmp);
+ Vcd_Putc(Character'Val(Digit + 48));
+ end loop;
+ Vcd_Putc('E');
+ if Exp < 0 then
+ Vcd_Putc('-');
+ Exp := -Exp;
+ end if;
+ N_Exp := 100;
+ while N_Exp > 0 loop
+ Vcd_Putc(Character'Val(Exp/N_Exp + 48));
+ Exp := Exp mod N_Exp;
+ N_Exp := N_Exp/10;
+ end loop;
+ end Vcd_Put_Float64;
+
+ procedure Vcd_Put_Var (I : Vcd_Index_Type)
+ is
+ Addr : Address;
+ V : Verilog_Wire_Info renames Vcd_Table.Table (I);
+ Len : Ghdl_Index_Type;
+ begin
+ Addr := V.Addr;
+ if V.Irange = null then
+ Len := 1;
+ else
+ Len := V.Irange.I32.Len;
+ end if;
+ case V.Val is
+ when Vcd_Effective =>
+ case V.Kind is
+ when Vcd_Bit
+ | Vcd_Bool =>
+ Vcd_Put_Bit (To_Signal_Arr_Ptr (Addr)(0).Value.B1);
+ when Vcd_Stdlogic =>
+ Vcd_Put_Stdlogic (To_Signal_Arr_Ptr (Addr)(0).Value.E8);
+ when Vcd_Integer32 =>
+ Vcd_Putc ('b');
+ Vcd_Put_Integer32 (To_Signal_Arr_Ptr (Addr)(0).Value.E32);
+ Vcd_Putc (' ');
+ when Vcd_Float64 =>
+ Vcd_Putc ('r');
+ Vcd_Put_Float64 (To_Signal_Arr_Ptr (Addr)(0).Value.F64);
+ Vcd_Putc (' ');
+ when Vcd_Bitvector =>
+ Vcd_Putc ('b');
+ for J in 0 .. Len - 1 loop
+ Vcd_Put_Bit (To_Signal_Arr_Ptr (Addr)(J).Value.B1);
+ end loop;
+ Vcd_Putc (' ');
+ when Vcd_Stdlogic_Vector =>
+ Vcd_Putc ('b');
+ for J in 0 .. Len - 1 loop
+ Vcd_Put_Stdlogic (To_Signal_Arr_Ptr (Addr)(J).Value.E8);
+ end loop;
+ Vcd_Putc (' ');
+ when Vcd_Bad =>
+ null;
+ end case;
+ when Vcd_Driving =>
+ case V.Kind is
+ when Vcd_Bit
+ | Vcd_Bool =>
+ Vcd_Put_Bit
+ (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.B1);
+ when Vcd_Stdlogic =>
+ Vcd_Put_Stdlogic
+ (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.E8);
+ when Vcd_Integer32 =>
+ Vcd_Putc ('b');
+ Vcd_Put_Integer32
+ (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.E32);
+ Vcd_Putc (' ');
+ when Vcd_Float64 =>
+ Vcd_Putc ('r');
+ Vcd_Put_Float64 (To_Signal_Arr_Ptr (Addr)(0)
+ .Driving_Value.F64);
+ Vcd_Putc (' ');
+ when Vcd_Bitvector =>
+ Vcd_Putc ('b');
+ for J in 0 .. Len - 1 loop
+ Vcd_Put_Bit
+ (To_Signal_Arr_Ptr (Addr)(J).Driving_Value.B1);
+ end loop;
+ Vcd_Putc (' ');
+ when Vcd_Stdlogic_Vector =>
+ Vcd_Putc ('b');
+ for J in 0 .. Len - 1 loop
+ Vcd_Put_Stdlogic
+ (To_Signal_Arr_Ptr (Addr)(J).Driving_Value.E8);
+ end loop;
+ Vcd_Putc (' ');
+ when Vcd_Bad =>
+ null;
+ end case;
+ end case;
+ Vcd_Put_Idcode (I);
+ Vcd_Newline;
+ end Vcd_Put_Var;
+
+ function Verilog_Wire_Changed (Info : Verilog_Wire_Info;
+ Last : Std_Time)
+ return Boolean
+ is
+ Len : Ghdl_Index_Type;
+ begin
+ if Info.Irange = null then
+ Len := 1;
+ else
+ Len := Info.Irange.I32.Len;
+ end if;
+
+ case Info.Val is
+ when Vcd_Effective =>
+ case Info.Kind is
+ when Vcd_Bit
+ | Vcd_Bool
+ | Vcd_Stdlogic
+ | Vcd_Bitvector
+ | Vcd_Stdlogic_Vector
+ | Vcd_Integer32
+ | Vcd_Float64 =>
+ for J in 0 .. Len - 1 loop
+ if To_Signal_Arr_Ptr (Info.Addr)(J).Last_Event = Last then
+ return True;
+ end if;
+ end loop;
+ when Vcd_Bad =>
+ null;
+ end case;
+ when Vcd_Driving =>
+ case Info.Kind is
+ when Vcd_Bit
+ | Vcd_Bool
+ | Vcd_Stdlogic
+ | Vcd_Bitvector
+ | Vcd_Stdlogic_Vector
+ | Vcd_Integer32
+ | Vcd_Float64 =>
+ for J in 0 .. Len - 1 loop
+ if To_Signal_Arr_Ptr (Info.Addr)(J).Last_Active = Last
+ then
+ return True;
+ end if;
+ end loop;
+ when Vcd_Bad =>
+ null;
+ end case;
+ end case;
+ return False;
+ end Verilog_Wire_Changed;
+
+ procedure Vcd_Put_Time
+ is
+ Str : String (1 .. 21);
+ First : Natural;
+ begin
+ Vcd_Putc ('#');
+ Vstrings.To_String (Str, First, Ghdl_I64 (Cycle_Time));
+ Vcd_Put (Str (First .. Str'Last));
+ Vcd_Newline;
+ end Vcd_Put_Time;
+
+ procedure Vcd_Cycle;
+
+ -- Called after elaboration.
+ procedure Vcd_Start
+ is
+ Root : VhpiHandleT;
+ begin
+ -- Do nothing if there is no VCD file to generate.
+ if Vcd_Close = null then
+ return;
+ end if;
+
+ -- Be sure the RTI of std_ulogic is set.
+ Search_Types_RTI;
+
+ -- Put hierarchy.
+ Get_Root_Inst (Root);
+ Vcd_Put_Hierarchy (Root);
+
+ -- End of header.
+ Vcd_Put ("$enddefinitions ");
+ Vcd_Put_End;
+
+ Register_Cycle_Hook (Vcd_Cycle'Access);
+ end Vcd_Start;
+
+ -- Called before each non delta cycle.
+ procedure Vcd_Cycle is
+ begin
+ -- Disp values.
+ Vcd_Put_Time;
+ if Cycle_Time = 0 then
+ -- Disp all values.
+ for I in Vcd_Table.First .. Vcd_Table.Last loop
+ Vcd_Put_Var (I);
+ end loop;
+ else
+ -- Disp only values changed.
+ for I in Vcd_Table.First .. Vcd_Table.Last loop
+ if Verilog_Wire_Changed (Vcd_Table.Table (I), Cycle_Time) then
+ Vcd_Put_Var (I);
+ end if;
+ end loop;
+ end if;
+ end Vcd_Cycle;
+
+ -- Called at the end of the simulation.
+ procedure Vcd_End is
+ begin
+ if Vcd_Close /= null then
+ Vcd_Close.all;
+ end if;
+ end Vcd_End;
+
+ Vcd_Hooks : aliased constant Hooks_Type :=
+ (Option => Vcd_Option'Access,
+ Help => Vcd_Help'Access,
+ Init => Vcd_Init'Access,
+ Start => Vcd_Start'Access,
+ Finish => Vcd_End'Access);
+
+ procedure Register is
+ begin
+ Register_Hooks (Vcd_Hooks'Access);
+ end Register;
+end Grt.Vcd;
diff --git a/src/translate/grt/grt-vcd.ads b/src/translate/grt/grt-vcd.ads
new file mode 100644
index 000000000..ed015af80
--- /dev/null
+++ b/src/translate/grt/grt-vcd.ads
@@ -0,0 +1,65 @@
+-- GHDL Run Time (GRT) - VCD generator.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System; use System;
+with Grt.Types; use Grt.Types;
+with Grt.Avhpi; use Grt.Avhpi;
+
+package Grt.Vcd is
+ -- Abstract type for IO.
+ type Vcd_Put_Acc is access procedure (Str : String);
+ type Vcd_Putc_Acc is access procedure (C : Character);
+ type Vcd_Close_Acc is access procedure;
+
+ Vcd_Put : Vcd_Put_Acc;
+ Vcd_Putc : Vcd_Putc_Acc;
+ Vcd_Close : Vcd_Close_Acc;
+
+ type Vcd_Var_Kind is (Vcd_Bad,
+ Vcd_Bool,
+ Vcd_Integer32,
+ Vcd_Float64,
+ Vcd_Bit, Vcd_Stdlogic,
+ Vcd_Bitvector, Vcd_Stdlogic_Vector);
+
+ -- Which value to be displayed: effective or driving (for out signals).
+ type Vcd_Value_Kind is (Vcd_Effective, Vcd_Driving);
+
+ type Verilog_Wire_Info is record
+ Addr : Address;
+ Irange : Ghdl_Range_Ptr;
+ Kind : Vcd_Var_Kind;
+ Val : Vcd_Value_Kind;
+ end record;
+
+ procedure Get_Verilog_Wire (Sig : VhpiHandleT;
+ Info : out Verilog_Wire_Info);
+
+ -- Return TRUE if last change time of the wire described by INFO is LAST.
+ function Verilog_Wire_Changed (Info : Verilog_Wire_Info;
+ Last : Std_Time)
+ return Boolean;
+
+ procedure Register;
+end Grt.Vcd;
diff --git a/src/translate/grt/grt-vcdz.adb b/src/translate/grt/grt-vcdz.adb
new file mode 100644
index 000000000..8e1ceb6f1
--- /dev/null
+++ b/src/translate/grt/grt-vcdz.adb
@@ -0,0 +1,116 @@
+-- GHDL Run Time (GRT) - VCD .gz module.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Vcd; use Grt.Vcd;
+with Grt.Errors; use Grt.Errors;
+with Grt.Types; use Grt.Types;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Zlib; use Grt.Zlib;
+with Grt.C; use Grt.C;
+
+package body Grt.Vcdz is
+ Stream : gzFile;
+
+ procedure My_Vcd_Put (Str : String)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := gzwrite (Stream, Str'Address, Str'Length);
+ end My_Vcd_Put;
+
+ procedure My_Vcd_Putc (C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := gzputc (Stream, Character'Pos (C));
+ end My_Vcd_Putc;
+
+ procedure My_Vcd_Close is
+ begin
+ gzclose (Stream);
+ Stream := NULL_gzFile;
+ end My_Vcd_Close;
+
+ -- VCD filename.
+
+ -- Return TRUE if OPT is an option for VCD.
+ function Vcdz_Option (Opt : String) return Boolean
+ is
+ F : constant Natural := Opt'First;
+ Vcd_Filename : String_Access := null;
+ Mode : constant String := "wb" & NUL;
+ begin
+ if Opt'Length < 7 or else Opt (F .. F + 6) /= "--vcdgz" then
+ return False;
+ end if;
+ if Opt'Length > 7 and then Opt (F + 7) = '=' then
+ if Vcd_Close /= null then
+ Error ("--vcdgz: file already set");
+ return True;
+ end if;
+
+ -- Add an extra NUL character.
+ Vcd_Filename := new String (1 .. Opt'Length - 8 + 1);
+ Vcd_Filename (1 .. Opt'Length - 8) := Opt (F + 8 .. Opt'Last);
+ Vcd_Filename (Vcd_Filename'Last) := NUL;
+
+ Stream := gzopen (Vcd_Filename.all'Address, Mode'Address);
+ if Stream = NULL_gzFile then
+ Error_C ("cannot open ");
+ Error_E (Vcd_Filename (Vcd_Filename'First
+ .. Vcd_Filename'Last - 1));
+ return True;
+ end if;
+ Vcd_Putc := My_Vcd_Putc'Access;
+ Vcd_Put := My_Vcd_Put'Access;
+ Vcd_Close := My_Vcd_Close'Access;
+ return True;
+ else
+ return False;
+ end if;
+ end Vcdz_Option;
+
+ procedure Vcdz_Help is
+ begin
+ Put_Line
+ (" --vcdgz=FILENAME dump signal values into a VCD gzip'ed file");
+ end Vcdz_Help;
+
+ Vcdz_Hooks : aliased constant Hooks_Type :=
+ (Option => Vcdz_Option'Access,
+ Help => Vcdz_Help'Access,
+ Init => Proc_Hook_Nil'Access,
+ Start => Proc_Hook_Nil'Access,
+ Finish => Proc_Hook_Nil'Access);
+
+ procedure Register is
+ begin
+ Register_Hooks (Vcdz_Hooks'Access);
+ end Register;
+end Grt.Vcdz;
diff --git a/src/translate/grt/grt-vcdz.ads b/src/translate/grt/grt-vcdz.ads
new file mode 100644
index 000000000..aba61c222
--- /dev/null
+++ b/src/translate/grt/grt-vcdz.ads
@@ -0,0 +1,28 @@
+-- GHDL Run Time (GRT) - VCD .gz module.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+package Grt.Vcdz is
+ procedure Register;
+end Grt.Vcdz;
diff --git a/src/translate/grt/grt-vital_annotate.adb b/src/translate/grt/grt-vital_annotate.adb
new file mode 100644
index 000000000..93ecb8119
--- /dev/null
+++ b/src/translate/grt/grt-vital_annotate.adb
@@ -0,0 +1,688 @@
+-- GHDL Run Time (GRT) - VITAL annotator.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Types; use Grt.Types;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Options;
+with Grt.Avhpi; use Grt.Avhpi;
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Vital_Annotate is
+ -- Point of the annotation.
+ Sdf_Top : VhpiHandleT;
+
+ -- Instance being annotated.
+ Sdf_Inst : VhpiHandleT;
+
+ Flag_Dump : Boolean := False;
+ Flag_Verbose : constant Boolean := False;
+
+ function Name_Compare (Handle : VhpiHandleT;
+ Name : String;
+ Property : VhpiStrPropertyT := VhpiNameP)
+ return Boolean
+ is
+ Obj_Name : String (1 .. Name'Length);
+ Len : Natural;
+ begin
+ Vhpi_Get_Str (Property, Handle, Obj_Name, Len);
+ if Len = Name'Length and then Obj_Name = Name then
+ return True;
+ else
+ return False;
+ end if;
+ end Name_Compare;
+
+ -- Note: RES may alias CUR.
+ procedure Find_Instance (Cur : VhpiHandleT;
+ Res : out VhpiHandleT;
+ Name : String;
+ Ok : out Boolean)
+ is
+ Error : AvhpiErrorT;
+ It : VhpiHandleT;
+ begin
+ Ok := False;
+ Vhpi_Iterator (VhpiInternalRegions, Cur, It, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ loop
+ Vhpi_Scan (It, Res, Error);
+ exit when Error /= AvhpiErrorOk;
+ if Name_Compare (Res, Name) then
+ Ok := True;
+ return;
+ end if;
+ end loop;
+ return;
+-- Put ("find instance: ");
+-- Put (Name);
+-- New_Line;
+ end Find_Instance;
+
+ procedure Find_Generic (Gen_Name : String;
+ Gen_Handle : out VhpiHandleT;
+ Port1_Name : String;
+ Port1_Handle : out VhpiHandleT;
+ Port2_Name : String;
+ Port2_Handle : out VhpiHandleT)
+ is
+ Error : AvhpiErrorT;
+ It : VhpiHandleT;
+ Decl : VhpiHandleT;
+ begin
+ Gen_Handle := Null_Handle;
+ Port1_Handle := Null_Handle;
+ Port2_Handle := Null_Handle;
+
+ Vhpi_Iterator (VhpiDecls, Sdf_Inst, It, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+
+ -- Look for the generic.
+ loop
+ Vhpi_Scan (It, Decl, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ exit when Vhpi_Get_Kind (Decl) /= VhpiGenericDeclK;
+ if Name_Compare (Decl, Gen_Name) then
+ Gen_Handle := Decl;
+ exit;
+ end if;
+ end loop;
+
+ -- Skip generics.
+ while Vhpi_Get_Kind (Decl) = VhpiGenericDeclK loop
+ Vhpi_Scan (It, Decl, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ end loop;
+
+ -- Look for ports.
+ loop
+ exit when Vhpi_Get_Kind (Decl) /= VhpiPortDeclK;
+ if Name_Compare (Decl, Port1_Name) then
+ Port1_Handle := Decl;
+ exit when Port2_Name'Length = 0;
+ end if;
+ if Port2_Name'Length > 0
+ and then Name_Compare (Decl, Port2_Name)
+ then
+ Port2_Handle := Decl;
+ exit when Vhpi_Get_Kind (Port1_Handle) /= VhpiUndefined;
+ end if;
+ Vhpi_Scan (It, Decl, Error);
+ if Error /= AvhpiErrorOk then
+ return;
+ end if;
+ end loop;
+
+ end Find_Generic;
+
+ procedure Sdf_Header (Context : Sdf_Context_Type)
+ is
+ begin
+ if Flag_Dump then
+ case Context.Version is
+ when Sdf_2_1 =>
+ Put ("found SDF file version 2.1");
+ when Sdf_Version_Unknown =>
+ Put ("found SDF file without version");
+ when Sdf_Version_Bad =>
+ Put ("found SDF file with unknown version");
+ end case;
+ New_Line;
+ end if;
+ end Sdf_Header;
+
+ procedure Sdf_Celltype (Context : Sdf_Context_Type)
+ is
+ begin
+ if Flag_Dump then
+ Put ("celltype: ");
+ Put (Context.Celltype (1 .. Context.Celltype_Len));
+ New_Line;
+ Put ("instance:");
+ return;
+ end if;
+ Sdf_Inst := Sdf_Top;
+ end Sdf_Celltype;
+
+ procedure Sdf_Instance (Context : in out Sdf_Context_Type;
+ Instance : String;
+ Status : out Boolean)
+ is
+ pragma Unreferenced (Context);
+ begin
+ if Flag_Dump then
+ Put (' ');
+ Put (Instance);
+ Status := True;
+ return;
+ end if;
+
+ Find_Instance (Sdf_Inst, Sdf_Inst, Instance, Status);
+ end Sdf_Instance;
+
+ procedure Sdf_Instance_End (Context : Sdf_Context_Type;
+ Status : out Boolean)
+ is
+ begin
+ if Flag_Dump then
+ Status := True;
+ New_Line;
+ return;
+ end if;
+ case Vhpi_Get_Kind (Sdf_Inst) is
+ when VhpiRootInstK =>
+ declare
+ Hdl : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ Status := False;
+ Vhpi_Handle (VhpiDesignUnit, Sdf_Inst, Hdl, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("VhpiDesignUnit");
+ return;
+ end if;
+ case Vhpi_Get_Kind (Hdl) is
+ when VhpiArchBodyK =>
+ Vhpi_Handle (VhpiPrimaryUnit, Hdl, Hdl, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("VhpiPrimaryUnit");
+ return;
+ end if;
+ when others =>
+ Internal_Error ("sdf_instance_end");
+ end case;
+ Status := Name_Compare
+ (Hdl, Context.Celltype (1 .. Context.Celltype_Len));
+ end;
+ when VhpiCompInstStmtK =>
+ Status := Name_Compare
+ (Sdf_Inst,
+ Context.Celltype (1 .. Context.Celltype_Len),
+ VhpiCompNameP);
+ when others =>
+ Status := False;
+ end case;
+ end Sdf_Instance_End;
+
+ VitalDelayType01 : VhpiHandleT;
+ VitalDelayType01Z : VhpiHandleT;
+ VitalDelayType01ZX : VhpiHandleT;
+ VitalDelayArrayType01 : VhpiHandleT;
+ VitalDelayType : VhpiHandleT;
+ VitalDelayArrayType : VhpiHandleT;
+
+ type Map_Type is array (1 .. 12) of Natural;
+ Map_1 : constant Map_Type := (1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0);
+ Map_2 : constant Map_Type := (1, 2, 1, 1, 2, 2, 0, 0, 0, 0, 0, 0);
+ Map_3 : constant Map_Type := (1, 2, 3, 1, 3, 2, 0, 0, 0, 0, 0, 0);
+ Map_6 : constant Map_Type := (1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0, 0);
+ --Map_12 : constant Map_Type := (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12);
+
+ function Write_Td_Delay_Generic (Context : Sdf_Context_Type;
+ Gen : VhpiHandleT;
+ Nbr : Natural;
+ Map : Map_Type)
+ return Boolean
+ is
+ It : VhpiHandleT;
+ El : VhpiHandleT;
+ Error : AvhpiErrorT;
+ N : Natural;
+ begin
+ Vhpi_Iterator (VhpiIndexedNames, Gen, It, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiIndexedNames");
+ return False;
+ end if;
+ for I in 1 .. Nbr loop
+ Vhpi_Scan (It, El, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("scan on vhpiIndexedNames");
+ return False;
+ end if;
+ N := Map (I);
+ if Context.Timing_Set (N) then
+ if Vhpi_Put_Value (El, Context.Timing (N) * 1000) /= AvhpiErrorOk
+ then
+ Internal_Error ("vhpi_put_value");
+ return False;
+ end if;
+ end if;
+ end loop;
+ return True;
+ end Write_Td_Delay_Generic;
+
+ function Write_Td_Delay_Generic (Context : Sdf_Context_Type;
+ Gen : VhpiHandleT)
+ return Boolean
+ is
+ Gen_Basetype : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("write_td_delay_generic: vhpiBaseType");
+ return False;
+ end if;
+ if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) then
+ case Context.Timing_Nbr is
+ when 1 =>
+ return Write_Td_Delay_Generic (Context, Gen, 2, Map_1);
+ when 2 =>
+ return Write_Td_Delay_Generic (Context, Gen, 2, Map_2);
+ when others =>
+ Errors.Error
+ ("timing generic type mismatch SDF timing specification");
+ end case;
+ elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z) then
+ case Context.Timing_Nbr is
+ when 1 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_1);
+ when 2 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_2);
+ when 3 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_3);
+ when 6 =>
+ return Write_Td_Delay_Generic (Context, Gen, 6, Map_6);
+ when others =>
+ Errors.Error
+ ("timing generic type mismatch SDF timing specification");
+ end case;
+ elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType) then
+ if Vhpi_Put_Value (Gen, Context.Timing (1) * 1000) /= AvhpiErrorOk
+ then
+ Internal_Error ("vhpi_put_value (vitaldelaytype)");
+ else
+ return True;
+ end if;
+ else
+ Internal_Error ("write_td_delay_generic: unhandled generic type");
+ end if;
+ end Write_Td_Delay_Generic;
+
+ procedure Generic_Get_Bounds (Port : VhpiHandleT;
+ Left : out Ghdl_I32;
+ Len : out Ghdl_Index_Type;
+ Up : out Boolean)
+ is
+ Port_Type, Port_Range : VhpiHandleT;
+ Error : AvhpiErrorT;
+ Right : VhpiIntT;
+ begin
+ Vhpi_Handle (VhpiSubtype, Port, Port_Type, Error);
+ Left := 0;
+ Len := 0;
+ Up := True;
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiSubtype - port");
+ return;
+ end if;
+ Vhpi_Handle_By_Index (VhpiConstraints, Port_Type, 1, Port_Range, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiIndexConstraints - port");
+ return;
+ end if;
+ Vhpi_Get (VhpiLeftBoundP, Port_Range, Left, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiLeftBoundP - port");
+ return;
+ end if;
+ Vhpi_Get (VhpiRightBoundP, Port_Range, Right, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiRightBoundP - port");
+ return;
+ end if;
+ Vhpi_Get (VhpiIsUpP, Port_Range, Up, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiIsUpP - port");
+ return;
+ end if;
+ if Up then
+ Len := Ghdl_Index_Type (Right - Left) + 1;
+ else
+ Len := Ghdl_Index_Type (Left - Right) + 1;
+ end if;
+ end Generic_Get_Bounds;
+
+ procedure Sdf_Generic (Context : in out Sdf_Context_Type;
+ Name : String;
+ Ok : out Boolean)
+ is
+ Gen : VhpiHandleT;
+ Gen_Basetype : VhpiHandleT;
+ Port1, Port2 : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ if Flag_Dump then
+ Put ("generic: ");
+ Put (Name);
+ if Context.Timing_Nbr = 0 then
+ Put (' ');
+ Put_I64 (stdout, Context.Timing (1));
+ else
+ for I in 1 .. 12 loop
+ Put (' ');
+ if Context.Timing_Set (I) then
+ Put_I64 (stdout, Context.Timing (I));
+ else
+ Put ('?');
+ end if;
+ end loop;
+ end if;
+
+ New_Line;
+ Ok := True;
+ return;
+ end if;
+
+ Ok := False;
+
+ if Context.Port_Num = 1 then
+ Context.Ports (2).Name_Len := 0;
+ end if;
+ Find_Generic
+ (Name, Gen,
+ Context.Ports (1).Name (1 .. Context.Ports (1).Name_Len), Port1,
+ Context.Ports (2).Name (1 .. Context.Ports (2).Name_Len), Port2);
+ if Vhpi_Get_Kind (Gen) = VhpiUndefined
+ or else Vhpi_Get_Kind (Port1) = VhpiUndefined
+ or else (Context.Port_Num = 2
+ and then Vhpi_Get_Kind (Port2) = VhpiUndefined)
+ then
+ return;
+ end if;
+
+ -- Extract subtype.
+ Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiBaseType");
+ return;
+ end if;
+ if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01)
+ or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z)
+ or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01ZX)
+ then
+ Ok := Write_Td_Delay_Generic (Context, Gen);
+ elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType01)
+ or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType)
+ then
+ declare
+ Left_Gen, Left1, Left2 : Ghdl_I32;
+ Len_Gen, Len1, Len2 : Ghdl_Index_Type;
+ Up_Gen, Up1, Up2 : Boolean;
+ Pos : Ghdl_Index_Type;
+ Gen_El : VhpiHandleT;
+ begin
+ Generic_Get_Bounds (Gen, Left_Gen, Len_Gen, Up_Gen);
+ if Context.Port_Num >= 1
+ and then Context.Ports (1).L /= Invalid_Dnumber
+ then
+ Generic_Get_Bounds (Port1, Left1, Len1, Up1);
+ if Up1 then
+ Pos := Ghdl_Index_Type (Context.Ports (1).L - Left1);
+ else
+ Pos := Ghdl_Index_Type (Left1 - Context.Ports (1).L);
+ end if;
+ else
+ Pos := 0;
+ end if;
+ if Context.Port_Num >= 2
+ and then Context.Ports (2).L /= Invalid_Dnumber
+ then
+ Generic_Get_Bounds (Port2, Left2, Len2, Up2);
+ Pos := Pos * Len2;
+ if Up2 then
+ Pos := Pos + Ghdl_Index_Type (Context.Ports (2).L - Left2);
+ else
+ Pos := Pos + Ghdl_Index_Type (Left2 - Context.Ports (2).L);
+ end if;
+ end if;
+ Vhpi_Handle_By_Index
+ (VhpiIndexedNames, Gen, Integer (Pos), Gen_El, Error);
+ if Error /= AvhpiErrorOk then
+ Internal_Error ("vhpiIndexedNames - gen_el");
+ return;
+ end if;
+ Ok := Write_Td_Delay_Generic (Context, Gen_El);
+ end;
+ else
+ Errors.Error_C ("vital: unhandled generic type for generic ");
+ Errors.Error_E (Name);
+ end if;
+ end Sdf_Generic;
+
+
+ procedure Annotate (Arg : String)
+ is
+ S, E : Natural;
+ Ok : Boolean;
+ begin
+ if Flag_Verbose then
+ Put ("sdf annotate: ");
+ Put (Arg);
+ New_Line;
+ end if;
+
+ -- Find scope by name.
+ Get_Root_Inst (Sdf_Top);
+ E := Arg'First;
+ S := E;
+ L1: loop
+ -- Skip path separator.
+ while Arg (E) = '/' or Arg (E) = '.' loop
+ E := E + 1;
+ exit L1 when E > Arg'Last;
+ end loop;
+
+ exit L1 when E > Arg'Last or else Arg (E) = '=';
+
+ -- Instance element.
+ S := E;
+ while Arg (E) /= '=' and Arg (E) /= '.' and Arg (E) /= '/' loop
+ E := E + 1;
+ exit L1 when E > Arg'Last;
+ end loop;
+
+ -- Path element.
+ if E - 1 >= S then
+ Find_Instance (Sdf_Top, Sdf_Top, Arg (S .. E - 1), Ok);
+ if not Ok then
+ Error_C ("cannot find instance '");
+ Error_C (Arg (S .. E - 1));
+ Error_E ("' for sdf annotation");
+ return;
+ end if;
+ end if;
+ end loop L1;
+
+ -- start annotation.
+ if E >= Arg'Last or else Arg (E) /= '=' then
+ Error_C ("no filename in sdf option '");
+ Error_C (Arg);
+ Error_E ("'");
+ return;
+ end if;
+ if not Sdf.Parse_Sdf_File (Arg (E + 1 .. Arg'Last)) then
+ null;
+ end if;
+ end Annotate;
+
+ procedure Extract_Vital_Delay_Type
+ is
+ It : VhpiHandleT;
+ Pkg : VhpiHandleT;
+ Decl : VhpiHandleT;
+ Basetype : VhpiHandleT;
+ Status : AvhpiErrorT;
+ begin
+ Get_Package_Inst (It);
+ loop
+ Vhpi_Scan (It, Pkg, Status);
+ exit when Status /= AvhpiErrorOk;
+ exit when Name_Compare (Pkg, "vital_timing")
+ and then Name_Compare (Pkg, "ieee", VhpiLibLogicalNameP);
+ end loop;
+ if Status /= AvhpiErrorOk then
+ Error ("package ieee.vital_timing not found, SDF annotation aborted");
+ return;
+ end if;
+ Vhpi_Iterator (VhpiDecls, Pkg, It, Status);
+ if Status /= AvhpiErrorOk then
+ Error ("cannot iterate on vital_timing");
+ return;
+ end if;
+ loop
+ Vhpi_Scan (It, Decl, Status);
+ exit when Status /= AvhpiErrorOk;
+ if Vhpi_Get_Kind (Decl) = VhpiSubtypeDeclK
+ or else Vhpi_Get_Kind (Decl) = VhpiArrayTypeDeclK
+ then
+ Vhpi_Handle (VhpiBaseType, Decl, Basetype, Status);
+ if Status = AvhpiErrorOk then
+ if Name_Compare (Decl, "vitaldelaytype01") then
+ VitalDelayType01 := Basetype;
+ elsif Name_Compare (Decl, "vitaldelaytype01z") then
+ VitalDelayType01Z := Basetype;
+ elsif Name_Compare (Decl, "vitaldelaytype01zx") then
+ VitalDelayType01ZX := Basetype;
+ elsif Name_Compare (Decl, "vitaldelayarraytype01") then
+ VitalDelayArrayType01 := Basetype;
+ elsif Name_Compare (Decl, "vitaldelaytype") then
+ VitalDelayType := Basetype;
+ elsif Name_Compare (Decl, "vitaldelayarraytype") then
+ VitalDelayArrayType := Basetype;
+ end if;
+ end if;
+ end if;
+ end loop;
+ if Vhpi_Get_Kind (VitalDelayType01) = VhpiUndefined then
+ Error ("cannot find VitalDelayType01 in ieee.vital_timing");
+ return;
+ end if;
+ if Vhpi_Get_Kind (VitalDelayType01Z) = VhpiUndefined then
+ Error ("cannot find VitalDelayType01Z in ieee.vital_timing");
+ return;
+ end if;
+ if Vhpi_Get_Kind (VitalDelayType01ZX) = VhpiUndefined then
+ Error ("cannot find VitalDelayType01ZX in ieee.vital_timing");
+ return;
+ end if;
+ if Vhpi_Get_Kind (VitalDelayArrayType01) = VhpiUndefined then
+ Error ("cannot find VitalDelayArrayType01 in ieee.vital_timing");
+ return;
+ end if;
+ if Vhpi_Get_Kind (VitalDelayType) = VhpiUndefined then
+ Error ("cannot find VitalDelayType in ieee.vital_timing");
+ return;
+ end if;
+ end Extract_Vital_Delay_Type;
+
+ Has_Sdf_Option : Boolean := False;
+
+ procedure Sdf_Start
+ is
+ use Grt.Options;
+ Len : Integer;
+ Beg : Integer;
+ Arg : Ghdl_C_String;
+ begin
+ if not Has_Sdf_Option then
+ -- Nothing to do.
+ return;
+ end if;
+ Flag_Dump := False;
+
+ -- Extract VitalDelayType(s) from VITAL_Timing package.
+ Extract_Vital_Delay_Type;
+
+ -- Annotate.
+ for I in 1 .. Last_Opt loop
+ Arg := Argv (I);
+ Len := strlen (Arg);
+ if Len > 5 and then Arg (1 .. 6) = "--sdf=" then
+ Sdf_Mtm := Typical;
+ Beg := 7;
+ if Len > 10 then
+ if Arg (7 .. 10) = "typ=" then
+ Beg := 11;
+ elsif Arg (7 .. 10) = "min=" then
+ Sdf_Mtm := Minimum;
+ Beg := 11;
+ elsif Arg (7 .. 10) = "max=" then
+ Sdf_Mtm := Maximum;
+ Beg := 11;
+ end if;
+ end if;
+ Annotate (Arg (Beg .. Len));
+ end if;
+ end loop;
+ end Sdf_Start;
+
+ function Sdf_Option (Option : String) return Boolean
+ is
+ Opt : constant String (1 .. Option'Length) := Option;
+ begin
+ if Opt'Length > 11 and then Opt (1 .. 11) = "--sdf-dump=" then
+ Flag_Dump := True;
+ if Sdf.Parse_Sdf_File (Opt (12 .. Opt'Last)) then
+ null;
+ end if;
+ return True;
+ end if;
+ if Opt'Length > 5 and then Opt (1 .. 6) = "--sdf=" then
+ Has_Sdf_Option := True;
+ return True;
+ else
+ return False;
+ end if;
+ end Sdf_Option;
+
+ procedure Sdf_Help is
+ begin
+ Put_Line (" --sdf=[min=|typ=|max=]TOP=FILENAME");
+ Put_Line (" annotate TOP with SDF delay file FILENAME");
+ end Sdf_Help;
+
+ Sdf_Hooks : aliased constant Hooks_Type :=
+ (Option => Sdf_Option'Access,
+ Help => Sdf_Help'Access,
+ Init => Proc_Hook_Nil'Access,
+ Start => Sdf_Start'Access,
+ Finish => Proc_Hook_Nil'Access);
+
+ procedure Register is
+ begin
+ Register_Hooks (Sdf_Hooks'Access);
+ end Register;
+end Grt.Vital_Annotate;
diff --git a/src/translate/grt/grt-vital_annotate.ads b/src/translate/grt/grt-vital_annotate.ads
new file mode 100644
index 000000000..acf82bba2
--- /dev/null
+++ b/src/translate/grt/grt-vital_annotate.ads
@@ -0,0 +1,42 @@
+-- GHDL Run Time (GRT) - VITAL annotator.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Sdf; use Grt.Sdf;
+
+package Grt.Vital_Annotate is
+ pragma Elaborate_Body (Grt.Vital_Annotate);
+
+ procedure Sdf_Header (Context : Sdf_Context_Type);
+ procedure Sdf_Celltype (Context : Sdf_Context_Type);
+ procedure Sdf_Instance (Context : in out Sdf_Context_Type;
+ Instance : String;
+ Status : out Boolean);
+ procedure Sdf_Instance_End (Context : Sdf_Context_Type;
+ Status : out Boolean);
+ procedure Sdf_Generic (Context : in out Sdf_Context_Type;
+ Name : String;
+ Ok : out Boolean);
+
+ procedure Register;
+end Grt.Vital_Annotate;
diff --git a/src/translate/grt/grt-vpi.adb b/src/translate/grt/grt-vpi.adb
new file mode 100644
index 000000000..9b77319f1
--- /dev/null
+++ b/src/translate/grt/grt-vpi.adb
@@ -0,0 +1,988 @@
+-- GHDL Run Time (GRT) - VPI interface.
+-- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+-- Description: VPI interface for GRT runtime
+-- the main purpose of this code is to interface with the
+-- Icarus Verilog Interactive (IVI) simulator GUI
+
+-------------------------------------------------------------------------------
+-- TODO:
+-------------------------------------------------------------------------------
+-- DONE:
+-- * The GHDL VPI implementation doesn't support time
+-- callbacks (cbReadOnlySynch). This is needed to support
+-- IVI run. Currently, the GHDL simulation runs until
+-- complete once a single 'run' is performed...
+-- * You are loading '_'-prefixed symbols when you
+-- load the vpi plugin. On Linux, there is no leading
+-- '_'. I just added code to try both '_'-prefixed and
+-- non-'_'-prefixed symbols. I have placed the changed
+-- file in the same download dir as the snapshot
+-- * I did find out why restart doesn't work for GHDL.
+-- You are passing back the leaf name of signals when the
+-- FullName is requested.
+-------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Stdio; use Grt.Stdio;
+with Grt.C; use Grt.C;
+with Grt.Signals; use Grt.Signals;
+with Grt.Table;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Vcd; use Grt.Vcd;
+with Grt.Errors; use Grt.Errors;
+with Grt.Rtis_Types;
+pragma Elaborate_All (Grt.Table);
+
+package body Grt.Vpi is
+ -- The VPI interface requires libdl (dlopen, dlsym) to be linked in.
+ -- This is now set in Makefile, since this is target dependent.
+ -- pragma Linker_Options ("-ldl");
+
+ --errAnyString: constant String := "grt-vcd.adb: any string" & NUL;
+ --errNoString: constant String := "grt-vcd.adb: no string" & NUL;
+
+ type Vpi_Index_Type is new Integer;
+
+-------------------------------------------------------------------------------
+-- * * * h e l p e r s * * * * * * * * * * * * * * * * * * * * * * * * * *
+-------------------------------------------------------------------------------
+
+ ------------------------------------------------------------------------
+ -- debugging helpers
+ procedure dbgPut (Str : String)
+ is
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ S := fwrite (Str'Address, Str'Length, 1, stderr);
+ end dbgPut;
+
+ procedure dbgPut (C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := fputc (Character'Pos (C), stderr);
+ end dbgPut;
+
+ procedure dbgNew_Line is
+ begin
+ dbgPut (Nl);
+ end dbgNew_Line;
+
+ procedure dbgPut_Line (Str : String)
+ is
+ begin
+ dbgPut (Str);
+ dbgNew_Line;
+ end dbgPut_Line;
+
+-- procedure dbgPut_Line (Str : Ghdl_Str_Len_Type)
+-- is
+-- begin
+-- Put_Str_Len(stderr, Str);
+-- dbgNew_Line;
+-- end dbgPut_Line;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Name => vpiHandle, Object => struct_vpiHandle);
+
+ ------------------------------------------------------------------------
+ -- NUL-terminate strings.
+ -- note: there are several buffers
+ -- see IEEE 1364-2001
+-- tmpstring1: string(1..1024);
+-- function NulTerminate1 (Str : Ghdl_Str_Len_Type) return Ghdl_C_String
+-- is
+-- begin
+-- for i in 1..Str.Len loop
+-- tmpstring1(i):= Str.Str(i);
+-- end loop;
+-- tmpstring1(Str.Len+1):= NUL;
+-- return To_Ghdl_C_String (tmpstring1'Address);
+-- end NulTerminate1;
+
+-------------------------------------------------------------------------------
+-- * * * V P I f u n c t i o n s * * * * * * * * * * * * * * * * * * * *
+-------------------------------------------------------------------------------
+
+ ------------------------------------------------------------------------
+ -- vpiHandle vpi_iterate(int type, vpiHandle ref)
+ -- Obtain an iterator handle to objects with a one-to-many relationship.
+ -- see IEEE 1364-2001, page 685
+ function vpi_iterate (aType: integer; Ref: vpiHandle) return vpiHandle
+ is
+ Res : vpiHandle;
+ Rel : VhpiOneToManyT;
+ Error : AvhpiErrorT;
+ begin
+ --dbgPut_Line ("vpi_iterate");
+
+ case aType is
+ when vpiNet =>
+ Rel := VhpiDecls;
+ when vpiModule =>
+ if Ref = null then
+ Res := new struct_vpiHandle (vpiModule);
+ Get_Root_Inst (Res.Ref);
+ return Res;
+ else
+ Rel := VhpiInternalRegions;
+ end if;
+ when vpiInternalScope =>
+ Rel := VhpiInternalRegions;
+ when others =>
+ return null;
+ end case;
+
+ -- find the proper start object for our scan
+ if Ref = null then
+ return null;
+ end if;
+
+ Res := new struct_vpiHandle (aType);
+ Vhpi_Iterator (Rel, Ref.Ref, Res.Ref, Error);
+
+ if Error /= AvhpiErrorOk then
+ Free (Res);
+ end if;
+ return Res;
+ end vpi_iterate;
+
+ ------------------------------------------------------------------------
+ -- int vpi_get(int property, vpiHandle ref)
+ -- Get the value of an integer or boolean property of an object.
+ -- see IEEE 1364-2001, chapter 27.6, page 667
+-- function ii_vpi_get_type (aRef: Ghdl_Instance_Name_Acc) return Integer
+-- is
+-- begin
+-- case aRef.Kind is
+-- when Ghdl_Name_Entity
+-- | Ghdl_Name_Architecture
+-- | Ghdl_Name_Block
+-- | Ghdl_Name_Generate_Iterative
+-- | Ghdl_Name_Generate_Conditional
+-- | Ghdl_Name_Instance =>
+-- return vpiModule;
+-- when Ghdl_Name_Signal =>
+-- return vpiNet;
+-- when others =>
+-- return vpiUndefined;
+-- end case;
+-- end ii_vpi_get_type;
+
+ function vpi_get (Property: integer; Ref: vpiHandle) return Integer
+ is
+ begin
+ case Property is
+ when vpiType=>
+ return Ref.mType;
+ when vpiTimePrecision=>
+ return -9; -- is this nano-seconds?
+ when others=>
+ dbgPut_Line ("vpi_get: unknown property");
+ return 0;
+ end case;
+ end vpi_get;
+
+ ------------------------------------------------------------------------
+ -- vpiHandle vpi_scan(vpiHandle iter)
+ -- Scan the Verilog HDL hierarchy for objects with a one-to-many
+ -- relationship.
+ -- see IEEE 1364-2001, chapter 27.36, page 709
+ function vpi_scan (Iter: vpiHandle) return vpiHandle
+ is
+ Res : VhpiHandleT;
+ Error : AvhpiErrorT;
+ R : vpiHandle;
+ begin
+ --dbgPut_Line ("vpi_scan");
+ if Iter = null then
+ return null;
+ end if;
+
+ -- There is only one top-level module.
+ if Iter.mType = vpiModule then
+ case Vhpi_Get_Kind (Iter.Ref) is
+ when VhpiRootInstK =>
+ R := new struct_vpiHandle (Iter.mType);
+ R.Ref := Iter.Ref;
+ Iter.Ref := Null_Handle;
+ return R;
+ when VhpiUndefined =>
+ return null;
+ when others =>
+ -- Fall through.
+ null;
+ end case;
+ end if;
+
+ loop
+ Vhpi_Scan (Iter.Ref, Res, Error);
+ exit when Error /= AvhpiErrorOk;
+
+ case Vhpi_Get_Kind (Res) is
+ when VhpiEntityDeclK
+ | VhpiArchBodyK
+ | VhpiBlockStmtK
+ | VhpiIfGenerateK
+ | VhpiForGenerateK
+ | VhpiCompInstStmtK =>
+ case Iter.mType is
+ when vpiInternalScope
+ | vpiModule =>
+ return new struct_vpiHandle'(mType => vpiModule,
+ Ref => Res);
+ when others =>
+ null;
+ end case;
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ if Iter.mType = vpiNet then
+ declare
+ Info : Verilog_Wire_Info;
+ begin
+ Get_Verilog_Wire (Res, Info);
+ if Info.Kind /= Vcd_Bad then
+ return new struct_vpiHandle'(mType => vpiNet,
+ Ref => Res);
+ end if;
+ end;
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ return null;
+ end vpi_scan;
+
+ ------------------------------------------------------------------------
+ -- char *vpi_get_str(int property, vpiHandle ref)
+ -- see IEEE 1364-2001, page xxx
+ Tmpstring2 : String (1 .. 1024);
+ function vpi_get_str (Property : Integer; Ref : vpiHandle)
+ return Ghdl_C_String
+ is
+ Prop : VhpiStrPropertyT;
+ Len : Natural;
+ begin
+ --dbgPut_Line ("vpiGetStr");
+
+ if Ref = null then
+ return null;
+ end if;
+
+ case Property is
+ when vpiFullName=>
+ Prop := VhpiFullNameP;
+ when vpiName=>
+ Prop := VhpiNameP;
+ when others=>
+ dbgPut_Line ("vpi_get_str: undefined property");
+ return null;
+ end case;
+ Vhpi_Get_Str (Prop, Ref.Ref, Tmpstring2, Len);
+ Tmpstring2 (Len + 1) := NUL;
+ if Property = vpiFullName then
+ for I in Tmpstring2'First .. Len loop
+ if Tmpstring2 (I) = ':' then
+ Tmpstring2 (I) := '.';
+ end if;
+ end loop;
+ -- Remove the initial '.'.
+ return To_Ghdl_C_String (Tmpstring2 (2)'Address);
+ else
+ return To_Ghdl_C_String (Tmpstring2'Address);
+ end if;
+ end vpi_get_str;
+
+ ------------------------------------------------------------------------
+ -- vpiHandle vpi_handle(int type, vpiHandle ref)
+ -- Obtain a handle to an object with a one-to-one relationship.
+ -- see IEEE 1364-2001, chapter 27.16, page 682
+ function vpi_handle (aType : Integer; Ref : vpiHandle) return vpiHandle
+ is
+ Res : vpiHandle;
+ begin
+ --dbgPut_Line ("vpi_handle");
+
+ if Ref = null then
+ return null;
+ end if;
+
+ case aType is
+ when vpiScope =>
+ case Ref.mType is
+ when vpiModule =>
+ Res := new struct_vpiHandle (vpiScope);
+ Res.Ref := Ref.Ref;
+ return Res;
+ when others =>
+ return null;
+ end case;
+ when vpiRightRange
+ | vpiLeftRange =>
+ case Ref.mType is
+ when vpiNet =>
+ Res := new struct_vpiHandle (aType);
+ Res.Ref := Ref.Ref;
+ return Res;
+ when others =>
+ return null;
+ end case;
+ when others =>
+ return null;
+ end case;
+ end vpi_handle;
+
+ ------------------------------------------------------------------------
+ -- void vpi_get_value(vpiHandle expr, p_vpi_value value);
+ -- Retrieve the simulation value of an object.
+ -- see IEEE 1364-2001, chapter 27.14, page 675
+ Tmpstring3idx : integer;
+ Tmpstring3 : String (1 .. 1024);
+ procedure ii_vpi_get_value_bin_str_B1 (Val : Ghdl_B1)
+ is
+ begin
+ case Val is
+ when True =>
+ Tmpstring3 (Tmpstring3idx) := '1';
+ when False =>
+ Tmpstring3 (Tmpstring3idx) := '0';
+ end case;
+ Tmpstring3idx := Tmpstring3idx + 1;
+ end ii_vpi_get_value_bin_str_B1;
+
+ procedure ii_vpi_get_value_bin_str_E8 (Val : Ghdl_E8)
+ is
+ type Map_Type_E8 is array (Ghdl_E8 range 0..8) of character;
+ Map_Std_E8: constant Map_Type_E8 := "UX01ZWLH-";
+ begin
+ if Val not in Map_Type_E8'range then
+ Tmpstring3 (Tmpstring3idx) := '?';
+ else
+ Tmpstring3 (Tmpstring3idx) := Map_Std_E8(Val);
+ end if;
+ Tmpstring3idx := Tmpstring3idx + 1;
+ end ii_vpi_get_value_bin_str_E8;
+
+ function ii_vpi_get_value_bin_str (Obj : VhpiHandleT)
+ return Ghdl_C_String
+ is
+ Info : Verilog_Wire_Info;
+ Len : Ghdl_Index_Type;
+ begin
+ case Vhpi_Get_Kind (Obj) is
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ null;
+ when others =>
+ return null;
+ end case;
+
+ -- Get verilog compat info.
+ Get_Verilog_Wire (Obj, Info);
+ if Info.Kind = Vcd_Bad then
+ return null;
+ end if;
+
+ if Info.Irange = null then
+ Len := 1;
+ else
+ Len := Info.Irange.I32.Len;
+ end if;
+
+ Tmpstring3idx := 1; -- reset string buffer
+
+ case Info.Val is
+ when Vcd_Effective =>
+ case Info.Kind is
+ when Vcd_Bad
+ | Vcd_Integer32
+ | Vcd_Float64 =>
+ return null;
+ when Vcd_Bit
+ | Vcd_Bool
+ | Vcd_Bitvector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_get_value_bin_str_B1
+ (To_Signal_Arr_Ptr (Info.Addr)(J).Value.B1);
+ end loop;
+ when Vcd_Stdlogic
+ | Vcd_Stdlogic_Vector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_get_value_bin_str_E8
+ (To_Signal_Arr_Ptr (Info.Addr)(J).Value.E8);
+ end loop;
+ end case;
+ when Vcd_Driving =>
+ case Info.Kind is
+ when Vcd_Bad
+ | Vcd_Integer32
+ | Vcd_Float64 =>
+ return null;
+ when Vcd_Bit
+ | Vcd_Bool
+ | Vcd_Bitvector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_get_value_bin_str_B1
+ (To_Signal_Arr_Ptr (Info.Addr)(J).Driving_Value.B1);
+ end loop;
+ when Vcd_Stdlogic
+ | Vcd_Stdlogic_Vector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_get_value_bin_str_E8
+ (To_Signal_Arr_Ptr (Info.Addr)(J).Driving_Value.E8);
+ end loop;
+ end case;
+ end case;
+ Tmpstring3 (Tmpstring3idx) := NUL;
+ return To_Ghdl_C_String (Tmpstring3'Address);
+ end ii_vpi_get_value_bin_str;
+
+ procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value)
+ is
+ begin
+ case Value.Format is
+ when vpiObjTypeVal=>
+ -- fill in the object type and value:
+ -- For an integer, vpiIntVal
+ -- For a real, vpiRealVal
+ -- For a scalar, either vpiScalar or vpiStrength
+ -- For a time variable, vpiTimeVal with vpiSimTime
+ -- For a vector, vpiVectorVal
+ dbgPut_Line ("vpi_get_value: vpiObjTypeVal");
+ when vpiBinStrVal=>
+ Value.Str := ii_vpi_get_value_bin_str (Expr.Ref);
+ --aValue.mStr := NulTerminate2(aExpr.mRef.Name.all);
+ when vpiOctStrVal=>
+ dbgPut_Line("vpi_get_value: vpiNet, vpiOctStrVal");
+ when vpiDecStrVal=>
+ dbgPut_Line("vpi_get_value: vpiNet, vpiDecStrVal");
+ when vpiHexStrVal=>
+ dbgPut_Line("vpi_get_value: vpiNet, vpiHexStrVal");
+ when vpiScalarVal=>
+ dbgPut_Line("vpi_get_value: vpiNet, vpiScalarVal");
+ when vpiIntVal=>
+ case Expr.mType is
+ when vpiLeftRange
+ | vpiRightRange=>
+ declare
+ Info : Verilog_Wire_Info;
+ begin
+ Get_Verilog_Wire (Expr.Ref, Info);
+ if Info.Irange /= null then
+ if Expr.mType = vpiLeftRange then
+ Value.Integer_m := Integer (Info.Irange.I32.Left);
+ else
+ Value.Integer_m := Integer (Info.Irange.I32.Right);
+ end if;
+ else
+ Value.Integer_m := 0;
+ end if;
+ end;
+ when others=>
+ dbgPut_Line ("vpi_get_value: vpiIntVal, unknown mType");
+ end case;
+ when vpiRealVal=> dbgPut_Line("vpi_get_value: vpiRealVal");
+ when vpiStringVal=> dbgPut_Line("vpi_get_value: vpiStringVal");
+ when vpiTimeVal=> dbgPut_Line("vpi_get_value: vpiTimeVal");
+ when vpiVectorVal=> dbgPut_Line("vpi_get_value: vpiVectorVal");
+ when vpiStrengthVal=> dbgPut_Line("vpi_get_value: vpiStrengthVal");
+ when others=> dbgPut_Line("vpi_get_value: unknown mFormat");
+ end case;
+ end vpi_get_value;
+
+ ------------------------------------------------------------------------
+ -- void vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value,
+ -- p_vpi_time when, int flags)
+ -- Alter the simulation value of an object.
+ -- see IEEE 1364-2001, chapter 27.14, page 675
+ -- FIXME
+
+ procedure ii_vpi_put_value_bin_str_B1 (SigPtr : Ghdl_Signal_Ptr;
+ Value : Character)
+ is
+ Tempval : Value_Union;
+ begin
+ -- use the Set_Effective_Value procedure to update the signal
+ case Value is
+ when '0' =>
+ Tempval.B1 := false;
+ when '1' =>
+ Tempval.B1 := true;
+ when others =>
+ dbgPut_Line("ii_vpi_put_value_bin_str_B1: "
+ & "wrong character - signal wont be set");
+ return;
+ end case;
+ SigPtr.Driving_Value := Tempval;
+ Set_Effective_Value (SigPtr, Tempval);
+ end ii_vpi_put_value_bin_str_B1;
+
+ procedure ii_vpi_put_value_bin_str_E8 (SigPtr : Ghdl_Signal_Ptr;
+ Value : Character)
+ is
+ Tempval : Value_Union;
+ begin
+ case Value is
+ when 'U' =>
+ Tempval.E8 := 0;
+ when 'X' =>
+ Tempval.E8 := 1;
+ when '0' =>
+ Tempval.E8 := 2;
+ when '1' =>
+ Tempval.E8 := 3;
+ when 'Z' =>
+ Tempval.E8 := 4;
+ when 'W' =>
+ Tempval.E8 := 5;
+ when 'L' =>
+ Tempval.E8 := 6;
+ when 'H' =>
+ Tempval.E8 := 7;
+ when '-' =>
+ Tempval.E8 := 8;
+ when others =>
+ dbgPut_Line("ii_vpi_put_value_bin_str_B8: "
+ & "wrong character - signal wont be set");
+ return;
+ end case;
+ SigPtr.Driving_Value := Tempval;
+ Set_Effective_Value (SigPtr, Tempval);
+ end ii_vpi_put_value_bin_str_E8;
+
+
+ procedure ii_vpi_put_value_bin_str(Obj : VhpiHandleT;
+ ValueStr : Ghdl_C_String)
+ is
+ Info : Verilog_Wire_Info;
+ Len : Ghdl_Index_Type;
+ begin
+ -- Check the Obj type.
+ -- * The vpiHandle has a reference (field Ref) to a VhpiHandleT
+ -- when it doesnt come from a callback.
+ case Vhpi_Get_Kind(Obj) is
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ null;
+ when others =>
+ return;
+ end case;
+
+ -- The following code segment was copied from the
+ -- ii_vpi_get_value function.
+ -- Get verilog compat info.
+ Get_Verilog_Wire (Obj, Info);
+ if Info.Kind = Vcd_Bad then
+ return;
+ end if;
+
+ if Info.Irange = null then
+ Len := 1;
+ else
+ Len := Info.Irange.I32.Len;
+ end if;
+
+ -- Step 1: convert vpi object to internal format.
+ -- p_vpi_handle -> Ghdl_Signal_Ptr
+ -- To_Signal_Arr_Ptr (Info.Addr) does part of the magic
+
+ -- Step 2: convert datum to appropriate type.
+ -- Ghdl_C_String -> Value_Union
+
+ -- Step 3: assigns value to object using Set_Effective_Value
+ -- call (from grt-signals)
+ -- Set_Effective_Value(sig_ptr, conv_value);
+
+
+ -- Took the skeleton from ii_vpi_get_value function
+ -- This point of the function must convert the string value to the
+ -- native ghdl format.
+ case Info.Kind is
+ when Vcd_Bad =>
+ return;
+ when Vcd_Bit
+ | Vcd_Bool
+ | Vcd_Bitvector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_put_value_bin_str_B1(
+ To_Signal_Arr_Ptr(Info.Addr)(J), ValueStr(Integer(J+1)));
+ end loop;
+ when Vcd_Stdlogic
+ | Vcd_Stdlogic_Vector =>
+ for J in 0 .. Len - 1 loop
+ ii_vpi_put_value_bin_str_E8(
+ To_Signal_Arr_Ptr(Info.Addr)(J), ValueStr(Integer(J+1)));
+ end loop;
+ when Vcd_Integer32
+ | Vcd_Float64 =>
+ null;
+ end case;
+
+ -- Always return null, because this simulation kernel cannot send
+ -- a handle to the event back.
+ return;
+ end ii_vpi_put_value_bin_str;
+
+
+ -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value,
+ -- p_vpi_time when, int flags)
+ function vpi_put_value (aObj: vpiHandle;
+ aValue: p_vpi_value;
+ aWhen: p_vpi_time;
+ aFlags: integer)
+ return vpiHandle
+ is
+ pragma Unreferenced (aWhen);
+ pragma Unreferenced (aFlags);
+ begin
+ -- A very simple write procedure for VPI.
+ -- Basically, it accepts bin_str values and converts to appropriate
+ -- types (only std_logic and bit values and vectors).
+
+ -- It'll use Set_Effective_Value procedure to update signals
+
+ -- Ignoring aWhen and aFlags, for now.
+
+ -- Checks the format of aValue. Only vpiBinStrVal will be accepted
+ -- for now.
+ case aValue.Format is
+ when vpiObjTypeVal =>
+ dbgPut_Line ("vpi_put_value: vpiObjTypeVal");
+ when vpiBinStrVal =>
+ ii_vpi_put_value_bin_str(aObj.Ref, aValue.Str);
+ -- dbgPut_Line ("vpi_put_value: vpiBinStrVal");
+ when vpiOctStrVal =>
+ dbgPut_Line ("vpi_put_value: vpiNet, vpiOctStrVal");
+ when vpiDecStrVal =>
+ dbgPut_Line ("vpi_put_value: vpiNet, vpiDecStrVal");
+ when vpiHexStrVal =>
+ dbgPut_Line ("vpi_put_value: vpiNet, vpiHexStrVal");
+ when vpiScalarVal =>
+ dbgPut_Line ("vpi_put_value: vpiNet, vpiScalarVal");
+ when vpiIntVal =>
+ dbgPut_Line ("vpi_put_value: vpiIntVal");
+ when vpiRealVal =>
+ dbgPut_Line("vpi_put_value: vpiRealVal");
+ when vpiStringVal =>
+ dbgPut_Line("vpi_put_value: vpiStringVal");
+ when vpiTimeVal =>
+ dbgPut_Line("vpi_put_value: vpiTimeVal");
+ when vpiVectorVal =>
+ dbgPut_Line("vpi_put_value: vpiVectorVal");
+ when vpiStrengthVal =>
+ dbgPut_Line("vpi_put_value: vpiStrengthVal");
+ when others =>
+ dbgPut_Line("vpi_put_value: unknown mFormat");
+ end case;
+
+ -- Must return a scheduled event caused by vpi_put_value()
+ -- Still dont know how to do it.
+ return null;
+ end vpi_put_value;
+
+ ------------------------------------------------------------------------
+ -- void vpi_get_time(vpiHandle obj, s_vpi_time*t);
+ -- see IEEE 1364-2001, page xxx
+ Sim_Time : Std_Time;
+ procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time)
+ is
+ pragma Unreferenced (Obj);
+ begin
+ --dbgPut_Line ("vpi_get_time");
+ Time.mType := vpiSimTime;
+ Time.mHigh := 0;
+ Time.mLow := Integer (Sim_Time / 1000000);
+ Time.mReal := 0.0;
+ end vpi_get_time;
+
+ ------------------------------------------------------------------------
+ -- vpiHandle vpi_register_cb(p_cb_data data)
+ g_cbEndOfCompile : p_cb_data;
+ g_cbEndOfSimulation: p_cb_data;
+ --g_cbValueChange: s_cb_data;
+ g_cbReadOnlySync: p_cb_data;
+
+ type Vpi_Var_Type is record
+ Info : Verilog_Wire_Info;
+ Cb : s_cb_data;
+ end record;
+
+ package Vpi_Table is new Grt.Table
+ (Table_Component_Type => Vpi_Var_Type,
+ Table_Index_Type => Vpi_Index_Type,
+ Table_Low_Bound => 0,
+ Table_Initial => 32);
+
+ function vpi_register_cb (Data : p_cb_data) return vpiHandle
+ is
+ Res : p_cb_data := null;
+ begin
+ --dbgPut_Line ("vpi_register_cb");
+ case Data.Reason is
+ when cbEndOfCompile =>
+ Res := new s_cb_data'(Data.all);
+ g_cbEndOfCompile := Res;
+ Sim_Time:= 0;
+ when cbEndOfSimulation =>
+ Res := new s_cb_data'(Data.all);
+ g_cbEndOfSimulation := Res;
+ when cbValueChange =>
+ declare
+ N : Vpi_Index_Type;
+ begin
+ --g_cbValueChange:= aData.all;
+ Vpi_Table.Increment_Last;
+ N := Vpi_Table.Last;
+ Vpi_Table.Table (N).Cb := Data.all;
+ Get_Verilog_Wire (Data.Obj.Ref, Vpi_Table.Table (N).Info);
+ end;
+ when cbReadOnlySynch=>
+ Res := new s_cb_data'(Data.all);
+ g_cbReadOnlySync := Res;
+ when others=>
+ dbgPut_Line ("vpi_register_cb: unknwon reason");
+ end case;
+ if Res /= null then
+ return new struct_vpiHandle'(mType => vpiCallback,
+ Cb => Res);
+ else
+ return null;
+ end if;
+ end vpi_register_cb;
+
+-------------------------------------------------------------------------------
+-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * *
+-------------------------------------------------------------------------------
+
+ -- int vpi_free_object(vpiHandle ref)
+ function vpi_free_object (aRef: vpiHandle) return integer
+ is
+ pragma Unreferenced (aRef);
+ begin
+ return 0;
+ end vpi_free_object;
+
+ -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p)
+ function vpi_get_vlog_info (aVlog_info_p: System.Address) return integer
+ is
+ pragma Unreferenced (aVlog_info_p);
+ begin
+ return 0;
+ end vpi_get_vlog_info;
+
+ -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index)
+ function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer)
+ return vpiHandle
+ is
+ pragma Unreferenced (aRef);
+ pragma Unreferenced (aIndex);
+ begin
+ return null;
+ end vpi_handle_by_index;
+
+ -- unsigned int vpi_mcd_close(unsigned int mcd)
+ function vpi_mcd_close (Mcd: integer) return integer
+ is
+ pragma Unreferenced (Mcd);
+ begin
+ return 0;
+ end vpi_mcd_close;
+
+ -- char *vpi_mcd_name(unsigned int mcd)
+ function vpi_mcd_name (Mcd: integer) return integer
+ is
+ pragma Unreferenced (Mcd);
+ begin
+ return 0;
+ end vpi_mcd_name;
+
+ -- unsigned int vpi_mcd_open(char *name)
+ function vpi_mcd_open (Name : Ghdl_C_String) return Integer
+ is
+ pragma Unreferenced (Name);
+ begin
+ return 0;
+ end vpi_mcd_open;
+
+ -- void vpi_register_systf(const struct t_vpi_systf_data*ss)
+ procedure vpi_register_systf(aSs: System.Address)
+ is
+ pragma Unreferenced (aSs);
+ begin
+ null;
+ end vpi_register_systf;
+
+ -- int vpi_remove_cb(vpiHandle ref)
+ function vpi_remove_cb (Ref : vpiHandle) return Integer
+ is
+ pragma Unreferenced (Ref);
+ begin
+ return 0;
+ end vpi_remove_cb;
+
+ -- void vpi_vprintf(const char*fmt, va_list ap)
+ procedure vpi_vprintf (Fmt : Address; Ap : Address)
+ is
+ pragma Unreferenced (Fmt);
+ pragma Unreferenced (Ap);
+ begin
+ null;
+ end vpi_vprintf;
+
+ -- missing here, see grt-cvpi.c:
+ -- vpi_mcd_open_x
+ -- vpi_mcd_vprintf
+ -- vpi_mcd_fputc
+ -- vpi_mcd_fgetc
+ -- vpi_sim_vcontrol
+ -- vpi_chk_error
+ -- pi_handle_by_name
+
+------------------------------------------------------------------------------
+-- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * *
+------------------------------------------------------------------------------
+
+ -- VCD filename.
+ Vpi_Filename : String_Access := null;
+
+ ------------------------------------------------------------------------
+ -- Return TRUE if OPT is an option for VPI.
+ function Vpi_Option (Opt : String) return Boolean
+ is
+ F : constant Natural := Opt'First;
+ begin
+ if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vpi" then
+ return False;
+ end if;
+ if Opt'Length > 6 and then Opt (F + 5) = '=' then
+ -- Add an extra NUL character.
+ Vpi_Filename := new String (1 .. Opt'Length - 6 + 1);
+ Vpi_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last);
+ Vpi_Filename (Vpi_Filename'Last) := NUL;
+ return True;
+ else
+ return False;
+ end if;
+ end Vpi_Option;
+
+ ------------------------------------------------------------------------
+ procedure Vpi_Help is
+ begin
+ Put_Line (" --vpi=FILENAME load VPI module");
+ end Vpi_Help;
+
+ ------------------------------------------------------------------------
+ -- Called before elaboration.
+
+ -- void loadVpiModule(const char* modulename)
+ function LoadVpiModule (Filename: Address) return Integer;
+ pragma Import (C, LoadVpiModule, "loadVpiModule");
+
+
+ procedure Vpi_Init
+ is
+ begin
+ Sim_Time:= 0;
+
+ --g_cbEndOfCompile.mCb_rtn:= null;
+ --g_cbEndOfSimulation.mCb_rtn:= null;
+ --g_cbValueChange.mCb_rtn:= null;
+
+ if Vpi_Filename /= null then
+ if LoadVpiModule (Vpi_Filename.all'Address) /= 0 then
+ Error ("cannot load VPI module");
+ end if;
+ end if;
+ end Vpi_Init;
+
+ procedure Vpi_Cycle;
+
+ ------------------------------------------------------------------------
+ -- Called after elaboration.
+ procedure Vpi_Start
+ is
+ Res : Integer;
+ pragma Unreferenced (Res);
+ begin
+ if Vpi_Filename = null then
+ return;
+ end if;
+
+ Grt.Rtis_Types.Search_Types_RTI;
+ Register_Cycle_Hook (Vpi_Cycle'Access);
+ if g_cbEndOfCompile /= null then
+ Res := g_cbEndOfCompile.Cb_Rtn.all (g_cbEndOfCompile);
+ end if;
+ end Vpi_Start;
+
+ ------------------------------------------------------------------------
+ -- Called before each non delta cycle.
+ procedure Vpi_Cycle
+ is
+ Res : Integer;
+ pragma Unreferenced (Res);
+ begin
+ if g_cbReadOnlySync /= null
+ and then g_cbReadOnlySync.Time.mLow < Integer (Sim_Time / 1_000_000)
+ then
+ Res := g_cbReadOnlySync.Cb_Rtn.all (g_cbReadOnlySync);
+ end if;
+
+ for I in Vpi_Table.First .. Vpi_Table.Last loop
+ if Verilog_Wire_Changed (Vpi_Table.Table (I).Info, Sim_Time) then
+ Res := Vpi_Table.Table (I).Cb.Cb_Rtn.all
+ (To_p_cb_data (Vpi_Table.Table (I).Cb'Address));
+ end if;
+ end loop;
+
+ if Current_Time /= Std_Time'last then
+ Sim_Time:= Current_Time;
+ end if;
+ end Vpi_Cycle;
+
+ ------------------------------------------------------------------------
+ -- Called at the end of the simulation.
+ procedure Vpi_End
+ is
+ Res : Integer;
+ pragma Unreferenced (Res);
+ begin
+ if g_cbEndOfSimulation /= null then
+ Res := g_cbEndOfSimulation.Cb_Rtn.all (g_cbEndOfSimulation);
+ end if;
+ end Vpi_End;
+
+ Vpi_Hooks : aliased constant Hooks_Type :=
+ (Option => Vpi_Option'Access,
+ Help => Vpi_Help'Access,
+ Init => Vpi_Init'Access,
+ Start => Vpi_Start'Access,
+ Finish => Vpi_End'Access);
+
+ procedure Register is
+ begin
+ Register_Hooks (Vpi_Hooks'Access);
+ end Register;
+end Grt.Vpi;
diff --git a/src/translate/grt/grt-vpi.ads b/src/translate/grt/grt-vpi.ads
new file mode 100644
index 000000000..86fb07374
--- /dev/null
+++ b/src/translate/grt/grt-vpi.ads
@@ -0,0 +1,252 @@
+-- GHDL Run Time (GRT) - VPI interface.
+-- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+-- Description: VPI interface for GRT runtime
+-- the main purpose of this code is to interface with the
+-- Icarus Verilog Interactive (IVI) simulator GUI
+
+with System; use System;
+with Ada.Unchecked_Conversion;
+with Grt.Types; use Grt.Types;
+with Grt.Avhpi; use Grt.Avhpi;
+
+package Grt.Vpi is
+
+ -- properties, see vpi_user.h
+ vpiUndefined: constant integer := -1;
+ vpiType: constant integer := 1;
+ vpiName: constant integer := 2;
+ vpiFullName: constant integer := 3;
+ vpiTimePrecision: constant integer := 12;
+
+ -- object codes, see vpi_user.h
+ vpiModule: constant integer := 32;
+ vpiNet: constant integer := 36;
+ vpiScope: constant integer := 84;
+ vpiInternalScope: constant integer := 92;
+ vpiLeftRange: constant integer := 79;
+ vpiRightRange: constant integer := 83;
+
+ -- Additionnal constants.
+ vpiCallback : constant Integer := 200;
+
+ -- codes for the format tag of the vpi_value structure
+ vpiBinStrVal: constant integer := 1;
+ vpiOctStrVal: constant integer := 2;
+ vpiDecStrVal: constant integer := 3;
+ vpiHexStrVal: constant integer := 4;
+ vpiScalarVal: constant integer := 5;
+ vpiIntVal: constant integer := 6;
+ vpiRealVal: constant integer := 7;
+ vpiStringVal: constant integer := 8;
+ vpiVectorVal: constant integer := 9;
+ vpiStrengthVal: constant integer := 10;
+ vpiTimeVal: constant integer := 11;
+ vpiObjTypeVal: constant integer := 12;
+ vpiSuppressVal: constant integer := 13;
+
+ -- codes for type tag of vpi_time structure
+ vpiSimTime: constant integer := 2;
+
+ -- codes for the reason tag of cb_data structure
+ cbValueChange: constant integer:= 1;
+ cbReadOnlySynch: constant integer:= 7;
+ cbEndOfCompile: constant integer:= 10;
+ cbEndOfSimulation:constant integer:= 12;
+
+ type struct_vpiHandle (mType : Integer := vpiUndefined);
+ type vpiHandle is access struct_vpiHandle;
+
+ -- typedef struct t_vpi_time {
+ -- int type;
+ -- unsigned int high;
+ -- unsigned int low;
+ -- double real;
+ -- } s_vpi_time, *p_vpi_time;
+ type s_vpi_time is record
+ mType : Integer;
+ mHigh : Integer; -- this should be unsigned
+ mLow : Integer; -- this should be unsigned
+ mReal : Float; -- this should be double
+ end record;
+ type p_vpi_time is access s_vpi_time;
+
+ -- typedef struct t_vpi_value
+ -- { int format;
+ -- union
+ -- { char*str;
+ -- int scalar;
+ -- int integer;
+ -- double real;
+ -- struct t_vpi_time *time;
+ -- struct t_vpi_vecval *vector;
+ -- struct t_vpi_strengthval *strength;
+ -- char*misc;
+ -- } value;
+ -- } s_vpi_value, *p_vpi_value;
+ type s_vpi_value (Format : integer) is record
+ case Format is
+ when vpiBinStrVal
+ | vpiOctStrVal
+ | vpiDecStrVal
+ | vpiHexStrVal
+ | vpiStringVal =>
+ Str : Ghdl_C_String;
+ when vpiScalarVal =>
+ Scalar : Integer;
+ when vpiIntVal =>
+ Integer_m : Integer;
+ --when vpiRealVal=> null; -- what is the equivalent to double?
+ --when vpiTimeVal=> mTime: p_vpi_time;
+ --when vpiVectorVal=> mVector: p_vpi_vecval;
+ --when vpiStrengthVal=> mStrength: p_vpi_strengthval;
+ when others =>
+ null;
+ end case;
+ end record;
+ type p_vpi_value is access s_vpi_value;
+
+ --typedef struct t_cb_data {
+ -- int reason;
+ -- int (*cb_rtn)(struct t_cb_data*cb);
+ -- vpiHandle obj;
+ -- p_vpi_time time;
+ -- p_vpi_value value;
+ -- int index;
+ -- char*user_data;
+ --} s_cb_data, *p_cb_data;
+ type s_cb_data;
+
+ type p_cb_data is access all s_cb_data;
+ function To_p_cb_data is new Ada.Unchecked_Conversion
+ (Source => Address, Target => p_cb_data);
+
+ type cb_rtn_type is access function (Cb : p_cb_data) return Integer;
+ pragma Convention (C, cb_rtn_type);
+
+ type s_cb_data is record
+ Reason : Integer;
+ Cb_Rtn : cb_rtn_type;
+ Obj : vpiHandle;
+ Time : p_vpi_time;
+ Value : p_vpi_value;
+ Index : Integer;
+ User_Data : Address;
+ end record;
+
+ type struct_vpiHandle (mType : Integer := vpiUndefined) is record
+ case mType is
+ when vpiCallback =>
+ Cb : p_cb_data;
+ when others =>
+ Ref : VhpiHandleT;
+ end case;
+ end record;
+
+ -- vpiHandle vpi_iterate(int type, vpiHandle ref)
+ function vpi_iterate (aType : Integer; Ref : vpiHandle) return vpiHandle;
+ pragma Export (C, vpi_iterate, "vpi_iterate");
+
+ -- int vpi_get(int property, vpiHandle ref)
+ function vpi_get (Property : Integer; Ref : vpiHandle) return Integer;
+ pragma Export (C, vpi_get, "vpi_get");
+
+ -- vpiHandle vpi_scan(vpiHandle iter)
+ function vpi_scan (Iter : vpiHandle) return vpiHandle;
+ pragma Export (C, vpi_scan, "vpi_scan");
+
+ -- char *vpi_get_str(int property, vpiHandle ref)
+ function vpi_get_str (Property : Integer; Ref : vpiHandle)
+ return Ghdl_C_String;
+ pragma Export (C, vpi_get_str, "vpi_get_str");
+
+ -- vpiHandle vpi_handle(int type, vpiHandle ref)
+ function vpi_handle (aType: integer; Ref: vpiHandle)
+ return vpiHandle;
+ pragma Export (C, vpi_handle, "vpi_handle");
+
+ -- void vpi_get_value(vpiHandle expr, p_vpi_value value);
+ procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value);
+ pragma Export (C, vpi_get_value, "vpi_get_value");
+
+ -- void vpi_get_time(vpiHandle obj, s_vpi_time*t);
+ procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time);
+ pragma Export (C, vpi_get_time, "vpi_get_time");
+
+ -- vpiHandle vpi_register_cb(p_cb_data data)
+ function vpi_register_cb (Data : p_cb_data) return vpiHandle;
+ pragma Export (C, vpi_register_cb, "vpi_register_cb");
+
+-------------------------------------------------------------------------------
+-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * *
+-------------------------------------------------------------------------------
+
+ -- int vpi_free_object(vpiHandle ref)
+ function vpi_free_object(aRef: vpiHandle) return integer;
+ pragma Export (C, vpi_free_object, "vpi_free_object");
+
+ -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p)
+ function vpi_get_vlog_info(aVlog_info_p: System.Address) return integer;
+ pragma Export (C, vpi_get_vlog_info, "vpi_get_vlog_info");
+
+ -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index)
+ function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer)
+ return vpiHandle;
+ pragma Export (C, vpi_handle_by_index, "vpi_handle_by_index");
+
+ -- unsigned int vpi_mcd_close(unsigned int mcd)
+ function vpi_mcd_close (Mcd : Integer) return Integer;
+ pragma Export (C, vpi_mcd_close, "vpi_mcd_close");
+
+ -- char *vpi_mcd_name(unsigned int mcd)
+ function vpi_mcd_name (Mcd : Integer) return Integer;
+ pragma Export (C, vpi_mcd_name, "vpi_mcd_name");
+
+ -- unsigned int vpi_mcd_open(char *name)
+ function vpi_mcd_open (Name : Ghdl_C_String) return Integer;
+ pragma Export (C, vpi_mcd_open, "vpi_mcd_open");
+
+ -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value,
+ -- p_vpi_time when, int flags)
+ function vpi_put_value (aObj : vpiHandle;
+ aValue : p_vpi_value;
+ aWhen : p_vpi_time;
+ aFlags : integer)
+ return vpiHandle;
+ pragma Export (C, vpi_put_value, "vpi_put_value");
+
+ -- void vpi_register_systf(const struct t_vpi_systf_data*ss)
+ procedure vpi_register_systf (aSs : Address);
+ pragma Export (C, vpi_register_systf, "vpi_register_systf");
+
+ -- int vpi_remove_cb(vpiHandle ref)
+ function vpi_remove_cb (Ref : vpiHandle) return integer;
+ pragma Export (C, vpi_remove_cb, "vpi_remove_cb");
+
+ -- void vpi_vprintf(const char*fmt, va_list ap)
+ procedure vpi_vprintf (Fmt: Address; Ap: Address);
+ pragma Export (C, vpi_vprintf, "vpi_vprintf");
+
+-------------------------------------------------------------------------------
+-- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * *
+-------------------------------------------------------------------------------
+
+ procedure Register;
+
+end Grt.Vpi;
+
diff --git a/src/translate/grt/grt-vstrings.adb b/src/translate/grt/grt-vstrings.adb
new file mode 100644
index 000000000..30c58ab41
--- /dev/null
+++ b/src/translate/grt/grt-vstrings.adb
@@ -0,0 +1,422 @@
+-- GHDL Run Time (GRT) - variable strings.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Errors; use Grt.Errors;
+with Grt.C; use Grt.C;
+
+package body Grt.Vstrings is
+ procedure Free (Fs : Fat_String_Acc);
+ pragma Import (C, Free);
+
+ function Malloc (Len : Natural) return Fat_String_Acc;
+ pragma Import (C, Malloc);
+
+ function Realloc (Ptr : Fat_String_Acc; Len : Natural)
+ return Fat_String_Acc;
+ pragma Import (C, Realloc);
+
+
+ procedure Free (Vstr : in out Vstring) is
+ begin
+ Free (Vstr.Str);
+ Vstr := (Str => null,
+ Max => 0,
+ Len => 0);
+ end Free;
+
+ procedure Grow (Vstr : in out Vstring; Sum : Natural)
+ is
+ Nlen : constant Natural := Vstr.Len + Sum;
+ Nmax : Natural;
+ begin
+ Vstr.Len := Nlen;
+ if Nlen <= Vstr.Max then
+ return;
+ end if;
+ if Vstr.Max = 0 then
+ Nmax := 32;
+ else
+ Nmax := Vstr.Max;
+ end if;
+ while Nmax < Nlen loop
+ Nmax := Nmax * 2;
+ end loop;
+ Vstr.Str := Realloc (Vstr.Str, Nmax);
+ if Vstr.Str = null then
+ Internal_Error ("grt.vstrings.grow: memory exhausted");
+ end if;
+ Vstr.Max := Nmax;
+ end Grow;
+
+ procedure Append (Vstr : in out Vstring; C : Character)
+ is
+ begin
+ Grow (Vstr, 1);
+ Vstr.Str (Vstr.Len) := C;
+ end Append;
+
+ procedure Append (Vstr : in out Vstring; Str : String)
+ is
+ S : constant Natural := Vstr.Len;
+ begin
+ Grow (Vstr, Str'Length);
+ Vstr.Str (S + 1 .. S + Str'Length) := Str;
+ end Append;
+
+ procedure Append (Vstr : in out Vstring; Str : Ghdl_C_String)
+ is
+ S : constant Natural := Vstr.Len;
+ L : constant Natural := strlen (Str);
+ begin
+ Grow (Vstr, L);
+ Vstr.Str (S + 1 .. S + L) := Str (1 .. L);
+ end Append;
+
+ function Length (Vstr : Vstring) return Natural is
+ begin
+ return Vstr.Len;
+ end Length;
+
+ procedure Truncate (Vstr : in out Vstring; Len : Natural) is
+ begin
+ if Len > Vstr.Len then
+ Internal_Error ("grt.vstrings.truncate: bad len");
+ end if;
+ Vstr.Len := Len;
+ end Truncate;
+
+ procedure Put (Stream : FILEs; Vstr : Vstring)
+ is
+ S : size_t;
+ begin
+ S := size_t (Vstr.Len);
+ if S > 0 then
+ S := fwrite (Vstr.Str (1)'Address, S, 1, Stream);
+ end if;
+ end Put;
+
+ procedure Free (Rstr : in out Rstring) is
+ begin
+ Free (Rstr.Str);
+ Rstr := (Str => null,
+ Max => 0,
+ First => 0);
+ end Free;
+
+ function Length (Rstr : Rstring) return Natural is
+ begin
+ return Rstr.Max + 1 - Rstr.First;
+ end Length;
+
+ procedure Grow (Rstr : in out Rstring; Min : Natural)
+ is
+ Len : constant Natural := Length (Rstr);
+ Nlen : constant Natural := Len + Min;
+ Nstr : Fat_String_Acc;
+ Nfirst : Natural;
+ Nmax : Natural;
+ begin
+ if Nlen <= Rstr.Max then
+ return;
+ end if;
+ if Rstr.Max = 0 then
+ Nmax := 32;
+ else
+ Nmax := Rstr.Max;
+ end if;
+ while Nmax < Nlen loop
+ Nmax := Nmax * 2;
+ end loop;
+ Nstr := Malloc (Nmax);
+ Nfirst := Nmax + 1 - Len;
+ if Rstr.Str /= null then
+ Nstr (Nfirst .. Nmax) := Rstr.Str (Rstr.First .. Rstr.Max);
+ Free (Rstr.Str);
+ end if;
+ Rstr := (Str => Nstr,
+ Max => Nmax,
+ First => Nfirst);
+ end Grow;
+
+ procedure Prepend (Rstr : in out Rstring; C : Character)
+ is
+ begin
+ Grow (Rstr, 1);
+ Rstr.First := Rstr.First - 1;
+ Rstr.Str (Rstr.First) := C;
+ end Prepend;
+
+ procedure Prepend (Rstr : in out Rstring; Str : String)
+ is
+ begin
+ Grow (Rstr, Str'Length);
+ Rstr.First := Rstr.First - Str'Length;
+ Rstr.Str (Rstr.First .. Rstr.First + Str'Length - 1) := Str;
+ end Prepend;
+
+ procedure Prepend (Rstr : in out Rstring; Str : Ghdl_C_String)
+ is
+ L : constant Natural := strlen (Str);
+ begin
+ Grow (Rstr, L);
+ Rstr.First := Rstr.First - L;
+ Rstr.Str (Rstr.First .. Rstr.First + L - 1) := Str (1 .. L);
+ end Prepend;
+
+ function Get_Address (Rstr : Rstring) return Address
+ is
+ begin
+ return Rstr.Str (Rstr.First)'Address;
+ end Get_Address;
+
+ procedure Copy (Rstr : Rstring; Str : in out String; Len : out Natural)
+ is
+ begin
+ Len := Length (Rstr);
+ if Len > Str'Length then
+ Str := Rstr.Str (Rstr.First .. Rstr.First + Str'Length - 1);
+ else
+ Str (Str'First .. Str'First + Len - 1) :=
+ Rstr.Str (Rstr.First .. Rstr.First + Len - 1);
+ end if;
+ end Copy;
+
+ procedure Put (Stream : FILEs; Rstr : Rstring)
+ is
+ S : size_t;
+ pragma Unreferenced (S);
+ begin
+ S := fwrite (Get_Address (Rstr), size_t (Length (Rstr)), 1, Stream);
+ end Put;
+
+ generic
+ type Ntype is range <>;
+ --Max_Len : Natural;
+ procedure Gen_To_String (Str : out String; First : out Natural; N : Ntype);
+
+ procedure Gen_To_String (Str : out String; First : out Natural; N : Ntype)
+ is
+ subtype R_Type is String (1 .. Str'Length);
+ S : R_Type renames Str;
+ P : Natural := S'Last;
+ V : Ntype;
+ begin
+ if N > 0 then
+ V := -N;
+ else
+ V := N;
+ end if;
+ loop
+ S (P) := Character'Val (48 - (V rem 10));
+ V := V / 10;
+ exit when V = 0;
+ P := P - 1;
+ end loop;
+ if N < 0 then
+ P := P - 1;
+ S (P) := '-';
+ end if;
+ First := P;
+ end Gen_To_String;
+
+ procedure To_String_I32 is new Gen_To_String (Ntype => Ghdl_I32);
+
+ procedure To_String (Str : out String; First : out Natural; N : Ghdl_I32)
+ renames To_String_I32;
+
+ procedure To_String_I64 is new Gen_To_String (Ntype => Ghdl_I64);
+
+ procedure To_String (Str : out String; First : out Natural; N : Ghdl_I64)
+ renames To_String_I64;
+
+ procedure To_String (Str : out String; Last : out Natural; N : Ghdl_F64)
+ is
+ function Trunc (V : Ghdl_F64) return Ghdl_F64;
+ pragma Import (C, Trunc);
+
+ P : Natural := Str'First;
+ V : Ghdl_F64;
+ Vmax : Ghdl_F64;
+ Vd : Ghdl_F64;
+ Exp : Integer;
+ D : Integer;
+ B : Boolean;
+ begin
+ -- Handle sign.
+ if N < 0.0 then
+ Str (P) := '-';
+ P := P + 1;
+ V := -N;
+ else
+ V := N;
+ end if;
+
+ -- Compute the mantissa.
+ -- and normalize V in [0 .. 10.0[
+ -- FIXME: should do a dichotomy.
+ if V = 0.0 then
+ Exp := 0;
+ elsif V < 1.0 then
+ Exp := 0;
+ loop
+ exit when V >= 1.0;
+ Exp := Exp - 1;
+ V := V * 10.0;
+ end loop;
+ else
+ Exp := 0;
+ loop
+ exit when V < 10.0;
+ Exp := Exp + 1;
+ V := V / 10.0;
+ end loop;
+ end if;
+
+ Vmax := 10.0 ** (1 - 15);
+ for I in 0 .. 15 loop
+ -- Vd := Ghdl_F64'Truncation (V);
+ Vd := Trunc (V);
+ Str (P) := Character'Val (48 + Integer (Vd));
+ P := P + 1;
+ V := (V - Vd) * 10.0;
+
+ if I = 0 then
+ Str (P) := '.';
+ P := P + 1;
+ end if;
+ exit when I > 0 and V < Vmax;
+ Vmax := Vmax * 10.0;
+ end loop;
+
+ if Exp /= 0 then
+ -- LRM93 14.3
+ -- if the exponent is present, the `e' is written as a lower case
+ -- character.
+ Str (P) := 'e';
+ P := P + 1;
+
+ if Exp < 0 then
+ Str (P) := '-';
+ P := P + 1;
+ Exp := -Exp;
+ end if;
+ B := False;
+ for I in 0 .. 4 loop
+ D := (Exp / 10000) mod 10;
+ if D /= 0 or B or I = 4 then
+ Str (P) := Character'Val (48 + D);
+ P := P + 1;
+ B := True;
+ end if;
+ Exp := (Exp - D * 10000) * 10;
+ end loop;
+ end if;
+
+ Last := P - 1;
+ end To_String;
+
+ procedure To_String (Str : out String_Real_Digits;
+ Last : out Natural;
+ N : Ghdl_F64;
+ Nbr_Digits : Ghdl_I32)
+ is
+ procedure Snprintf_Nf (Str : in out String;
+ Len : Natural;
+ Ndigits : Ghdl_I32;
+ V : Ghdl_F64);
+ pragma Import (C, Snprintf_Nf, "__ghdl_snprintf_nf");
+ begin
+ Snprintf_Nf (Str, Str'Length, Nbr_Digits, N);
+ Last := strlen (To_Ghdl_C_String (Str'Address));
+ end To_String;
+
+ procedure To_String (Str : out String_Real_Digits;
+ Last : out Natural;
+ N : Ghdl_F64;
+ Format : Ghdl_C_String)
+ is
+ procedure Snprintf_Fmtf (Str : in out String;
+ Len : Natural;
+ Format : Ghdl_C_String;
+ V : Ghdl_F64);
+ pragma Import (C, Snprintf_Fmtf, "__ghdl_snprintf_fmtf");
+ begin
+ -- FIXME: check format ('%', f/g/e/a)
+ Snprintf_Fmtf (Str, Str'Length, Format, N);
+ Last := strlen (To_Ghdl_C_String (Str'Address));
+ end To_String;
+
+ procedure To_String (Str : out String_Time_Unit;
+ First : out Natural;
+ Value : Ghdl_I64;
+ Unit : Ghdl_I64)
+ is
+ V, U : Ghdl_I64;
+ D : Natural;
+ P : Natural := Str'Last;
+ Has_Digits : Boolean;
+ begin
+ -- Always work on negative values.
+ if Value > 0 then
+ V := -Value;
+ else
+ V := Value;
+ end if;
+
+ Has_Digits := False;
+ U := Unit;
+ loop
+ if U = 1 then
+ if Has_Digits then
+ Str (P) := '.';
+ P := P - 1;
+ else
+ Has_Digits := True;
+ end if;
+ end if;
+
+ D := Natural (-(V rem 10));
+ if D /= 0 or else Has_Digits then
+ Str (P) := Character'Val (48 + D);
+ P := P - 1;
+ Has_Digits := True;
+ end if;
+ U := U / 10;
+ V := V / 10;
+ exit when V = 0 and then U = 0;
+ end loop;
+ if not Has_Digits then
+ Str (P) := '0';
+ else
+ P := P + 1;
+ end if;
+ if Value < 0 then
+ P := P - 1;
+ Str (P) := '-';
+ end if;
+ First := P;
+ end To_String;
+end Grt.Vstrings;
diff --git a/src/translate/grt/grt-vstrings.ads b/src/translate/grt/grt-vstrings.ads
new file mode 100644
index 000000000..94967bb0f
--- /dev/null
+++ b/src/translate/grt/grt-vstrings.ads
@@ -0,0 +1,143 @@
+-- GHDL Run Time (GRT) - variable strings.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Grt.Stdio; use Grt.Stdio;
+with Grt.Types; use Grt.Types;
+with System; use System;
+
+package Grt.Vstrings is
+ -- A Vstring (Variable string) is an object which contains an unbounded
+ -- string.
+ type Vstring is limited private;
+
+ -- Deallocate all storage internally allocated.
+ procedure Free (Vstr : in out Vstring);
+
+ -- Append a character.
+ procedure Append (Vstr : in out Vstring; C : Character);
+
+ -- Append a string.
+ procedure Append (Vstr : in out Vstring; Str : String);
+
+ -- Append a C string.
+ procedure Append (Vstr : in out Vstring; Str : Ghdl_C_String);
+
+ -- Get length of VSTR.
+ function Length (Vstr : Vstring) return Natural;
+
+ -- Truncate VSTR to LEN.
+ -- It is an error if LEN is greater than the current length.
+ procedure Truncate (Vstr : in out Vstring; Len : Natural);
+
+ -- Display VSTR.
+ procedure Put (Stream : FILEs; Vstr : Vstring);
+
+
+ -- A Rstring is link a Vstring but characters can only be prepended.
+ type Rstring is limited private;
+
+ -- Deallocate storage associated with Rstr.
+ procedure Free (Rstr : in out Rstring);
+
+ -- Prepend characters or strings.
+ procedure Prepend (Rstr : in out Rstring; C : Character);
+ procedure Prepend (Rstr : in out Rstring; Str : String);
+ procedure Prepend (Rstr : in out Rstring; Str : Ghdl_C_String);
+
+ -- Get the length of RSTR.
+ function Length (Rstr : Rstring) return Natural;
+
+ -- Return the address of the first character of RSTR.
+ function Get_Address (Rstr : Rstring) return Address;
+
+ -- Display RSTR.
+ procedure Put (Stream : FILEs; Rstr : Rstring);
+
+ -- Copy RSTR to STR, and return length of the string to LEN.
+ procedure Copy (Rstr : Rstring; Str : in out String; Len : out Natural);
+
+ -- Write the image of N into STR padded to the right. FIRST is the index
+ -- of the first character, so the result is in STR (FIRST .. STR'last).
+ -- Requires at least 11 characters.
+ procedure To_String (Str : out String; First : out Natural; N : Ghdl_I32);
+
+ -- Write the image of N into STR padded to the right. FIRST is the index
+ -- of the first character, so the result is in STR (FIRST .. STR'last).
+ -- Requires at least 21 characters.
+ procedure To_String (Str : out String; First : out Natural; N : Ghdl_I64);
+
+ -- Write the image of N into STR. LAST is the index of the last character,
+ -- so the result is in STR (STR'first .. LAST).
+ -- Requires at least 24 characters.
+ -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1)
+ -- + exp_digits (4) -> 24.
+ procedure To_String (Str : out String; Last : out Natural; N : Ghdl_F64);
+
+ subtype String_Real_Digits is String (1 .. 128);
+
+ -- Write the image of N into STR using NBR_DIGITS digits after the decimal
+ -- point.
+ procedure To_String (Str : out String_Real_Digits;
+ Last : out Natural;
+ N : Ghdl_F64;
+ Nbr_Digits : Ghdl_I32);
+
+ subtype String_Real_Format is String (1 .. 128);
+
+ -- Write the image of N into STR using NBR_DIGITS digits after the decimal
+ -- point.
+ procedure To_String (Str : out String_Real_Digits;
+ Last : out Natural;
+ N : Ghdl_F64;
+ Format : Ghdl_C_String);
+
+ -- Write the image of VALUE to STR using UNIT as unit. The output is in
+ -- STR (FIRST .. STR'last).
+ subtype String_Time_Unit is String (1 .. 22);
+ procedure To_String (Str : out String_Time_Unit;
+ First : out Natural;
+ Value : Ghdl_I64;
+ Unit : Ghdl_I64);
+
+private
+ subtype Fat_String is String (Positive);
+ type Fat_String_Acc is access Fat_String;
+
+ type Vstring is record
+ Str : Fat_String_Acc := null;
+ Max : Natural := 0;
+ Len : Natural := 0;
+ end record;
+
+ type Rstring is record
+ -- String whose bounds is (1 .. Max).
+ Str : Fat_String_Acc := null;
+
+ -- Last index in STR.
+ Max : Natural := 0;
+
+ -- Index of the first character.
+ First : Natural := 1;
+ end record;
+end Grt.Vstrings;
diff --git a/src/translate/grt/grt-waves.adb b/src/translate/grt/grt-waves.adb
new file mode 100644
index 000000000..63bdb9a54
--- /dev/null
+++ b/src/translate/grt/grt-waves.adb
@@ -0,0 +1,1632 @@
+-- GHDL Run Time (GRT) - wave dumper (GHW) module.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with Interfaces; use Interfaces;
+with System.Storage_Elements; -- Work around GNAT bug.
+pragma Unreferenced (System.Storage_Elements);
+with Grt.Types; use Grt.Types;
+with Grt.Avhpi; use Grt.Avhpi;
+with Grt.Stdio; use Grt.Stdio;
+with Grt.C; use Grt.C;
+with Grt.Errors; use Grt.Errors;
+with Grt.Astdio; use Grt.Astdio;
+with Grt.Hooks; use Grt.Hooks;
+with Grt.Table;
+with Grt.Avls; use Grt.Avls;
+with Grt.Rtis; use Grt.Rtis;
+with Grt.Rtis_Addr; use Grt.Rtis_Addr;
+with Grt.Rtis_Utils;
+with Grt.Rtis_Types;
+with Grt.Signals; use Grt.Signals;
+with System; use System;
+with Grt.Vstrings; use Grt.Vstrings;
+
+pragma Elaborate_All (Grt.Rtis_Utils);
+pragma Elaborate_All (Grt.Table);
+
+package body Grt.Waves is
+ -- Waves filename.
+ Wave_Filename : String_Access := null;
+ -- Stream corresponding to the GHW filename.
+ Wave_Stream : FILEs;
+
+ Ghw_Hie_Design : constant Unsigned_8 := 1;
+ Ghw_Hie_Block : constant Unsigned_8 := 3;
+ Ghw_Hie_Generate_If : constant Unsigned_8 := 4;
+ Ghw_Hie_Generate_For : constant Unsigned_8 := 5;
+ Ghw_Hie_Instance : constant Unsigned_8 := 6;
+ Ghw_Hie_Package : constant Unsigned_8 := 7;
+ Ghw_Hie_Process : constant Unsigned_8 := 13;
+ Ghw_Hie_Generic : constant Unsigned_8 := 14;
+ Ghw_Hie_Eos : constant Unsigned_8 := 15; -- End of scope.
+ Ghw_Hie_Signal : constant Unsigned_8 := 16; -- Signal.
+ Ghw_Hie_Port_In : constant Unsigned_8 := 17; -- Port
+ Ghw_Hie_Port_Out : constant Unsigned_8 := 18; -- Port
+ Ghw_Hie_Port_Inout : constant Unsigned_8 := 19; -- Port
+ Ghw_Hie_Port_Buffer : constant Unsigned_8 := 20; -- Port
+ Ghw_Hie_Port_Linkage : constant Unsigned_8 := 21; -- Port
+
+ pragma Unreferenced (Ghw_Hie_Design);
+ pragma Unreferenced (Ghw_Hie_Generic);
+
+ -- Return TRUE if OPT is an option for wave.
+ function Wave_Option (Opt : String) return Boolean
+ is
+ F : constant Natural := Opt'First;
+ begin
+ if Opt'Length < 6 or else Opt (F .. F + 5) /= "--wave" then
+ return False;
+ end if;
+ if Opt'Length > 6 and then Opt (F + 6) = '=' then
+ -- Add an extra NUL character.
+ Wave_Filename := new String (1 .. Opt'Length - 7 + 1);
+ Wave_Filename (1 .. Opt'Length - 7) := Opt (F + 7 .. Opt'Last);
+ Wave_Filename (Wave_Filename'Last) := NUL;
+ return True;
+ else
+ return False;
+ end if;
+ end Wave_Option;
+
+ procedure Wave_Help is
+ begin
+ Put_Line (" --wave=FILENAME dump signal values into a wave file");
+ end Wave_Help;
+
+ procedure Wave_Put (Str : String)
+ is
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (Str'Address, Str'Length, 1, Wave_Stream);
+ end Wave_Put;
+
+ procedure Wave_Putc (C : Character)
+ is
+ R : int;
+ pragma Unreferenced (R);
+ begin
+ R := fputc (Character'Pos (C), Wave_Stream);
+ end Wave_Putc;
+
+ procedure Wave_Newline is
+ begin
+ Wave_Putc (Nl);
+ end Wave_Newline;
+
+ procedure Wave_Put_Byte (B : Unsigned_8)
+ is
+ V : Unsigned_8 := B;
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (V'Address, 1, 1, Wave_Stream);
+ end Wave_Put_Byte;
+
+ procedure Wave_Put_ULEB128 (Val : Ghdl_E32)
+ is
+ V : Ghdl_E32;
+ R : Ghdl_E32;
+ begin
+ V := Val;
+ loop
+ R := V mod 128;
+ V := V / 128;
+ if V = 0 then
+ Wave_Put_Byte (Unsigned_8 (R));
+ exit;
+ else
+ Wave_Put_Byte (Unsigned_8 (128 + R));
+ end if;
+ end loop;
+ end Wave_Put_ULEB128;
+
+ procedure Wave_Put_SLEB128 (Val : Ghdl_I32)
+ is
+ function To_Ghdl_U32 is new Ada.Unchecked_Conversion
+ (Ghdl_I32, Ghdl_U32);
+ V : Ghdl_U32 := To_Ghdl_U32 (Val);
+
+-- function Shift_Right_Arithmetic (Value : Ghdl_U32; Amount : Natural)
+-- return Ghdl_U32;
+-- pragma Import (Intrinsic, Shift_Right_Arithmetic);
+ R : Unsigned_8;
+ begin
+ loop
+ R := Unsigned_8 (V mod 128);
+ V := Shift_Right_Arithmetic (V, 7);
+ if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0)
+ then
+ Wave_Put_Byte (R);
+ exit;
+ else
+ Wave_Put_Byte (R or 16#80#);
+ end if;
+ end loop;
+ end Wave_Put_SLEB128;
+
+ procedure Wave_Put_LSLEB128 (Val : Ghdl_I64)
+ is
+ function To_Ghdl_U64 is new Ada.Unchecked_Conversion
+ (Ghdl_I64, Ghdl_U64);
+ V : Ghdl_U64 := To_Ghdl_U64 (Val);
+
+ R : Unsigned_8;
+ begin
+ loop
+ R := Unsigned_8 (V mod 128);
+ V := Shift_Right_Arithmetic (V, 7);
+ if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0)
+ then
+ Wave_Put_Byte (R);
+ exit;
+ else
+ Wave_Put_Byte (R or 16#80#);
+ end if;
+ end loop;
+ end Wave_Put_LSLEB128;
+
+ procedure Wave_Put_I32 (Val : Ghdl_I32)
+ is
+ V : Ghdl_I32 := Val;
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (V'Address, 4, 1, Wave_Stream);
+ end Wave_Put_I32;
+
+ procedure Wave_Put_I64 (Val : Ghdl_I64)
+ is
+ V : Ghdl_I64 := Val;
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (V'Address, 8, 1, Wave_Stream);
+ end Wave_Put_I64;
+
+ procedure Wave_Put_F64 (F64 : Ghdl_F64)
+ is
+ V : Ghdl_F64 := F64;
+ R : size_t;
+ pragma Unreferenced (R);
+ begin
+ R := fwrite (V'Address, Ghdl_F64'Size / Storage_Unit, 1, Wave_Stream);
+ end Wave_Put_F64;
+
+ procedure Wave_Puts (Str : Ghdl_C_String) is
+ begin
+ Put (Wave_Stream, Str);
+ end Wave_Puts;
+
+ procedure Write_Value (Value : Value_Union; Mode : Mode_Type) is
+ begin
+ case Mode is
+ when Mode_B1 =>
+ Wave_Put_Byte (Ghdl_B1'Pos (Value.B1));
+ when Mode_E8 =>
+ Wave_Put_Byte (Ghdl_E8'Pos (Value.E8));
+ when Mode_E32 =>
+ Wave_Put_ULEB128 (Value.E32);
+ when Mode_I32 =>
+ Wave_Put_SLEB128 (Value.I32);
+ when Mode_I64 =>
+ Wave_Put_LSLEB128 (Value.I64);
+ when Mode_F64 =>
+ Wave_Put_F64 (Value.F64);
+ end case;
+ end Write_Value;
+
+ subtype Section_Name is String (1 .. 4);
+ type Header_Type is record
+ Name : Section_Name;
+ Pos : long;
+ end record;
+
+ package Section_Table is new Grt.Table
+ (Table_Component_Type => Header_Type,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 16);
+
+ -- Create a new section.
+ -- Write the header in the file.
+ -- Save the location for the directory.
+ procedure Wave_Section (Name : Section_Name) is
+ begin
+ Section_Table.Append (Header_Type'(Name => Name,
+ Pos => ftell (Wave_Stream)));
+ Wave_Put (Name);
+ end Wave_Section;
+
+ procedure Wave_Write_Size_Order is
+ begin
+ -- Byte order, 1 byte.
+ -- 0: bad, 1 : little-endian, 2 : big endian.
+ declare
+ type Byte_Arr is array (0 .. 3) of Unsigned_8;
+ function To_Byte_Arr is new Ada.Unchecked_Conversion
+ (Source => Unsigned_32, Target => Byte_Arr);
+ B4 : constant Byte_Arr := To_Byte_Arr (16#11_22_33_44#);
+ V : Unsigned_8;
+ begin
+ if B4 (0) = 16#11# then
+ -- Big endian.
+ V := 2;
+ elsif B4 (0) = 16#44# then
+ -- Little endian.
+ V := 1;
+ else
+ -- Unknown endian.
+ V := 0;
+ end if;
+ Wave_Put_Byte (V);
+ end;
+ -- Word size, 1 byte.
+ Wave_Put_Byte (Integer'Size / 8);
+ -- File offset size, 1 byte
+ Wave_Put_Byte (1);
+ -- Unused, must be zero (MBZ).
+ Wave_Put_Byte (0);
+ end Wave_Write_Size_Order;
+
+ procedure Wave_Write_Directory
+ is
+ Pos : long;
+ begin
+ Pos := ftell (Wave_Stream);
+ Wave_Section ("DIR" & NUL);
+ Wave_Write_Size_Order;
+ Wave_Put_I32 (Ghdl_I32 (Section_Table.Last));
+ for I in Section_Table.First .. Section_Table.Last loop
+ Wave_Put (Section_Table.Table (I).Name);
+ Wave_Put_I32 (Ghdl_I32 (Section_Table.Table (I).Pos));
+ end loop;
+ Wave_Put ("EOD" & NUL);
+
+ Wave_Section ("TAI" & NUL);
+ Wave_Write_Size_Order;
+ Wave_Put_I32 (Ghdl_I32 (Pos));
+ end Wave_Write_Directory;
+
+ -- Called before elaboration.
+ procedure Wave_Init
+ is
+ Mode : constant String := "wb" & NUL;
+ begin
+ if Wave_Filename = null then
+ Wave_Stream := NULL_Stream;
+ return;
+ end if;
+ if Wave_Filename.all = "-" & NUL then
+ Wave_Stream := stdout;
+ else
+ Wave_Stream := fopen (Wave_Filename.all'Address, Mode'Address);
+ if Wave_Stream = NULL_Stream then
+ Error_C ("cannot open ");
+ Error_E (Wave_Filename (Wave_Filename'First
+ .. Wave_Filename'Last - 1));
+ return;
+ end if;
+ end if;
+ end Wave_Init;
+
+ procedure Write_File_Header
+ is
+ begin
+ -- Magic, 9 bytes.
+ Wave_Put ("GHDLwave" & Nl);
+ -- Header length.
+ Wave_Put_Byte (16);
+ -- Version-major, 1 byte.
+ Wave_Put_Byte (0);
+ -- Version-minor, 1 byte.
+ Wave_Put_Byte (1);
+
+ Wave_Write_Size_Order;
+ end Write_File_Header;
+
+ procedure Avhpi_Error (Err : AvhpiErrorT)
+ is
+ pragma Unreferenced (Err);
+ begin
+ Put_Line ("Waves.Avhpi_Error!");
+ null;
+ end Avhpi_Error;
+
+ package Str_Table is new Grt.Table
+ (Table_Component_Type => Ghdl_C_String,
+ Table_Index_Type => AVL_Value,
+ Table_Low_Bound => 1,
+ Table_Initial => 16);
+
+ package Str_AVL is new Grt.Table
+ (Table_Component_Type => AVL_Node,
+ Table_Index_Type => AVL_Nid,
+ Table_Low_Bound => AVL_Root,
+ Table_Initial => 16);
+
+ Strings_Len : Natural := 0;
+
+ function Str_Compare (L, R : AVL_Value) return Integer
+ is
+ Ls, Rs : Ghdl_C_String;
+ begin
+ Ls := Str_Table.Table (L);
+ Rs := Str_Table.Table (R);
+ if L = R then
+ return 0;
+ end if;
+ return Strcmp (Ls, Rs);
+ end Str_Compare;
+
+ procedure Disp_Str_Avl (N : AVL_Nid) is
+ begin
+ Put (stdout, "node: ");
+ Put_I32 (stdout, Ghdl_I32 (N));
+ New_Line (stdout);
+ Put (stdout, " left: ");
+ Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Left));
+ New_Line (stdout);
+ Put (stdout, " right: ");
+ Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Right));
+ New_Line (stdout);
+ Put (stdout, " height: ");
+ Put_I32 (stdout, Str_AVL.Table (N).Height);
+ New_Line (stdout);
+ Put (stdout, " str: ");
+ --Put (stdout, Str_AVL.Table (N).Val);
+ New_Line (stdout);
+ end Disp_Str_Avl;
+
+ pragma Unreferenced (Disp_Str_Avl);
+
+ function Create_Str_Index (Str : Ghdl_C_String) return AVL_Value
+ is
+ Res : AVL_Nid;
+ begin
+ Str_Table.Append (Str);
+ Str_AVL.Append (AVL_Node'(Val => Str_Table.Last,
+ Left | Right => AVL_Nil,
+ Height => 1));
+ Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)),
+ Str_Compare'Access,
+ Str_AVL.Last, Res);
+ if Res /= Str_AVL.Last then
+ Str_AVL.Decrement_Last;
+ Str_Table.Decrement_Last;
+ else
+ Strings_Len := Strings_Len + strlen (Str);
+ end if;
+ return Str_AVL.Table (Res).Val;
+ end Create_Str_Index;
+
+ pragma Unreferenced (Create_Str_Index);
+
+ procedure Create_String_Id (Str : Ghdl_C_String)
+ is
+ Res : AVL_Nid;
+ begin
+ if Str = null then
+ return;
+ end if;
+ Str_Table.Append (Str);
+ Str_AVL.Append (AVL_Node'(Val => Str_Table.Last,
+ Left | Right => AVL_Nil,
+ Height => 1));
+ Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)),
+ Str_Compare'Access,
+ Str_AVL.Last, Res);
+ if Res /= Str_AVL.Last then
+ Str_AVL.Decrement_Last;
+ Str_Table.Decrement_Last;
+ else
+ Strings_Len := Strings_Len + strlen (Str);
+ end if;
+ end Create_String_Id;
+
+ function Get_String (Str : Ghdl_C_String) return AVL_Value
+ is
+ H, L, M : AVL_Value;
+ Diff : Integer;
+ begin
+ L := Str_Table.First;
+ H := Str_Table.Last;
+ loop
+ M := (L + H) / 2;
+ Diff := Strcmp (Str, Str_Table.Table (M));
+ if Diff = 0 then
+ return M;
+ elsif Diff < 0 then
+ H := M - 1;
+ else
+ L := M + 1;
+ end if;
+ exit when L > H;
+ end loop;
+ return 0;
+ end Get_String;
+
+ procedure Write_String_Id (Str : Ghdl_C_String) is
+ begin
+ if Str = null then
+ Wave_Put_Byte (0);
+ else
+ Wave_Put_ULEB128 (Ghdl_E32 (Get_String (Str)));
+ end if;
+ end Write_String_Id;
+
+ type Type_Node is record
+ Type_Rti : Ghdl_Rti_Access;
+ Context : Rti_Context;
+ end record;
+
+ package Types_Table is new Grt.Table
+ (Table_Component_Type => Type_Node,
+ Table_Index_Type => AVL_Value,
+ Table_Low_Bound => 1,
+ Table_Initial => 16);
+
+ package Types_AVL is new Grt.Table
+ (Table_Component_Type => AVL_Node,
+ Table_Index_Type => AVL_Nid,
+ Table_Low_Bound => AVL_Root,
+ Table_Initial => 16);
+
+ function Type_Compare (L, R : AVL_Value) return Integer
+ is
+ function To_Ia is new
+ Ada.Unchecked_Conversion (Ghdl_Rti_Access, Integer_Address);
+
+ function "<" (L, R : Ghdl_Rti_Access) return Boolean is
+ begin
+ return To_Ia (L) < To_Ia (R);
+ end "<";
+
+ Ls : Type_Node renames Types_Table.Table (L);
+ Rs : Type_Node renames Types_Table.Table (R);
+ begin
+ if Ls.Type_Rti /= Rs.Type_Rti then
+ if Ls.Type_Rti < Rs.Type_Rti then
+ return -1;
+ else
+ return 1;
+ end if;
+ end if;
+ if Ls.Context.Block /= Rs.Context.Block then
+ if Ls.Context.Block < Rs.Context.Block then
+ return -1;
+ else
+ return +1;
+ end if;
+ end if;
+ if Ls.Context.Base /= Rs.Context.Base then
+ if Ls.Context.Base < Rs.Context.Base then
+ return -1;
+ else
+ return +1;
+ end if;
+ end if;
+ return 0;
+ end Type_Compare;
+
+ -- Try to find type (RTI, CTXT) in the types_AVL table.
+ -- The first step is to canonicalize CTXT, so that it is the CTXT of
+ -- the type (and not a sub-scope of it).
+ procedure Find_Type (Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ N_Ctxt : out Rti_Context;
+ Id : out AVL_Nid)
+ is
+ Depth : Ghdl_Rti_Depth;
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8 =>
+ N_Ctxt := Null_Context;
+ when Ghdl_Rtik_Port
+ | Ghdl_Rtik_Signal =>
+ N_Ctxt := Ctxt;
+ when others =>
+ -- Compute the canonical context.
+ if Rti.Max_Depth < Rti.Depth then
+ Internal_Error ("grt.waves.find_type");
+ end if;
+ Depth := Rti.Max_Depth;
+ if Depth = 0 or else Ctxt.Block = null then
+ N_Ctxt := Null_Context;
+ else
+ N_Ctxt := Ctxt;
+ while N_Ctxt.Block.Depth > Depth loop
+ N_Ctxt := Get_Parent_Context (N_Ctxt);
+ end loop;
+ end if;
+ end case;
+
+ -- If the type is already known, return now.
+ -- Otherwise, ID is set to AVL_Nil.
+ Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => N_Ctxt));
+ Id := Find_Node
+ (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)),
+ Type_Compare'Access,
+ Types_Table.Last);
+ Types_Table.Decrement_Last;
+ end Find_Type;
+
+ procedure Write_Type_Id (Tid : AVL_Nid) is
+ begin
+ Wave_Put_ULEB128 (Ghdl_E32 (Types_AVL.Table (Tid).Val));
+ end Write_Type_Id;
+
+ procedure Write_Type_Id (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
+ is
+ N_Ctxt : Rti_Context;
+ Res : AVL_Nid;
+ begin
+ Find_Type (Rti, Ctxt, N_Ctxt, Res);
+ if Res = AVL_Nil then
+ -- raise Program_Error;
+ Internal_Error ("write_type_id");
+ end if;
+ Write_Type_Id (Res);
+ end Write_Type_Id;
+
+ procedure Add_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
+ is
+ Res : AVL_Nid;
+ begin
+ -- Then, create the type.
+ Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => Ctxt));
+ Types_AVL.Append (AVL_Node'(Val => Types_Table.Last,
+ Left | Right => AVL_Nil,
+ Height => 1));
+
+ Get_Node
+ (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)),
+ Type_Compare'Access,
+ Types_AVL.Last, Res);
+ if Res /= Types_AVL.Last then
+ --raise Program_Error;
+ Internal_Error ("wave.create_type(2)");
+ end if;
+ end Add_Type;
+
+ procedure Create_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
+ is
+ N_Ctxt : Rti_Context;
+ Res : AVL_Nid;
+ begin
+ Find_Type (Rti, Ctxt, N_Ctxt, Res);
+ if Res /= AVL_Nil then
+ return;
+ end if;
+
+ -- First, create all the types it depends on.
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8 =>
+ declare
+ Enum : Ghdl_Rtin_Type_Enum_Acc;
+ begin
+ Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Create_String_Id (Enum.Name);
+ for I in 1 .. Enum.Nbr loop
+ Create_String_Id (Enum.Names (I - 1));
+ end loop;
+ end;
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ Arr : Ghdl_Rtin_Subtype_Array_Acc;
+ B_Ctxt : Rti_Context;
+ begin
+ Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Create_String_Id (Arr.Name);
+ if Rti_Complex_Type (Rti) then
+ B_Ctxt := Ctxt;
+ else
+ B_Ctxt := N_Ctxt;
+ end if;
+ Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), B_Ctxt);
+ end;
+ when Ghdl_Rtik_Type_Array =>
+ declare
+ Arr : Ghdl_Rtin_Type_Array_Acc;
+ begin
+ Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti);
+ Create_String_Id (Arr.Name);
+ Create_Type (Arr.Element, N_Ctxt);
+ for I in 1 .. Arr.Nbr_Dim loop
+ Create_Type (Arr.Indexes (I - 1), N_Ctxt);
+ end loop;
+ end;
+ when Ghdl_Rtik_Subtype_Scalar =>
+ declare
+ Sub : Ghdl_Rtin_Subtype_Scalar_Acc;
+ begin
+ Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
+ Create_String_Id (Sub.Name);
+ Create_Type (Sub.Basetype, N_Ctxt);
+ end;
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_I64
+ | Ghdl_Rtik_Type_F64 =>
+ declare
+ Base : Ghdl_Rtin_Type_Scalar_Acc;
+ begin
+ Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
+ Create_String_Id (Base.Name);
+ end;
+ when Ghdl_Rtik_Type_P32
+ | Ghdl_Rtik_Type_P64 =>
+ declare
+ Base : Ghdl_Rtin_Type_Physical_Acc;
+ Unit_Name : Ghdl_C_String;
+ begin
+ Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Create_String_Id (Base.Name);
+ for I in 1 .. Base.Nbr loop
+ Unit_Name :=
+ Rtis_Utils.Get_Physical_Unit_Name (Base.Units (I - 1));
+ Create_String_Id (Unit_Name);
+ end loop;
+ end;
+ when Ghdl_Rtik_Type_Record =>
+ declare
+ Rec : Ghdl_Rtin_Type_Record_Acc;
+ El : Ghdl_Rtin_Element_Acc;
+ begin
+ Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti);
+ Create_String_Id (Rec.Name);
+ for I in 1 .. Rec.Nbrel loop
+ El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1));
+ Create_String_Id (El.Name);
+ Create_Type (El.Eltype, N_Ctxt);
+ end loop;
+ end;
+ when others =>
+ Internal_Error ("wave.create_type");
+-- Internal_Error ("wave.create_type: does not handle " &
+-- Ghdl_Rtik'Image (Rti.Kind));
+ end case;
+
+ -- Then, create the type.
+ Add_Type (Rti, N_Ctxt);
+ end Create_Type;
+
+ procedure Create_Object_Type (Obj : VhpiHandleT)
+ is
+ Obj_Type : VhpiHandleT;
+ Error : AvhpiErrorT;
+ Rti : Ghdl_Rti_Access;
+ begin
+ -- Extract type of the signal.
+ Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+ Rti := Avhpi_Get_Rti (Obj_Type);
+ Create_Type (Rti, Avhpi_Get_Context (Obj_Type));
+
+ -- The the signal type is an unconstrained array, also put the object
+ -- in the type AVL.
+ -- The real type will be written to the file.
+ if Rti.Kind = Ghdl_Rtik_Type_Array then
+ Add_Type (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
+ end if;
+ end Create_Object_Type;
+
+ procedure Write_Object_Type (Obj : VhpiHandleT)
+ is
+ Obj_Type : VhpiHandleT;
+ Error : AvhpiErrorT;
+ Rti : Ghdl_Rti_Access;
+ begin
+ -- Extract type of the signal.
+ Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+ Rti := Avhpi_Get_Rti (Obj_Type);
+ if Rti.Kind = Ghdl_Rtik_Type_Array then
+ Write_Type_Id (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
+ else
+ Write_Type_Id (Rti, Avhpi_Get_Context (Obj_Type));
+ end if;
+ end Write_Object_Type;
+
+ procedure Create_Generate_Type (Gen : VhpiHandleT)
+ is
+ Iterator : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ -- Extract the iterator.
+ Vhpi_Handle (VhpiIterScheme, Gen, Iterator, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+ Create_Object_Type (Iterator);
+ end Create_Generate_Type;
+
+ procedure Write_Generate_Type_And_Value (Gen : VhpiHandleT)
+ is
+ Iter : VhpiHandleT;
+ Iter_Type : VhpiHandleT;
+ Error : AvhpiErrorT;
+ Addr : Address;
+ Mode : Mode_Type;
+ Rti : Ghdl_Rti_Access;
+ begin
+ -- Extract the iterator.
+ Vhpi_Handle (VhpiIterScheme, Gen, Iter, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+ Write_Object_Type (Iter);
+
+ Vhpi_Handle (VhpiSubtype, Iter, Iter_Type, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+ Rti := Avhpi_Get_Rti (Iter_Type);
+ Addr := Avhpi_Get_Address (Iter);
+
+ case Get_Base_Type (Rti).Kind is
+ when Ghdl_Rtik_Type_B1 =>
+ Mode := Mode_B1;
+ when Ghdl_Rtik_Type_E8 =>
+ Mode := Mode_E8;
+ when Ghdl_Rtik_Type_E32 =>
+ Mode := Mode_E32;
+ when Ghdl_Rtik_Type_I32 =>
+ Mode := Mode_I32;
+ when Ghdl_Rtik_Type_I64 =>
+ Mode := Mode_I64;
+ when Ghdl_Rtik_Type_F64 =>
+ Mode := Mode_F64;
+ when others =>
+ Internal_Error ("bad iterator type");
+ end case;
+ Write_Value (To_Ghdl_Value_Ptr (Addr).all, Mode);
+ end Write_Generate_Type_And_Value;
+
+ type Step_Type is (Step_Name, Step_Hierarchy);
+
+ Nbr_Scopes : Natural := 0;
+ Nbr_Scope_Signals : Natural := 0;
+ Nbr_Dumped_Signals : Natural := 0;
+
+ -- This is only valid during write_hierarchy.
+ function Get_Signal_Number (Sig : Ghdl_Signal_Ptr) return Natural
+ is
+ function To_Integer_Address is new Ada.Unchecked_Conversion
+ (Ghdl_Signal_Ptr, Integer_Address);
+ begin
+ return Natural (To_Integer_Address (Sig.Alink));
+ end Get_Signal_Number;
+
+ procedure Write_Signal_Number (Val_Addr : Address;
+ Val_Name : Vstring;
+ Val_Type : Ghdl_Rti_Access;
+ Param_Type : Natural)
+ is
+ pragma Unreferenced (Val_Name);
+ pragma Unreferenced (Val_Type);
+ pragma Unreferenced (Param_Type);
+
+ Num : Natural;
+
+ function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion
+ (Source => Integer_Address, Target => Ghdl_Signal_Ptr);
+ Sig : Ghdl_Signal_Ptr;
+ begin
+ -- Convert to signal.
+ Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
+
+ -- Get signal number.
+ Num := Get_Signal_Number (Sig);
+
+ -- If the signal number is 0, then assign a valid signal number.
+ if Num = 0 then
+ Nbr_Dumped_Signals := Nbr_Dumped_Signals + 1;
+ Sig.Alink := To_Ghdl_Signal_Ptr
+ (Integer_Address (Nbr_Dumped_Signals));
+ Num := Nbr_Dumped_Signals;
+ end if;
+
+ -- Do the real job: write the signal number.
+ Wave_Put_ULEB128 (Ghdl_E32 (Num));
+ end Write_Signal_Number;
+
+ procedure Foreach_Scalar_Signal_Number is new
+ Grt.Rtis_Utils.Foreach_Scalar (Param_Type => Natural,
+ Process => Write_Signal_Number);
+
+ procedure Write_Signal_Numbers (Decl : VhpiHandleT)
+ is
+ Ctxt : Rti_Context;
+ Sig : Ghdl_Rtin_Object_Acc;
+ begin
+ Ctxt := Avhpi_Get_Context (Decl);
+ Sig := To_Ghdl_Rtin_Object_Acc (Avhpi_Get_Rti (Decl));
+ Foreach_Scalar_Signal_Number
+ (Ctxt, Sig.Obj_Type,
+ Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, 0);
+ end Write_Signal_Numbers;
+
+ procedure Write_Hierarchy_El (Decl : VhpiHandleT)
+ is
+ Mode2hie : constant array (VhpiModeT) of Unsigned_8 :=
+ (VhpiErrorMode => Ghw_Hie_Signal,
+ VhpiInMode => Ghw_Hie_Port_In,
+ VhpiOutMode => Ghw_Hie_Port_Out,
+ VhpiInoutMode => Ghw_Hie_Port_Inout,
+ VhpiBufferMode => Ghw_Hie_Port_Buffer,
+ VhpiLinkageMode => Ghw_Hie_Port_Linkage);
+ V : Unsigned_8;
+ begin
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiPortDeclK =>
+ V := Mode2hie (Vhpi_Get_Mode (Decl));
+ when VhpiSigDeclK =>
+ V := Ghw_Hie_Signal;
+ when VhpiForGenerateK =>
+ V := Ghw_Hie_Generate_For;
+ when VhpiIfGenerateK =>
+ V := Ghw_Hie_Generate_If;
+ when VhpiBlockStmtK =>
+ V := Ghw_Hie_Block;
+ when VhpiCompInstStmtK =>
+ V := Ghw_Hie_Instance;
+ when VhpiProcessStmtK =>
+ V := Ghw_Hie_Process;
+ when VhpiPackInstK =>
+ V := Ghw_Hie_Package;
+ when VhpiRootInstK =>
+ V := Ghw_Hie_Instance;
+ when others =>
+ --raise Program_Error;
+ Internal_Error ("write_hierarchy_el");
+ end case;
+ Wave_Put_Byte (V);
+ Write_String_Id (Avhpi_Get_Base_Name (Decl));
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ Write_Object_Type (Decl);
+ Write_Signal_Numbers (Decl);
+ when VhpiForGenerateK =>
+ Write_Generate_Type_And_Value (Decl);
+ when others =>
+ null;
+ end case;
+ end Write_Hierarchy_El;
+
+ -- Create a hierarchy block.
+ procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type);
+
+ procedure Wave_Put_Hierarchy_1 (Inst : VhpiHandleT; Step : Step_Type)
+ is
+ Decl_It : VhpiHandleT;
+ Decl : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ -- Extract signals.
+ loop
+ Vhpi_Scan (Decl_It, Decl, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiPortDeclK
+ | VhpiSigDeclK =>
+ case Step is
+ when Step_Name =>
+ Create_String_Id (Avhpi_Get_Base_Name (Decl));
+ Nbr_Scope_Signals := Nbr_Scope_Signals + 1;
+ Create_Object_Type (Decl);
+ when Step_Hierarchy =>
+ Write_Hierarchy_El (Decl);
+ end case;
+ --Wave_Put_Name (Decl);
+ --Wave_Newline;
+ when others =>
+ null;
+ end case;
+ end loop;
+
+ -- No sub-scopes for packages.
+ if Vhpi_Get_Kind (Inst) = VhpiPackInstK then
+ return;
+ end if;
+
+ -- Extract sub-scopes.
+ Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error);
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ loop
+ Vhpi_Scan (Decl_It, Decl, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ Nbr_Scopes := Nbr_Scopes + 1;
+
+ case Vhpi_Get_Kind (Decl) is
+ when VhpiIfGenerateK
+ | VhpiForGenerateK
+ | VhpiBlockStmtK
+ | VhpiCompInstStmtK =>
+ Wave_Put_Hierarchy_Block (Decl, Step);
+ when VhpiProcessStmtK =>
+ case Step is
+ when Step_Name =>
+ Create_String_Id (Avhpi_Get_Base_Name (Decl));
+ when Step_Hierarchy =>
+ Write_Hierarchy_El (Decl);
+ end case;
+ when others =>
+ Internal_Error ("wave_put_hierarchy_1");
+-- Wave_Put ("unknown ");
+-- Wave_Put (VhpiClassKindT'Image (Vhpi_Get_Kind (Decl)));
+-- Wave_Newline;
+ end case;
+ end loop;
+ end Wave_Put_Hierarchy_1;
+
+ procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type)
+ is
+ begin
+ case Step is
+ when Step_Name =>
+ Create_String_Id (Avhpi_Get_Base_Name (Inst));
+ if Vhpi_Get_Kind (Inst) = VhpiForGenerateK then
+ Create_Generate_Type (Inst);
+ end if;
+ when Step_Hierarchy =>
+ Write_Hierarchy_El (Inst);
+ end case;
+
+ Wave_Put_Hierarchy_1 (Inst, Step);
+
+ if Step = Step_Hierarchy then
+ Wave_Put_Byte (Ghw_Hie_Eos);
+ end if;
+ end Wave_Put_Hierarchy_Block;
+
+ procedure Wave_Put_Hierarchy (Root : VhpiHandleT; Step : Step_Type)
+ is
+ Pack_It : VhpiHandleT;
+ Pack : VhpiHandleT;
+ Error : AvhpiErrorT;
+ begin
+ -- First packages.
+ Get_Package_Inst (Pack_It);
+ loop
+ Vhpi_Scan (Pack_It, Pack, Error);
+ exit when Error = AvhpiErrorIteratorEnd;
+ if Error /= AvhpiErrorOk then
+ Avhpi_Error (Error);
+ return;
+ end if;
+
+ Wave_Put_Hierarchy_Block (Pack, Step);
+ end loop;
+
+ -- Then top entity.
+ Wave_Put_Hierarchy_Block (Root, Step);
+ end Wave_Put_Hierarchy;
+
+ procedure Disp_Str_AVL (Str : AVL_Nid; Indent : Natural)
+ is
+ begin
+ if Str = AVL_Nil then
+ return;
+ end if;
+ Disp_Str_AVL (Str_AVL.Table (Str).Left, Indent + 1);
+ for I in 1 .. Indent loop
+ Wave_Putc (' ');
+ end loop;
+ Wave_Puts (Str_Table.Table (Str_AVL.Table (Str).Val));
+-- Wave_Putc ('(');
+-- Put_I32 (Wave_Stream, Ghdl_I32 (Str));
+-- Wave_Putc (')');
+-- Put_I32 (Wave_Stream, Get_Height (Str));
+ Wave_Newline;
+ Disp_Str_AVL (Str_AVL.Table (Str).Right, Indent + 1);
+ end Disp_Str_AVL;
+
+ procedure Write_Strings
+ is
+ begin
+-- Wave_Put ("AVL height: ");
+-- Put_I32 (Wave_Stream, Ghdl_I32 (Check_AVL (Str_Root)));
+-- Wave_Newline;
+ Wave_Put ("strings length: ");
+ Put_I32 (Wave_Stream, Ghdl_I32 (Strings_Len));
+ Wave_Newline;
+ Disp_Str_AVL (AVL_Root, 0);
+ fflush (Wave_Stream);
+ end Write_Strings;
+
+ pragma Unreferenced (Write_Strings);
+
+ procedure Freeze_Strings
+ is
+ type Str_Table1_Type is array (1 .. Str_Table.Last) of Ghdl_C_String;
+ type Str_Table1_Acc is access Str_Table1_Type;
+ Idx : AVL_Value;
+ Table1 : Str_Table1_Acc;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Str_Table1_Type, Str_Table1_Acc);
+
+ procedure Store_Strings (N : AVL_Nid) is
+ begin
+ if N = AVL_Nil then
+ return;
+ end if;
+ Store_Strings (Str_AVL.Table (N).Left);
+ Table1 (Idx) := Str_Table.Table (Str_AVL.Table (N).Val);
+ Idx := Idx + 1;
+ Store_Strings (Str_AVL.Table (N).Right);
+ end Store_Strings;
+ begin
+ Table1 := new Str_Table1_Type;
+ Idx := 1;
+ Store_Strings (AVL_Root);
+ Str_Table.Release;
+ Str_AVL.Free;
+ for I in Table1.all'Range loop
+ Str_Table.Table (I) := Table1 (I);
+ end loop;
+ Free (Table1);
+ end Freeze_Strings;
+
+ procedure Write_Strings_Compress
+ is
+ Last : Ghdl_C_String;
+ V : Ghdl_C_String;
+ L : Natural;
+ L1 : Natural;
+ begin
+ Wave_Section ("STR" & NUL);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_I32 (Ghdl_I32 (Str_Table.Last));
+ Wave_Put_I32 (Ghdl_I32 (Strings_Len));
+ for I in Str_Table.First .. Str_Table.Last loop
+ V := Str_Table.Table (I);
+ if I = Str_Table.First then
+ L := 1;
+ else
+ Last := Str_Table.Table (I - 1);
+
+ for I in Positive loop
+ if V (I) /= Last (I) then
+ L := I;
+ exit;
+ end if;
+ end loop;
+ L1 := L - 1;
+ loop
+ if L1 >= 32 then
+ Wave_Put_Byte (Unsigned_8 (L1 mod 32) + 16#80#);
+ else
+ Wave_Put_Byte (Unsigned_8 (L1 mod 32));
+ end if;
+ L1 := L1 / 32;
+ exit when L1 = 0;
+ end loop;
+ end if;
+
+ if Boolean'(False) then
+ Put ("string ");
+ Put_I32 (stdout, Ghdl_I32 (I));
+ Put (": ");
+ Put (V);
+ New_Line;
+ end if;
+
+ loop
+ exit when V (L) = NUL;
+ Wave_Putc (V (L));
+ L := L + 1;
+ end loop;
+ end loop;
+ -- Last string length.
+ Wave_Put_Byte (0);
+ -- End marker.
+ Wave_Put ("EOS" & NUL);
+ end Write_Strings_Compress;
+
+ procedure Write_Range (Rti : Ghdl_Rti_Access; Rng : Ghdl_Range_Ptr)
+ is
+ Kind : Ghdl_Rtik;
+ begin
+ Kind := Rti.Kind;
+ if Kind = Ghdl_Rtik_Subtype_Scalar then
+ Kind := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype.Kind;
+ end if;
+ case Kind is
+ when Ghdl_Rtik_Type_B1 =>
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Kind)
+ + Ghdl_Dir_Type'Pos (Rng.B1.Dir) * 16#80#);
+ Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Left));
+ Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Right));
+ when Ghdl_Rtik_Type_E8 =>
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Kind)
+ + Ghdl_Dir_Type'Pos (Rng.E8.Dir) * 16#80#);
+ Wave_Put_Byte (Unsigned_8 (Rng.E8.Left));
+ Wave_Put_Byte (Unsigned_8 (Rng.E8.Right));
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_P32 =>
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Kind)
+ + Ghdl_Dir_Type'Pos (Rng.I32.Dir) * 16#80#);
+ Wave_Put_SLEB128 (Rng.I32.Left);
+ Wave_Put_SLEB128 (Rng.I32.Right);
+ when Ghdl_Rtik_Type_P64
+ | Ghdl_Rtik_Type_I64 =>
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Kind)
+ + Ghdl_Dir_Type'Pos (Rng.P64.Dir) * 16#80#);
+ Wave_Put_LSLEB128 (Rng.P64.Left);
+ Wave_Put_LSLEB128 (Rng.P64.Right);
+ when Ghdl_Rtik_Type_F64 =>
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Kind)
+ + Ghdl_Dir_Type'Pos (Rng.F64.Dir) * 16#80#);
+ Wave_Put_F64 (Rng.F64.Left);
+ Wave_Put_F64 (Rng.F64.Right);
+ when others =>
+ Internal_Error ("waves.write_range: unhandled kind");
+ --Internal_Error ("waves.write_range: unhandled kind "
+ -- & Ghdl_Rtik'Image (Kind));
+ end case;
+ end Write_Range;
+
+ procedure Write_Types
+ is
+ Rti : Ghdl_Rti_Access;
+ Ctxt : Rti_Context;
+ begin
+ Wave_Section ("TYP" & NUL);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_I32 (Ghdl_I32 (Types_Table.Last));
+ for I in Types_Table.First .. Types_Table.Last loop
+ Rti := Types_Table.Table (I).Type_Rti;
+ Ctxt := Types_Table.Table (I).Context;
+
+ if Rti.Kind = Ghdl_Rtik_Signal or Rti.Kind = Ghdl_Rtik_Port then
+ declare
+ Obj_Rti : constant Ghdl_Rtin_Object_Acc :=
+ To_Ghdl_Rtin_Object_Acc (Rti);
+ Arr : constant Ghdl_Rtin_Type_Array_Acc :=
+ To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type);
+ Addr : Ghdl_Uc_Array_Acc;
+ begin
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Ghdl_Rtik_Subtype_Array));
+ Write_String_Id (null);
+ Write_Type_Id (Obj_Rti.Obj_Type, Ctxt);
+ Addr := To_Ghdl_Uc_Array_Acc
+ (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt));
+ declare
+ Rngs : Ghdl_Range_Array (0 .. Arr.Nbr_Dim - 1);
+ begin
+ Bound_To_Range (Addr.Bounds, Arr, Rngs);
+ for I in Rngs'Range loop
+ Write_Range (Arr.Indexes (I), Rngs (I));
+ end loop;
+ end;
+ end;
+ else
+ -- Kind.
+ Wave_Put_Byte (Ghdl_Rtik'Pos (Rti.Kind));
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_E8 =>
+ declare
+ Enum : Ghdl_Rtin_Type_Enum_Acc;
+ begin
+ Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
+ Write_String_Id (Enum.Name);
+ Wave_Put_ULEB128 (Ghdl_E32 (Enum.Nbr));
+ for I in 1 .. Enum.Nbr loop
+ Write_String_Id (Enum.Names (I - 1));
+ end loop;
+ end;
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ Arr : Ghdl_Rtin_Subtype_Array_Acc;
+ begin
+ Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti);
+ Write_String_Id (Arr.Name);
+ Write_Type_Id (To_Ghdl_Rti_Access (Arr.Basetype), Ctxt);
+ declare
+ Rngs : Ghdl_Range_Array
+ (0 .. Arr.Basetype.Nbr_Dim - 1);
+ begin
+ Bound_To_Range
+ (Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt),
+ Arr.Basetype, Rngs);
+ for I in Rngs'Range loop
+ Write_Range (Arr.Basetype.Indexes (I), Rngs (I));
+ end loop;
+ end;
+ end;
+ when Ghdl_Rtik_Type_Array =>
+ declare
+ Arr : Ghdl_Rtin_Type_Array_Acc;
+ begin
+ Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti);
+ Write_String_Id (Arr.Name);
+ Write_Type_Id (Arr.Element, Ctxt);
+ Wave_Put_ULEB128 (Ghdl_E32 (Arr.Nbr_Dim));
+ for I in 1 .. Arr.Nbr_Dim loop
+ Write_Type_Id (Arr.Indexes (I - 1), Ctxt);
+ end loop;
+ end;
+ when Ghdl_Rtik_Type_Record =>
+ declare
+ Rec : Ghdl_Rtin_Type_Record_Acc;
+ El : Ghdl_Rtin_Element_Acc;
+ begin
+ Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti);
+ Write_String_Id (Rec.Name);
+ Wave_Put_ULEB128 (Ghdl_E32 (Rec.Nbrel));
+ for I in 1 .. Rec.Nbrel loop
+ El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1));
+ Write_String_Id (El.Name);
+ Write_Type_Id (El.Eltype, Ctxt);
+ end loop;
+ end;
+ when Ghdl_Rtik_Subtype_Scalar =>
+ declare
+ Sub : Ghdl_Rtin_Subtype_Scalar_Acc;
+ begin
+ Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
+ Write_String_Id (Sub.Name);
+ Write_Type_Id (Sub.Basetype, Ctxt);
+ Write_Range
+ (Sub.Basetype,
+ To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth,
+ Sub.Range_Loc,
+ Ctxt)));
+ end;
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_I64
+ | Ghdl_Rtik_Type_F64 =>
+ declare
+ Base : Ghdl_Rtin_Type_Scalar_Acc;
+ begin
+ Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
+ Write_String_Id (Base.Name);
+ end;
+ when Ghdl_Rtik_Type_P32
+ | Ghdl_Rtik_Type_P64 =>
+ declare
+ Base : Ghdl_Rtin_Type_Physical_Acc;
+ Unit : Ghdl_Rti_Access;
+ begin
+ Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Write_String_Id (Base.Name);
+ Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr));
+ for I in 1 .. Base.Nbr loop
+ Unit := Base.Units (I - 1);
+ Write_String_Id
+ (Rtis_Utils.Get_Physical_Unit_Name (Unit));
+ case Unit.Kind is
+ when Ghdl_Rtik_Unit64 =>
+ Wave_Put_LSLEB128
+ (To_Ghdl_Rtin_Unit64_Acc (Unit).Value);
+ when Ghdl_Rtik_Unitptr =>
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ Wave_Put_LSLEB128
+ (To_Ghdl_Rtin_Unitptr_Acc (Unit).
+ Addr.I64);
+ when Ghdl_Rtik_Type_P32 =>
+ Wave_Put_SLEB128
+ (To_Ghdl_Rtin_Unitptr_Acc (Unit).
+ Addr.I32);
+ when others =>
+ Internal_Error
+ ("wave.write_types(P32/P64-1)");
+ end case;
+ when others =>
+ Internal_Error
+ ("wave.write_types(P32/P64-2)");
+ end case;
+ end loop;
+ end;
+ when others =>
+ Internal_Error ("wave.write_types");
+ -- Internal_Error ("wave.write_types: does not handle " &
+ -- Ghdl_Rtik'Image (Rti.Kind));
+ end case;
+ end if;
+ end loop;
+ Wave_Put_Byte (0);
+ end Write_Types;
+
+ procedure Write_Known_Types
+ is
+ use Grt.Rtis_Types;
+
+ Boolean_Type_Id : AVL_Nid;
+ Bit_Type_Id : AVL_Nid;
+ Std_Ulogic_Type_Id : AVL_Nid;
+
+ function Search_Type_Id (Rti : Ghdl_Rti_Access) return AVL_Nid
+ is
+ Ctxt : Rti_Context;
+ Tid : AVL_Nid;
+ begin
+ Find_Type (Rti, Null_Context, Ctxt, Tid);
+ return Tid;
+ end Search_Type_Id;
+ begin
+ Search_Types_RTI;
+
+ Boolean_Type_Id := Search_Type_Id (Std_Standard_Boolean_RTI_Ptr);
+
+ Bit_Type_Id := Search_Type_Id (Std_Standard_Bit_RTI_Ptr);
+
+ if Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr /= null then
+ Std_Ulogic_Type_Id := Search_Type_Id
+ (Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr);
+ else
+ Std_Ulogic_Type_Id := AVL_Nil;
+ end if;
+
+ Wave_Section ("WKT" & NUL);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+
+ if Boolean_Type_Id /= AVL_Nil then
+ Wave_Put_Byte (1);
+ Write_Type_Id (Boolean_Type_Id);
+ end if;
+
+ if Bit_Type_Id /= AVL_Nil then
+ Wave_Put_Byte (2);
+ Write_Type_Id (Bit_Type_Id);
+ end if;
+
+ if Std_Ulogic_Type_Id /= AVL_Nil then
+ Wave_Put_Byte (3);
+ Write_Type_Id (Std_Ulogic_Type_Id);
+ end if;
+
+ Wave_Put_Byte (0);
+ end Write_Known_Types;
+
+ -- Table of signals to be dumped.
+ package Dump_Table is new Grt.Table
+ (Table_Component_Type => Ghdl_Signal_Ptr,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 32);
+
+ function Get_Dump_Entry (N : Natural) return Ghdl_Signal_Ptr is
+ begin
+ return Dump_Table.Table (N);
+ end Get_Dump_Entry;
+
+ pragma Unreferenced (Get_Dump_Entry);
+
+ procedure Write_Hierarchy (Root : VhpiHandleT)
+ is
+ N : Natural;
+ begin
+ -- Check Alink is 0.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ if Sig_Table.Table (I).Alink /= null then
+ Internal_Error ("wave.write_hierarchy");
+ end if;
+ end loop;
+
+ Wave_Section ("HIE" & NUL);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_I32 (Ghdl_I32 (Nbr_Scopes));
+ Wave_Put_I32 (Ghdl_I32 (Nbr_Scope_Signals));
+ Wave_Put_I32 (Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1));
+ Wave_Put_Hierarchy (Root, Step_Hierarchy);
+ Wave_Put_Byte (0);
+
+ Dump_Table.Set_Last (Nbr_Dumped_Signals);
+ for I in Dump_Table.First .. Dump_Table.Last loop
+ Dump_Table.Table (I) := null;
+ end loop;
+
+ -- Save and clear.
+ for I in Sig_Table.First .. Sig_Table.Last loop
+ N := Get_Signal_Number (Sig_Table.Table (I));
+ if N /= 0 then
+ if Dump_Table.Table (N) /= null then
+ Internal_Error ("wave.write_hierarchy(2)");
+ end if;
+ Dump_Table.Table (N) := Sig_Table.Table (I);
+ Sig_Table.Table (I).Alink := null;
+ end if;
+ end loop;
+ end Write_Hierarchy;
+
+ procedure Write_Signal_Value (Sig : Ghdl_Signal_Ptr) is
+ begin
+ -- FIXME: for some signals, the significant value is the driving value!
+ Write_Value (Sig.Value, Sig.Mode);
+ end Write_Signal_Value;
+
+ procedure Write_Snapshot is
+ begin
+ Wave_Section ("SNP" & NUL);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_Byte (0);
+ Wave_Put_I64 (Ghdl_I64 (Cycle_Time));
+
+ for I in Dump_Table.First .. Dump_Table.Last loop
+ Write_Signal_Value (Dump_Table.Table (I));
+ end loop;
+ Wave_Put ("ESN" & NUL);
+ end Write_Snapshot;
+
+ procedure Wave_Cycle;
+
+ -- Called after elaboration.
+ procedure Wave_Start
+ is
+ Root : VhpiHandleT;
+ begin
+ -- Do nothing if there is no VCD file to generate.
+ if Wave_Stream = NULL_Stream then
+ return;
+ end if;
+
+ Write_File_Header;
+
+ -- FIXME: write infos
+ -- * date
+ -- * timescale
+ -- * design name ?
+ -- ...
+
+ -- Put hierarchy.
+ Get_Root_Inst (Root);
+ -- Vcd_Search_Packages;
+ Wave_Put_Hierarchy (Root, Step_Name);
+
+ Freeze_Strings;
+
+ -- Register_Cycle_Hook (Vcd_Cycle'Access);
+ Write_Strings_Compress;
+ Write_Types;
+ Write_Known_Types;
+ Write_Hierarchy (Root);
+
+ -- End of header mark.
+ Wave_Section ("EOH" & NUL);
+
+ Write_Snapshot;
+
+ Register_Cycle_Hook (Wave_Cycle'Access);
+
+ fflush (Wave_Stream);
+ end Wave_Start;
+
+ Wave_Time : Std_Time := 0;
+ In_Cyc : Boolean := False;
+
+ procedure Wave_Close_Cyc
+ is
+ begin
+ Wave_Put_LSLEB128 (-1);
+ Wave_Put ("ECY" & NUL);
+ In_Cyc := False;
+ end Wave_Close_Cyc;
+
+ procedure Wave_Cycle
+ is
+ Diff : Std_Time;
+ Sig : Ghdl_Signal_Ptr;
+ Last : Natural;
+ begin
+ if not In_Cyc then
+ Wave_Section ("CYC" & NUL);
+ Wave_Put_I64 (Ghdl_I64 (Cycle_Time));
+ In_Cyc := True;
+ else
+ Diff := Cycle_Time - Wave_Time;
+ Wave_Put_LSLEB128 (Ghdl_I64 (Diff));
+ end if;
+ Wave_Time := Cycle_Time;
+
+ -- Dump signals.
+ Last := 0;
+ for I in Dump_Table.First .. Dump_Table.Last loop
+ Sig := Dump_Table.Table (I);
+ if Sig.Flags.Cyc_Event then
+ Wave_Put_ULEB128 (Ghdl_U32 (I - Last));
+ Last := I;
+ Write_Signal_Value (Sig);
+ Sig.Flags.Cyc_Event := False;
+ end if;
+ end loop;
+ Wave_Put_Byte (0);
+ end Wave_Cycle;
+
+ -- Called at the end of the simulation.
+ procedure Wave_End is
+ begin
+ if Wave_Stream = NULL_Stream then
+ return;
+ end if;
+ if In_Cyc then
+ Wave_Close_Cyc;
+ end if;
+ Wave_Write_Directory;
+ fflush (Wave_Stream);
+ end Wave_End;
+
+ Wave_Hooks : aliased constant Hooks_Type :=
+ (Option => Wave_Option'Access,
+ Help => Wave_Help'Access,
+ Init => Wave_Init'Access,
+ Start => Wave_Start'Access,
+ Finish => Wave_End'Access);
+
+ procedure Register is
+ begin
+ Register_Hooks (Wave_Hooks'Access);
+ end Register;
+end Grt.Waves;
diff --git a/src/translate/grt/grt-waves.ads b/src/translate/grt/grt-waves.ads
new file mode 100644
index 000000000..72d7ea6e1
--- /dev/null
+++ b/src/translate/grt/grt-waves.ads
@@ -0,0 +1,27 @@
+-- GHDL Run Time (GRT) - wave dumper (GHW) module.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+package Grt.Waves is
+ procedure Register;
+end Grt.Waves;
diff --git a/src/translate/grt/grt-zlib.ads b/src/translate/grt/grt-zlib.ads
new file mode 100644
index 000000000..9dfee3665
--- /dev/null
+++ b/src/translate/grt/grt-zlib.ads
@@ -0,0 +1,47 @@
+-- GHDL Run Time (GRT) - Zlib binding.
+-- Copyright (C) 2005 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+with System; use System;
+with Grt.C; use Grt.C;
+
+package Grt.Zlib is
+ pragma Linker_Options ("-lz");
+
+ type gzFile is new System.Address;
+
+ NULL_gzFile : constant gzFile := gzFile (System'To_Address (0));
+
+ function gzputc (File : gzFile; C : int) return int;
+ pragma Import (C, gzputc);
+
+ function gzwrite (File : gzFile; Buf : voids; Len : int) return int;
+ pragma Import (C, gzwrite);
+
+ function gzopen (Path : chars; Mode : chars) return gzFile;
+ pragma Import (C, gzopen);
+
+ procedure gzclose (File : gzFile);
+ pragma Import (C, gzclose);
+end Grt.Zlib;
diff --git a/src/translate/grt/grt.adc b/src/translate/grt/grt.adc
new file mode 100644
index 000000000..f2284997d
--- /dev/null
+++ b/src/translate/grt/grt.adc
@@ -0,0 +1,46 @@
+-- GHDL Run Time (GRT) - Configuration pragmas.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+-- The GRT library is built with a lot of restrictions.
+-- The purpose of these restrictions (mainly No_Run_Time) is not to link with
+-- the GNAT run time library. The user does not need to download or compile
+-- it.
+--
+-- However, GRT works without these restrictions. If you want to use GRT
+-- in Ada, you may compile GRT without these restrictions (remove the -gnatec
+-- flag).
+--
+-- This files is *not* names gnat.adc, in order to ease the possibility of
+-- not using it.
+pragma Restrictions (No_Exception_Handlers);
+--pragma restrictions (No_Exceptions);
+pragma Restrictions (No_Secondary_Stack);
+--pragma Restrictions (No_Elaboration_Code);
+pragma Restrictions (No_Io);
+pragma restrictions (no_dependence => Ada.Tags);
+pragma restrictions (no_dependence => GNAT);
+pragma Restrictions (Max_Tasks => 0);
+pragma Restrictions (No_Implicit_Heap_Allocations);
+pragma No_Run_Time;
diff --git a/src/translate/grt/grt.ads b/src/translate/grt/grt.ads
new file mode 100644
index 000000000..9727d0430
--- /dev/null
+++ b/src/translate/grt/grt.ads
@@ -0,0 +1,27 @@
+-- GHDL Run Time (GRT) - Top of hierarchy.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+package Grt is
+ pragma Pure (Grt);
+end Grt;
diff --git a/src/translate/grt/grt.ver b/src/translate/grt/grt.ver
new file mode 100644
index 000000000..031c20761
--- /dev/null
+++ b/src/translate/grt/grt.ver
@@ -0,0 +1,25 @@
+{
+ global:
+vpi_free_object;
+vpi_get;
+vpi_get_str;
+vpi_get_time;
+vpi_get_value;
+vpi_get_vlog_info;
+vpi_handle;
+vpi_handle_by_index;
+vpi_iterate;
+vpi_mcd_close;
+vpi_mcd_name;
+vpi_mcd_open;
+vpi_put_value;
+vpi_register_cb;
+vpi_register_systf;
+vpi_remove_cb;
+vpi_scan;
+vpi_vprintf;
+vpi_printf;
+ local:
+ *;
+};
+
diff --git a/src/translate/grt/main.adb b/src/translate/grt/main.adb
new file mode 100644
index 000000000..5de379449
--- /dev/null
+++ b/src/translate/grt/main.adb
@@ -0,0 +1,32 @@
+-- GHDL Run Time (GRT) - C-like entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+with Ghdl_Main;
+
+function Main (Argc : Integer; Argv : System.Address)
+ return Integer
+is
+begin
+ return Ghdl_Main (Argc, Argv);
+end Main;
diff --git a/src/translate/grt/main.ads b/src/translate/grt/main.ads
new file mode 100644
index 000000000..f7c414274
--- /dev/null
+++ b/src/translate/grt/main.ads
@@ -0,0 +1,34 @@
+-- GHDL Run Time (GRT) - C-like entry point.
+-- Copyright (C) 2002 - 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GCC; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+--
+-- As a special exception, if other files instantiate generics from this
+-- unit, or you link this unit with other files to produce an executable,
+-- this unit does not by itself cause the resulting executable to be
+-- covered by the GNU General Public License. This exception does not
+-- however invalidate any other reasons why the executable file might be
+-- covered by the GNU Public License.
+
+-- In the usual case of a standalone executable, this file defines the
+-- standard entry point, ie the main() function.
+--
+-- However, as explained in the manual, the user can use its own main()
+-- function, and calls the ghdl entry point ghdl_main.
+with System;
+
+function Main (Argc : Integer; Argv : System.Address) return Integer;
+pragma Export (C, Main, "main");
diff --git a/src/translate/mcode/Makefile.in b/src/translate/mcode/Makefile.in
new file mode 100644
index 000000000..beb450a08
--- /dev/null
+++ b/src/translate/mcode/Makefile.in
@@ -0,0 +1,54 @@
+PREFIX=/usr/local
+target=i686-pc-linux-gnu
+
+CFLAGS=-O
+GNATFLAGS=$(CFLAGS) -gnatn
+
+GRT_FLAGS=$(CFLAGS)
+
+all: ghdl_mcode std.v93 std.v87 ieee.v93 ieee.v87 synopsys.v93 synopsys.v87 mentor.v93
+
+
+GRTSRCDIR=grt
+
+####grt Makefile.inc
+
+ghdl_mcode: default_pathes.ads $(GRT_ADD_OBJS) mmap_binding.o force
+ gnatmake -aIghdldrv -aIghdl -aIortho -aIgrt $(GNATFLAGS) ghdl_mcode $(GNAT_BARGS) -largs mmap_binding.o $(GNAT_LARGS) $(GRT_ADD_OBJS) $(GRT_EXTRA_LIB) -Wl,--version-script=$(GRTSRCDIR)/grt.ver -Wl,--export-dynamic
+
+mmap_binding.o: ortho/mmap_binding.c
+ $(CC) -c -g -o $@ $<
+
+default_pathes.ads: Makefile
+ echo "-- DO NOT EDIT" > tmp-dpathes.ads
+ echo "-- This file is created by Makefile" >> tmp-dpathes.ads
+ echo "package Default_Pathes is" >> tmp-dpathes.ads
+ echo " Prefix : constant String :=">> tmp-dpathes.ads
+ echo " \"$(PREFIX)/lib/ghdl/\";" >> tmp-dpathes.ads
+ echo "end Default_Pathes;" >> tmp-dpathes.ads
+ if test -r $@ && cmp tmp-dpathes.ads $@; then \
+ echo "$@ unchanged"; \
+ else \
+ mv tmp-dpathes.ads $@; \
+ fi
+ $(RM) tmp-dpathes.ads
+
+force:
+
+LIB93_DIR:=./lib/v93
+LIB87_DIR:=./lib/v87
+LIBSRC_DIR:=./libraries
+ANALYZE=../../../ghdl_mcode -a --ieee=none
+REL_DIR=../../..
+VHDLLIBS_COPY_OBJS:=no
+CP=cp
+LN=ln -s
+
+./lib:
+ mkdir $@
+
+$(LIB93_DIR) $(LIB87_DIR): ./lib
+ mkdir $@
+
+
+####libraries Makefile.inc
diff --git a/src/translate/mcode/README b/src/translate/mcode/README
new file mode 100644
index 000000000..a10cd6efc
--- /dev/null
+++ b/src/translate/mcode/README
@@ -0,0 +1,47 @@
+This is the README from the source distribution of GHDL.
+
+To get the binary distribution or more information, go to http://ghdl.free.fr
+
+Copyright:
+**********
+GHDL is copyright (c) 2002, 2003, 2004, 2005 Tristan Gingold.
+See the GHDL manual for more details.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.
+
+
+Building GHDL from sources for Windows:
+***************************************
+
+Note: this was tested with Windows XP SP2 familly edition.
+
+Note: If you want to create the installer, GHDL should be built on a
+FAT partition. NSIS rounds files date to be FAT compliant (seconds are always
+even) and because GHDL stores dates, the files date must not be modified.
+
+Required:
+* the Ada95 GNAT compiler (GNAT GPL 2005 is known to work).
+* NSIS to create the installer.
+
+Unzip,
+edit winbuild to use correct path for makensis,
+run winbuild.
+
+The installer is in the windows directory.
+
+Send bugs and comments on http://gna.org/project/ghdl
+
+Tristan Gingold.
diff --git a/src/translate/mcode/dist.sh b/src/translate/mcode/dist.sh
new file mode 100755
index 000000000..cf24141de
--- /dev/null
+++ b/src/translate/mcode/dist.sh
@@ -0,0 +1,506 @@
+#!/bin/sh
+
+# Script used to create tar balls.
+# Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+#
+# GHDL is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2, or (at your option) any later
+# version.
+#
+# GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+# for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING. If not, write to the Free
+# Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+
+# Building a distribution:
+# * update the 'version' variable in ../../Makefile
+# * Regenerate version.ads: make -f ../../Makefile version.ads
+# * Check NEWS, README and INSTALL files.
+# * Check version and copyright years in doc/ghdl.texi, ghdlmain.adb
+# * Check GCCVERSION below.
+# * Check lists of exported files in this file.
+# * Create source tar and build binaries: ./dist.sh dist_phase1
+# * su root
+# * Build binary tar: ./dist.sh dist_phase2
+# * Run the testsuites: GHDL=ghdl ./testsuite.sh
+# * Update website/index.html (./dist.sh website helps, rename .new)
+# * upload (./dist upload)
+# * CVS commit, tag + cd image.
+# * remove previous version in /usr/local
+
+## DO NOT MODIFY this file while it is running...
+
+set -e
+
+# GTKWave version.
+GTKWAVE_VERSION=1.3.72
+
+# GHDL version (extracted from version.ads)
+VERSION=`sed -n -e 's/.*GHDL \([0-9.a-z]*\) (.*/\1/p' ../../version.ads`
+
+CWD=`pwd`
+
+distdir=ghdl-$VERSION
+tarfile=$distdir.tar
+zipfile=$distdir.zip
+
+PREFIX=/usr/local
+bindirname=ghdl-$VERSION-i686-pc-linux
+TARINSTALL=$DISTDIR/$bindirname.tar.bz2
+VHDLDIR=$distdir/vhdl
+DOWNLOAD_HTML=../../website/download.html
+DESTDIR=$CWD/
+UNSTRIPDIR=${distdir}-unstripped
+
+PATH=/usr/gnat/bin:$PATH
+
+do_clean ()
+{
+ rm -rf $distdir
+ mkdir $distdir
+ mkdir $distdir/ghdl
+ mkdir $distdir/ghdldrv
+ mkdir $distdir/libraries
+ mkdir $distdir/libraries/std $distdir/libraries/ieee
+ mkdir $distdir/libraries/vital95 $distdir/libraries/vital2000
+ mkdir $distdir/libraries/synopsys $distdir/libraries/mentor
+ mkdir $distdir/grt
+ mkdir $distdir/grt/config
+ mkdir $distdir/ortho
+ mkdir $distdir/windows
+}
+
+# Build Makefile
+do_Makefile ()
+{
+ sed -e "/^####libraries Makefile.inc/r ../../libraries/Makefile.inc" \
+ -e "/^####grt Makefile.inc/r ../grt/Makefile.inc" \
+ < Makefile.in > $distdir/Makefile
+}
+
+# Copy (or link) sources files into $distdir
+do_files ()
+{
+. ../gcc/dist-common.sh
+
+ortho_mcode_files="
+binary_file-elf.adb
+binary_file-elf.ads
+binary_file-memory.adb
+binary_file-memory.ads
+binary_file.adb
+binary_file.ads
+disa_x86.adb
+disa_x86.ads
+disassemble.ads
+dwarf.ads
+elf32.adb
+elf32.ads
+elf64.ads
+elf_common.adb
+elf_common.ads
+elf_arch32.ads
+elf_arch.ads
+hex_images.adb
+hex_images.ads
+memsegs.ads
+memsegs_mmap.ads
+memsegs_mmap.adb
+memsegs_c.c
+ortho_code-abi.ads
+ortho_code-binary.adb
+ortho_code-binary.ads
+ortho_code-consts.adb
+ortho_code-consts.ads
+ortho_code-debug.adb
+ortho_code-debug.ads
+ortho_code-decls.adb
+ortho_code-decls.ads
+ortho_code-disps.adb
+ortho_code-disps.ads
+ortho_code-dwarf.adb
+ortho_code-dwarf.ads
+ortho_code-exprs.adb
+ortho_code-exprs.ads
+ortho_code-flags.ads
+ortho_code-opts.adb
+ortho_code-opts.ads
+ortho_code-types.adb
+ortho_code-types.ads
+ortho_code-sysdeps.adb
+ortho_code-sysdeps.ads
+ortho_code-x86-emits.adb
+ortho_code-x86-emits.ads
+ortho_code-x86-insns.adb
+ortho_code-x86-insns.ads
+ortho_code-x86-abi.adb
+ortho_code-x86-abi.ads
+ortho_code-x86-flags.ads
+ortho_code-x86.adb
+ortho_code-x86.ads
+ortho_code.ads
+ortho_code_main.adb
+ortho_ident.adb
+ortho_ident.ads
+ortho_mcode.adb
+ortho_mcode.ads
+ortho_nodes.ads
+"
+
+windows_files="
+compile.bat
+complib.bat
+default_pathes.ads
+ghdl.nsi
+windows_default_path.adb
+windows_default_path.ads
+ghdlfilter.adb
+ortho_code-sysdeps.adb
+grt-modules.adb
+"
+
+drv_files="
+ghdlcomp.ads
+ghdlcomp.adb
+foreigns.ads
+foreigns.adb
+ghdlrun.adb
+ghdlrun.ads
+ghdl_mcode.adb
+"
+
+for i in $cfiles; do ln -sf $CWD/../../$i $distdir/ghdl/$i; done
+for i in $tfiles; do ln -sf $CWD/../$i $distdir/ghdl/$i; done
+
+ln -sf $CWD/../../doc/ghdl.texi $distdir/ghdl.texi
+
+for i in $ortho_files; do ln -sf $CWD/../../ortho/$i $distdir/ortho/$i; done
+
+for i in $ortho_mcode_files; do
+ ln -sf $CWD/../../ortho/mcode/$i $distdir/ortho/$i
+done
+
+for i in $ghdl_files $drv_files; do
+ ln -sf $CWD/../ghdldrv/$i $distdir/ghdldrv/$i
+done
+
+for i in $libraries_files; do
+ ln -sf $CWD/../../libraries/$i $distdir/libraries/$i
+done
+
+for i in $grt_files; do
+ ln -sf $CWD/../grt/$i $distdir/grt/$i
+done
+
+for i in $grt_config_files; do
+ ln -sf $CWD/../grt/config/$i $distdir/grt/config/$i
+done
+
+for i in $windows_files; do
+ ln -sf $CWD/windows/$i $distdir/windows/$i
+done
+ echo "!define VERSION \"$VERSION\"" > $distdir/windows/version.nsi
+
+
+ ln -sf $CWD/winbuild.bat $distdir/winbuild.bat
+
+makeinfo --html --no-split -o $distdir/windows/ghdl.htm $CWD/../../doc/ghdl.texi
+}
+
+do_sources_dir ()
+{
+ \rm -rf $distdir
+ mkdir $distdir
+ do_clean
+ do_Makefile
+ do_files
+ ln -sf ../../../COPYING $distdir
+}
+
+# Create the tar of sources.
+do_tar ()
+{
+ do_sources_dir
+ tar cvhf $tarfile $distdir
+ bzip2 -f $tarfile
+ rm -rf $distdir
+}
+
+# Create the zip of sources.
+do_zip ()
+{
+ do_sources_dir
+ zip -r $zipfile $distdir
+ rm -rf $distdir
+}
+
+# Extract the source, configure and make.
+do_compile ()
+{
+ set -x
+
+ do_update_gcc_sources;
+
+ rm -rf $GCCDISTOBJ
+ mkdir $GCCDISTOBJ
+ cd $GCCDISTOBJ
+ ../gcc-$GCCVERSION/configure --enable-languages=vhdl --prefix=$PREFIX
+ make CFLAGS="-O -g"
+ make -C gcc vhdl.info
+ cd $CWD
+}
+
+check_root ()
+{
+ if [ $UID -ne 0 ]; then
+ echo "$0: you must be root";
+ exit 1;
+ fi
+}
+
+# Do a make install
+do_compile2 ()
+{
+ set -x
+ cd $GCCDISTOBJ
+ # Check the info file is not empty.
+ if [ -s gcc/doc/ghdl.info ]; then
+ echo "info file found"
+ else
+ echo "Error: ghdl.info not found".
+ exit 1;
+ fi
+ mkdir -p $DESTDIR/usr/local || true
+ make DESTDIR=$DESTDIR install
+ cd $CWD
+ if [ -d $UNSTRIPDIR ]; then
+ rm -rf $UNSTRIPDIR
+ fi
+ mkdir $UNSTRIPDIR
+ cp ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl $UNSTRIPDIR
+ chmod -w $UNSTRIPDIR/*
+ strip ${DESTDIR}${GCCLIBEXECDIR}/ghdl1 ${DESTDIR}${PREFIX}/bin/ghdl
+}
+
+# Create the tar file from the current installation.
+do_tar_install ()
+{
+ tar -C $DESTDIR -jcvf $TARINSTALL \
+ ./$PREFIX/bin/ghdl ./$PREFIX/info/ghdl.info \
+ ./$GCCLIBDIR/vhdl \
+ ./$GCCLIBEXECDIR/ghdl1
+}
+
+do_extract_tar_install ()
+{
+ check_root;
+ cd /
+ tar jxvf $TARINSTALL
+ cd $CWD
+}
+
+# Create the tar file to be distributed.
+do_tar_dist ()
+{
+ rm -rf $bindirname
+ mkdir $bindirname
+ sed -e "s/@TARFILE@/$dir.tar/" < INSTALL > $bindirname/INSTALL
+ ln ../../COPYING $bindirname
+ ln $TARINSTALL $bindirname
+ tar cvf $bindirname.tar $bindirname
+}
+
+# Remove the non-ghdl files of gcc in the current installation.
+do_distclean_gcc ()
+{
+ set -x
+ rm -f ${DESTDIR}${PREFIX}/bin/cpp ${DESTDIR}${PREFIX}/bin/gcc
+ rm -f ${DESTDIR}${PREFIX}/bin/gccbug ${DESTDIR}${PREFIX}/bin/gcov
+ rm -f ${DESTDIR}${PREFIX}/bin/${MACHINE}-gcc*
+ rm -f ${DESTDIR}${PREFIX}/info/cpp.info*
+ rm -f ${DESTDIR}${PREFIX}/info/cppinternals.info*
+ rm -f ${DESTDIR}${PREFIX}/info/gcc.info*
+ rm -f ${DESTDIR}${PREFIX}/info/gccinstall.info*
+ rm -f ${DESTDIR}${PREFIX}/info/gccint.info*
+ rm -f ${DESTDIR}${PREFIX}/lib/*.a ${DESTDIR}${PREFIX}/lib/*.so*
+ rm -rf ${DESTDIR}${PREFIX}/share
+ rm -rf ${DESTDIR}${PREFIX}/man
+ rm -rf ${DESTDIR}${PREFIX}/include
+ rm -f ${DESTDIR}${GCCLIBEXECDIR}/cc1 ${DESTDIR}${GCCLIBEXECDIR}/collect2
+ rm -f ${DESTDIR}${GCCLIBEXECDIR}/cpp0 ${DESTDIR}${GCCLIBEXECDIR}/tradcpp0
+ rm -f ${DESTDIR}${GCCLIBDIR}/*.o ${DESTDIR}$GCCLIBDIR/*.a
+ rm -f ${DESTDIR}${GCCLIBDIR}/specs
+ rm -rf ${DESTDIR}${GCCLIBDIR}/include
+ rm -rf ${DESTDIR}${GCCLIBDIR}/install-tools
+ rm -rf ${DESTDIR}${GCCLIBEXECDIR}/install-tools
+}
+
+# Remove ghdl files in the current installation.
+do_distclean_ghdl ()
+{
+ check_root;
+ set -x
+ rm -f $PREFIX/bin/ghdl
+ rm -f $PREFIX/info/ghdl.info*
+ rm -f $GCCLIBEXECDIR/ghdl1
+ rm -rf $GCCLIBDIR/vhdl
+}
+
+# Build the source tar, and build the binaries.
+do_dist_phase1 ()
+{
+ do_sources;
+ do_compile;
+ do_compile2;
+ do_distclean_gcc;
+ do_tar_install;
+ do_tar_dist;
+ rm -rf ./$PREFIX
+}
+
+# Install the binaries and create the binary tar.
+do_dist_phase2 ()
+{
+ check_root;
+ do_distclean_ghdl;
+ do_extract_tar_install;
+ echo "dist_phase2 success"
+}
+
+# Create gtkwave patch
+do_gtkwave_patch ()
+{
+# rm -rf gtkwave-patch
+ mkdir gtkwave-patch
+ diff -rc -x Makefile.in $GTKWAVE_BASE.orig $GTKWAVE_BASE | \
+ sed -e "/^Only in/d" \
+ > gtkwave-patch/gtkwave-$GTKWAVE_VERSION.diffs
+ cp ../grt/ghwlib.c ../grt/ghwlib.h $GTKWAVE_BASE/src/ghw.c gtkwave-patch
+ sed -e "s/VERSION/$GTKWAVE_VERSION/g" < README.gtkwave > gtkwave-patch/README
+ tar zcvf ../../website/gtkwave-patch.tgz gtkwave-patch
+ rm -rf gtkwave-patch
+}
+
+# Update the index.html
+# Update the doc
+do_website ()
+{
+ sed -e "
+/SRC-HREF/ s/href=\".*\"/href=\"$tarfile.bz2\"/
+/BIN-HREF/ s/href=\".*\"/href=\"$bindirname.tar\"/
+/HISTORY/ a \\
+