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-